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

Joe Boatman

New member
Local time
Today, 15:44
May 30, 2020
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
                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)
        End With

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

    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.


I’m here to help
Staff member
Local time
Today, 07:44
Oct 29, 2018
Hi Joe. Your code block looks empty. Maybe something happened when you were posting.

Joe Boatman

New member
Local time
Today, 15:44
May 30, 2020
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!

Users who are viewing this thread

Top Bottom