导出Outlook里的全球通讯录到Excel

最近整理硬盘文件，发现一个Outlook里的全球通讯录到Excel的代码，但不知道这个文件是什么时候下的了，谨向原作者致敬。

注意：
1、这个代码是写在Excel的模块里的。
2、通讯录中联系人个数多的话，可能时间有点长

Const CdoAddressListGAL = 0
Const CdoUser = 0
Const CdoRemoteUser = 6
#Const EarlyBind = True

Sub Approach()
'Requires Excel 2000 as it uses Array

'A reference must be set to the CDO 1.21 Library for Early Binding
'The file is cdo.dll

    Dim X As Variant, CDOList As Variant, TitleList As Variant, CDOitem As Variant
    Dim NumX As Long, ArrayDump As Long, i As Long, v As Long, u As Long

    Range("a1:R1").Value2 = Array("Global Name", "Given Name", "Surname", "Email address", "Logon", "Title Field", "Telephone", "Mobile", "Fax", "CSG/Group", "Department", "Site", "Address", "Location", "State ", "Country Field", "Assistant Name", "Assistant Phone")

    #If EarlyBind Then
        Dim objSession As MAPI.Session, oFolder As MAPI.AddressList, oMessage As MAPI.AddressEntry
        Set objSession = New MAPI.Session
        CDOList = Array(CdoPR_DISPLAY_NAME, CdoPR_GIVEN_NAME, CdoPR_SURNAME, 972947486, CdoPR_ACCOUNT, _
                        CdoPR_TITLE, CdoPR_OFFICE_TELEPHONE_NUMBER, CdoPR_MOBILE_TELEPHONE_NUMBER, CdoPR_PRIMARY_FAX_NUMBER, _
                        CdoPR_COMPANY_NAME, CdoPR_DEPARTMENT_NAME, 974716958, CdoPR_STREET_ADDRESS, _
                        CdoPR_LOCALITY, CdoPR_STATE_OR_PROVINCE, CdoPR_COUNTRY, _
                        CdoPR_ASSISTANT, CdoPR_ASSISTANT_TELEPHONE_NUMBER)
    #Else
        Dim objSession As Object, oFolder As Object, oMessage As Object
        Set objSession = CreateObject("MAPI.Session")
        CDOList = Array(805371934, 973471774, 974192670, 972947486, 973078558, 974585886, _
                        973602846, 974913566, 975372318, 974520350, 974651422, 974716958, 975765534, _
                        975634462, 975699998, 975568926, 976224286, 976093214)
    #End If

    With objSession
        .Logon , , False, False
        Set oFolder = .GetAddressList(CdoAddressListGAL)
    End With

    TitleList = Array("GAL Name", "Given Name", "Surname", "Email address", "Logon", "Title Field", _
                      "Telephone", "Mobile", "Fax", "CSG/Group", "Department", "Site", "Address", "Location", "State ", _
                      "Country Field", "Assistant Name", "Assistant Phone")

    'Grab 10 records in one hit before writing to sheet
    '2000 would be better but Excel skips records

    ArrayDump = 10
    Cells.Clear

    'Add Titles
    With Range("A1").Resize(1, UBound(TitleList) + 1)
        .Formula = TitleList
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 35
        .Font.Bold = True
        .Font.Size = 12
    End With

    UserForm1.Show vbModeless

    ReDim X(1 To ArrayDump, 1 To UBound(CDOList) + 1)

    On Error Resume Next
    'Some fields may not exist
    Application.ScreenUpdating = False
    For Each oMessage In oFolder.AddressEntries

        Select Case oMessage.DisplayType
        Case CdoUser, CdoRemoteUser
            i = i + 1
            'Reset variant array every after each group of records
            If i Mod (ArrayDump + 1) = 0 Then
                If NumX * ArrayDump + i > 65535 Then
                    MsgBox "GAL exceeds 65535 entries - extraction stopped ", vbCritical + vbOKOnly
                    GoTo FastExit
                End If
                NumX = NumX + 1
                Range("A2").Offset((NumX - 1) * ArrayDump, 0).Resize(ArrayDump, UBound(CDOList) + 1) = X
                ReDim X(1 To ArrayDump, 1 To UBound(CDOList) + 1)
                i = 1
            End If
            'Display status to user
            If i Mod ArrayDump = 0 Then
                UserForm1.LabelProgress.Width = (i + u + NumX * ArrayDump) / oFolder.AddressEntries.Count * UserForm1.FrameProgress.Width
                UserForm1.LabelSheetNum = Format((i + u + NumX * ArrayDump) / oFolder.AddressEntries.Count, "percent")
                DoEvents
            End If

            v = 0
            ' Add detail to each address
            For Each CDOitem In CDOList
                v = v + 1
                X(i, v) = oMessage.Fields(CDOitem)
            Next
        Case Else
            u = u + 1
        End Select
    Next

    'dump remaining entries
    Range("A2").Offset(NumX * ArrayDump, 0).Resize(ArrayDump, UBound(CDOList) + 1) = X

    'cleanup
FastExit:
    Unload UserForm1
    ActiveSheet.UsedRange.EntireRow.WrapText = False
    ActiveSheet.UsedRange.AutoFilter
    Columns("A:R").AutoFit

    Application.ScreenUpdating = True

    Set oFolder = Nothing
    Set objSession = Nothing

End Sub