'---------------------------------------------------------------------------------------
' Procedure : Outlook_ExtractContacts
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Extract contact information from Outlook
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Usage:
' ~~~~~~
' Call Outlook_ExtractContacts
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2019-07-15              Initial Release - Forum Help
'---------------------------------------------------------------------------------------
Sub Outlook_ExtractContacts()
    Dim oOutlook              As Object    'Outlook.Application
    Dim oNameSpace            As Object    'Outlook.Namespace
    Dim oFolder               As Object    'Outlook.folder
    Dim oItem                 As Object
    Dim oPrp                  As Object
    Const olFolderContacts = 10
    Const olContact = 40
 
    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")        'Bind to existing instance of Outlook
    If Err.Number <> 0 Then        'Could not get instance, so create a new one
        Err.Clear
        Set oOutlook = CreateObject("Outlook.Application")
    End If
    On Error GoTo Error_Handler
 
    Set oNameSpace = oOutlook.GetNamespace("MAPI")
    Set oFolder = oNameSpace.GetDefaultFolder(olFolderContacts)
 
    On Error Resume Next
    For Each oItem In oFolder.Items
        With oItem
            If .Class = olContact Then
                Debug.Print .EntryId, .FullName, .FirstName, .LastName, .CompanyName
                For Each oPrp In .ItemProperties
                    Debug.Print , oPrp.Name, oPrp.Value
                Next oPrp
            End If
        End With
    Next oItem
 
Error_Handler_Exit:
    On Error Resume Next
    If Not oPrp Is Nothing Then Set oPrp = Nothing
    If Not oItem Is Nothing Then Set oItem = Nothing
    If Not oFolder Is Nothing Then Set oFolder = Nothing
    If Not oNameSpace Is Nothing Then Set oNameSpace = Nothing
    If Not oOutlook Is Nothing Then Set oOutlook = Nothing
    Exit Sub
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Outlook_ExtractContacts" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub

Debug. Печать .EntryId, .FullName, .FirstName, .LastName, .CompanyName