Script to add e-mail recipients to your Outlook address book

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 = _

    ' 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] = " & _
            Set objContact = colContacts.Find(strFind)
            If Not objContact Is Nothing Then
                Exit For
            End If

        ' if not, add it
        If objContact Is Nothing Then
            Set objContact = _
            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)
                    .FullName = RecipName
                End If
                .Email1Address = objRecip.Address
            End With
        End If
        End If
        Set objContact = Nothing

    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

Schreibe einen Kommentar

Deine E-Mail-Adresse wird nicht veröffentlicht. Erforderliche Felder sind mit * markiert

Diese Website verwendet Akismet, um Spam zu reduzieren. Erfahre mehr darüber, wie deine Kommentardaten verarbeitet werden.