I used the following vb script to add everybody I send an email to into my outlook address book at work.
The reason for this is, that Oulook does not remember every e-mail address used, so this helps to get autocompletion in the recipient field writing a new mail.
I forgot where I got the original code from, but I left the comment as they were.
In Outlook press Alt + F11 to get into the macroview, then add the code to the Project1 – ThisOutlookSession section.
' sample Outlook 2003 VBA application by Sue Mosher ' send questions/comments to webmaster a outlookcode dot com ' The Application_ItemSend procedure must go in the ' built-in ThisOutlookSession session module in Outlook VBA Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) If Item.Class = olMail Then Call AddRecipToContacts(Item) End If Set Item = Nothing End Sub ' This procedure can go in any module Sub AddRecipToContacts(objMail As Outlook.MailItem) Dim strFind As String Dim strAddress As String Dim objNS As Outlook.NameSpace Dim colContacts As Outlook.Items Dim objContact As Outlook.ContactItem Dim objRecip As Outlook.Recipient Dim i As Integer On Error Resume Next ' get Contacts folder and its Items collection Set objNS = Application.GetNamespace("MAPI") Set colContacts = _ objNS.GetDefaultFolder(olFolderContacts).Items ' process message recipients For Each objRecip In objMail.Recipients ' check to see if the recip is already in Contacts If objRecip.AddressEntry.Type <> "EX" Then strAddress = AddQuote(objRecip.Address) For i = 1 To 3 strFind = "[Email" & i & "Address] = " & _ strAddress Set objContact = colContacts.Find(strFind) If Not objContact Is Nothing Then Exit For End If Next ' if not, add it If objContact Is Nothing Then Set objContact = _ Application.CreateItem(olContactItem) With objContact Dim RecipName As String Dim atPos As Integer RecipName = Replace(Replace(objRecip.Name, ".", " "), "_", " ") atPos = InStr(RecipName, "@") - 1 If atPos > -1 Then .FullName = Left(RecipName, atPos) Else .FullName = RecipName End If .Email1Address = objRecip.Address .Save End With End If End If Set objContact = Nothing Next Set objNS = Nothing Set objContact = Nothing Set colContacts = Nothing End Sub ' helper function - put in any module Function AddQuote(MyText) As String AddQuote = Chr(34) & MyText & Chr(34) End Function