Sub ProcessMessages1()
Dim olkMsg As Outlook.MailItem, _
olkRecipient As Outlook.Recipient
For Each olkMsg In Application.ActiveExplorer.Selection
If olkMsg.Class = olMail Then
For Each olkRecipient In olkMsg.Recipients
CreateContact1 olkRecipient.Name, olkRecipient.Address
Next
End If
Next
Set olkMsg = Nothing
End Sub
Sub CreateContact1(strName As String, strAddress As String)
Dim olkFolder As Outlook.MAPIFolder, _
olkContact As Outlook.ContactItem
Set olkFolder = Session.GetDefaultFolder(olFolderContacts)
Set olkContact = olkFolder.Items.Find("[Email1Address] = '" & strAddress & "'")
If IsNothing(olkContact) Then
Set olkContact = Application.CreateItem(olContactItem)
With olkContact
.FullName = strName
.Email1Address = strAddress
.Save
End With
End If
Set olkContact = Nothing
Set olkFolder = Nothing
End Sub
|