Outlook VBA routines (part 2), Fully comprehensive method of putting Outlook contacts into a temporary Access table

[Joe Boatman]

This shows how to transfer contact data from Outlook to an Access table. Copy this code into modOutlook.

'27 May 2020
'Fully comprehensive method of putting contacts into a temporary table
'Requires loads of support functions
Function apContactFetchFromOutlook() As Integer
'Import Outlook contacts into tblOutlookContacts, display results in datasheet
'Irritant: Note error when not using reference to Outlook Object Library if CStr() is not used

    Dim sList As String, sTmp As String
    Dim nRetVal As Long
    Dim nFldCount As Integer, i As Integer, n As Integer
    Dim bRetVal As Boolean
    Dim vArrOLfields, vArrMyFields
    Dim olApp As Object ' Outlook.Application    'Needs MS Outlook Object Lib b4 ContactItem properties pop up
    Dim oNameSpace As Object ' Outlook.NameSpace
    Dim oContactFolder As Object ' Outlook.Folder
    Dim oContact As Object 'Outlook.ContactItem
    Dim rst As DAO.Recordset
    Const olFolderContacts As Long = 10
    Const olContact As Long = 40

    'Field mapping: Search for "outlook-fields-and-equivalent-properties"
    'Outlook contact field names must match 'my field names'
    Const conOLFldList As String = "FullName,Email1Address,CompanyName,BusinessTelephoneNumber,MobileTelephoneNumber,LastModificationTime"
    Const conMyFldList As String = "Name,Email,Company,Phone,Mobile,Modified"

    'Create tblImport with My field names
    sList = modFunctions.apTable_CreateWithSQL(gcontblImport, conMyFldList, lLocal, nFldCount)
    bRetVal = modFunctions.apFieldAdd(gcontblImport, "Add", dbBoolean, , "Checkbox to add to Contacts", sDefaultValue:="False", dbLoc:=lLocal)

    Set olApp = apGetOutlook    'Get/switch to Outlook
    If olApp Is Nothing Then GoTo ExitRoutine

    Set oNameSpace = olApp.GetNamespace("MAPI")
    Set oContactFolder = oNameSpace.GetDefaultFolder(olFolderContacts)
    nRetVal = oContactFolder.Items.Count
    If nRetVal = 0 Then GoTo ExitRoutine    'No contacts

    vArrOLfields = VBA.Split(conOLFldList, ",", , vbTextCompare)
    vArrMyFields = VBA.Split(conMyFldList, ",", , vbTextCompare)
    Set rst = CurrentDb.OpenRecordset("SELECT * FROM " & gcontblImport)

    For Each oContact In oContactFolder.Items
        With rst
            .AddNew
                For i = LBound(vArrMyFields) To UBound(vArrMyFields)
                    sTmp = oContact.ItemProperties.Item(VBA.CStr(vArrOLfields(i)))    'Error if no CStr()
                    .Fields(vArrMyFields(i)) = VBA.IIf(sTmp = "", Null, sTmp)
                Next
            .Update
        End With
    Next

    rst.Close
    Set rst = Nothing
    vArrOLfields = Empty
    vArrMyFields = Empty
    DoCmd.OpenTable gcontblImport
    Application.VBE.MainWindow.WindowState = 1

ExitRoutine:
    Set oContact = Nothing
    Set oContactFolder = Nothing
    Set oNameSpace = Nothing
    Set olApp = Nothing
    apContactFetchFromOutlook = nRetVal
End Function

I'll add the support routines into a new thread: Outlook support routines.

 

[theDBguy]

Hi Joe. Your code block looks empty. Maybe something happened when you were posting.

 

[Joe Boatman]

I was trying to find out what prevents posting: it's a hyperlink in the code to a Microsoft site I found useful in the development!

 

[theDBguy]

I was trying to find out what prevents posting: it's a hyperlink in the code to a Microsoft site I found useful in the development!

Ah, makes sense.