' sample application by Sue Mosher
' send questions/comments to webmaster@outlookcode.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)
    Item.Categories = ""
    If Item.Class = olMail Then
        Call AddRecipToContacts(Item)
    End If
End Sub

' This procedure can go in any module
Sub AddRecipToContacts(objMail As MailItem)
    Dim strFind As String
    Dim strAddress As String
    Dim objSMail As Redemption.SafeMailItem
    Dim objSRecip As Redemption.SafeRecipient
    Dim objNS As NameSpace
    Dim colContacts As Items
    Dim objContact As ContactItem
    Dim i As Integer

    ' process message recipients
    Set objSMail = CreateObject("Redemption.SafeMailItem")
    objMail.Save
    objSMail.Item = objMail
    Set objNS = Application.GetNamespace("MAPI")
    Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items
    For Each objSRecip In objSMail.Recipients
        ' check to see if the recip is already in Contacts
        strAddress = objSRecip.Address
        For i = 1 To 3
            strFind = "[Email" & i & "Address] = " & _
                        AddQuote(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
                .FullName = objSRecip.Name
                .Email1Address = strAddress
                .Save
            End With
        End If
        Set objContact = Nothing
    Next

    Set objSMail = Nothing
    Set objSRecip = Nothing 
    Set objNS = 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