Option Compare Database
Option Explicit
Private Sub AddFromOutlook_Click()
Dim olApp As Outlook.Application
Dim olns As Outlook.NameSpace
Dim olDialog As SelectNamesDialog
Dim olAddressList As Outlook.AddressList
Dim olRecipient As Outlook.Recipient
Dim olContactsFolder As Outlook.Folder
Dim itm As Object
Dim itms As Outlook.Items
Dim blnContactsFolder As Boolean
Set olApp = CreateObject("Outlook.Application")
Set olns = olApp.GetNamespace("MAPI")
'Pick the Outlook Contacts Folder of your choice
Set olContactsFolder = olns.PickFolder
' Return the Focus to Access
AppActivate "Microsoft Access"
' Make sure a Contacts Folder has been chosen
If olContactsFolder Is Nothing Then
MsgBox "Please select a Contacts Folder.", vbExclamation
blnContactsFolder = False
Else
'Test whether folder is a Contacts folder
If olContactsFolder.DefaultItemType <> 2 Then ' olContactItem = 2
MsgBox "Please select a Contacts folder."
blnContactsFolder = False
Else
blnContactsFolder = True
End If
End If
If blnContactsFolder = True Then
Set olDialog = olApp.Session.GetSelectNamesDialog
'Loop through the AddressLists until we get the Default Outlook Contacts Folder
For Each olAddressList In olApp.Session.AddressLists
If olAddressList.GetContactsFolder = olContactsFolder Then
Exit For
End If
Next
With olDialog
'Set the Dialog to use the Default Outlook Contacts Folder
.InitialAddressList = olAddressList
.ShowOnlyInitialAddressList = True
'Select the Names using the Dialog
If .Display Then
'Loop through selections and check for match
For Each olRecipient In olDialog.Recipients
'Loop through each Contact item in the Folder to check for a match
For Each itm In olContactsFolder.Items
'Verify the Item is a Contact Item by Class
If itm.Class = 40 Then '40 = olContact
'Match on finding itm.EntryID within olRecipient.EntryID
If InStr(1, olRecipient.EntryID, itm.EntryID) > 0 Then
'Replace this code with code to insert or update records in Access table
'Either use an action query or a recordset
Debug.Print "olRecipient.Name: " & olRecipient.Name
Debug.Print "itm.FileAs: " & itm.FileAs
Debug.Print "itm.FirstName: " & itm.FirstName
Debug.Print "itm.LastName: " & itm.LastName
Debug.Print "itm.Email1Address: " & itm.Email1Address
Debug.Print "itm.Email2Address: " & itm.Email2Address
Debug.Print "itm.Email3Address: " & itm.Email3Address
Debug.Print "olRecipient.Address: " & olRecipient.Address
Debug.Print "olRecipient.AddressEntry: " & olRecipient.AddressEntry
Debug.Print "olRecipient.Index: " & olRecipient.Index
Debug.Print "olRecipient.Type: " & olRecipient.Type
Debug.Print "olRecipient.EntryID: " & olRecipient.EntryID
Debug.Print "itm.EntryID: " & itm.EntryID
Debug.Print "---------------------------------------------------"
End If
End If
Next itm
Next olRecipient
End If
End With
End If
Set itm = Nothing
Set itms = Nothing
Set olAddressList = Nothing
Set olContactsFolder = Nothing
Set olDialog = Nothing
Set olns = Nothing
Set olApp = Nothing
End Sub
