Hi everyone,
I've been happily using this code to get our GAL into Excel 2003 for a couple of years, but now we're on 2007, it errors on this line:
Dim objSession As MAPI.Session
Would anyone know how to change this so it works with Office 2007 please?
I've no idea how this code works, or what it does, only that it's worked perfectly for years...
Thanks.
I've been happily using this code to get our GAL into Excel 2003 for a couple of years, but now we're on 2007, it errors on this line:
Dim objSession As MAPI.Session
Would anyone know how to change this so it works with Office 2007 please?
Code:
Option Explicit
Const CdoAddressListGAL = 0
Const CdoUser = 0
Const CdoRemoteUser = 6
#Const EarlyBind = True
Sub GetGAL()
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 2000 records in one hit before writing to sheet
ArrayDump = 2000
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 SubI've no idea how this code works, or what it does, only that it's worked perfectly for years...
Thanks.
