Question Link Microsoft Outlook Contacts to Microsoft Access

[Mohsin Malik]

Hello,

I want to programatically link to Microsoft Outlook Contacts in Microsoft Access? How can I do this with VBA?

Basically I want the first option is to allow the user to select Outlook Account >> Contacts folder (Please note that there are several Outlook folders exist). Once the User select Outlook 'Contacts', Access will create a link table to Outlook folder selected. Any Idea/directions?

Thanks
Mohsin

 

[arnelgp]

make sure you reference Microsoft Outlook Object in VBA.
copy the code below in a new module.
to use it, passed the name of your table.
your table must have corresponding field names, otherwise comment out unneeded code.

to call the sub:

PutOutlookContactsToTable "yourTableName"

Public Sub PutOutlookContactsToTable(strTable As String)
    Dim ol As Object
    Dim olns As Object
    Dim objFolder As Object
    Dim objAllContacts As Object
    Dim Contact As Object
    
    Dim db As DAO.Database
    Dim rs As DAO.recordSet
    
    Set db = CurrentDb
    Set rs = db.OpenRecordset(strTable, dbOpenDynaset)
    
    ' Set the application object
    Set ol = New Outlook.Application
    
    ' Set the namespace object
    Set olns = ol.GetNamespace("MAPI")
    
    ' Set the default Contacts folder
    Set objFolder = olns.GetDefaultFolder(olFolderContacts)
    
    ' Set objAllContacts = the collection of all contacts
    On Error GoTo exit_sub
    
    Set objAllContacts = objFolder.Items
    
    ' Loop through each contact
    For Each Contact In objAllContacts
        rs.AddNew
        rs!FullName = Contact.FullName
        rs!FirstName = Contact.FirstName
        rs!LastName = Contact.LastName
        rs!JobTitle = Contact.JobTitle
        rs!Company = Contact.CompanyName
        rs!BusinessAddress = Contact.BusinessAddressStreet
        rs!BusinessAddressCity = Contact.BusinessAddressCity
        rs!BusinessAddressState = Contact.BusinessAddressState
        rs!BusinessAddressCountry = Contact.BusinessAddressCountry
        rs!BusinessAddressPostalCode = Contact.BusinessAddressPostalCode
        rs!BusinessTelephoneNumber = Contact.BusinessTelephoneNumber
        rs!BusinessFaxNumber = Contact.BusinessFaxNumber
        rs!Email1Address = Contact.Email1Address
        rs!MobileTelephoneNumber = Contact.MobileTelephoneNumber
        rs.Update
    Next
    rs.Close
exit_sub:
    Set rs = Nothing
    Set db = Nothing
    Set ol = Nothing
    Set olns = Nothing
    Set objFolder = Nothing
    Set objAllContacts = Nothing
    Set Contact = Nothing
End Sub

 

[Mohsin Malik]

Hi Arnelgp,

Thanks for your help, what I would further do is bulk editing in Microsoft Outlook linked contacts. Instead of importing contacts in Access, Is there a way if we programatically create/refresh a link table in Access?

Dim strOutlookPath As String
strOutlookPath= "Outlook 9.0;MAPILEVEL=myemail123@gmail.com|;PROFILE=Outlook;TABLETYPE=0;TABLENAME=Contacts;COLSETVERSION=12.0;Database=C:\Users\Vaio\AppData\Local\Temp\"

DoCmd.TransferDatabase acLink, "ODBC Database", strOutlook, acTable, strOutlook, "Contacts"

Thanks
Mohsin

make sure you reference Microsoft Outlook Object in VBA.
copy the code below in a new module.
to use it, passed the name of your table.
your table must have corresponding field names, otherwise comment out unneeded code.

to call the sub:

PutOutlookContactsToTable "yourTableName"

Public Sub PutOutlookContactsToTable(strTable As String)
    Dim ol As Object
    Dim olns As Object
    Dim objFolder As Object
    Dim objAllContacts As Object
    Dim Contact As Object
    
    Dim db As DAO.Database
    Dim rs As DAO.recordSet
    
    Set db = CurrentDb
    Set rs = db.OpenRecordset(strTable, dbOpenDynaset)
    
    ' Set the application object
    Set ol = New Outlook.Application
    
    ' Set the namespace object
    Set olns = ol.GetNamespace("MAPI")
    
    ' Set the default Contacts folder
    Set objFolder = olns.GetDefaultFolder(olFolderContacts)
    
    ' Set objAllContacts = the collection of all contacts
    On Error GoTo exit_sub
    
    Set objAllContacts = objFolder.Items
    
    ' Loop through each contact
    For Each Contact In objAllContacts
        rs.AddNew
        rs!FullName = Contact.FullName
        rs!FirstName = Contact.FirstName
        rs!LastName = Contact.LastName
        rs!JobTitle = Contact.JobTitle
        rs!Company = Contact.CompanyName
        rs!BusinessAddress = Contact.BusinessAddressStreet
        rs!BusinessAddressCity = Contact.BusinessAddressCity
        rs!BusinessAddressState = Contact.BusinessAddressState
        rs!BusinessAddressCountry = Contact.BusinessAddressCountry
        rs!BusinessAddressPostalCode = Contact.BusinessAddressPostalCode
        rs!BusinessTelephoneNumber = Contact.BusinessTelephoneNumber
        rs!BusinessFaxNumber = Contact.BusinessFaxNumber
        rs!Email1Address = Contact.Email1Address
        rs!MobileTelephoneNumber = Contact.MobileTelephoneNumber
        rs.Update
    Next
    rs.Close
exit_sub:
    Set rs = Nothing
    Set db = Nothing
    Set ol = Nothing
    Set olns = Nothing
    Set objFolder = Nothing
    Set objAllContacts = Nothing
    Set Contact = Nothing
End Sub

 

[arnelgp]

check this link http://stackoverflow.com/questions/...access-with-outlook-contacts-programmatically