Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Sub GALExport()
- Dim appOL As Object
- Dim oGAL As Object
- Dim oContact As Object
- Dim oUser As Object
- Dim arrUsers(1 To 65000, 1 To 5) As String
- Dim UserIndex As Long
- Dim i As Long
- Set appOL = CreateObject("Outlook.Application")
- Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries
- For i = 1 To oGAL.Count
- Set oContact = oGAL.Item(i)
- If oContact.AddressEntryUserType = 0 Then
- Set oUser = oContact.GetExchangeUser
- If Len(oUser.lastname) > 0 Then
- UserIndex = UserIndex + 1
- arrUsers(UserIndex, 1) = oUser.Name
- arrUsers(UserIndex, 2) = oUser.PrimarySMTPAddress
- arrUsers(UserIndex, 3) = oUser.Alias
- arrUsers(UserIndex, 4) = oUser.JobTitle
- arrUsers(UserIndex, 5) = oUser.Department
- End If
- End If
- Next i
- appOL.Quit
- Range("A1").Value = "Name"
- Range("B1").Value = "Email Address"
- Range("C1").Value = "Network Alias"
- Range("D1").Value = "Job Title"
- Range("E1").Value = "Department"
- If UserIndex > 0 Then
- Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
- End If
- Set appOL = Nothing
- Set oGAL = Nothing
- Set oContact = Nothing
- Set oUser = Nothing
- Erase arrUsers
- End Sub
Add Comment
Please, Sign In to add comment