Outlook emails vba code

Spring cleaning the desktop, found this old vba code that I must have mashed together sometime back.

Well I tested it today and it works, so posting it here for future use.

What it does, collects every email for the GAL in outlook…

Sub GetAllGALMembers()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olGAL As Outlook.AddressList
Dim olEntry As Outlook.AddressEntries
Dim olMember As Outlook.AddressEntry
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olGAL = olNS.GetGlobalAddressList()

Set olEntry = olGAL.AddressEntries
On Error Resume Next
Open "d:\project\email\emails.csv" For Output As #1
Dim i As Long
For i = 1 To olEntry.Count
Set olMember = olEntry.Item(i)
If olMember.AddressEntryUserType = olExchangeUserAddressEntry Then
strName = olMember.Name
strAlias = olMember.GetExchangeUser.Alias
strAddress = olMember.GetExchangeUser.PrimarySmtpAddress
strPhone = olMember.GetExchangeUser.BusinessTelephoneNumber
strCity = olMember.GetExchangeUser.City
strCom = olMember.GetExchangeUser.CompanyName
strJobT = olMember.GetExchangeUser.JobTitle
strDepar = olMember.GetExchangeUser.Department
strOffLoc = olMember.GetExchangeUser.OfficeLocation
Print #1, strName & vbTab & " (" & strAlias & ") " & vbTab & strAddress & vbTab & strPhone & vbTab & strCity & vbTab & strCom & vbTab & strJobT & vbTab & strDepar & vbTab & strOffLoc
End If
' for testing
' If (i = 200) Then
'  GoTo 10
' End If
Next i

10 msgbox ('Done!!')

End Sub