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