Good morning. I have some code that extracts email addresses from an Outlook Global Address List. The contents of that list are in excess of 100,000 serials but the code only goes up to 65535 before stopping. Where I struggle is an instruction that enables the extract to continue running into the next Sheet 'Sheet2' etc. Any ideas would be gratefully received!
Code:
Option Explicit
Const CdoAddressListGAL = 0
Const CdoUser = 0
Const CdoRemoteUser = 6
#Const EarlyBind = True
Sub GetGAL()
'Requires Excel 2000 as it uses Array
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
'Change the #Const to True to enable Early Binding
#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 65535 records in one hit before writing to sheet
ArrayDump = 65535
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
ReDim X(1 To ArrayDump, 1 To UBound(CDOList) + 1)
On Error Resume Next
'Some fields may not exist
'Turn off screen updating
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
'Check that records do notexceed one sheet
If NumX * ArrayDump + i > 65535 Then
MsgBox "GAL exceeds 65535 entries - extraction stopped ", vbCritical + vbOKOnly
GoTo FastExit
End If
'Dump data
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
Application.StatusBar = "Entry " & i + u + NumX * ArrayDump & " of " & oFolder.AddressEntries.Count
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:
ActiveSheet.UsedRange.EntireRow.WrapText = False
Cells.EntireColumn.AutoFit
Application.StatusBar = ""
Application.ScreenUpdating = True
Set oFolder = Nothing
Set objSession = Nothing
End Sub