I am running the below code and making a lot of hits on the Microsoft Exchange server.
This often causes this particular code to crash for one reason or another. I get a variety of inconsistent VBA errors at runtime or even a complete crash of outlook as a result. The .GetDirectReports
method seems unstable in my experience when being called frequently.
I am wondering if I can run the following code against the cached/local version of the Outlook Address book. I see "Updating Address book" in Outlook often so I know somewhere there is a saved address book.
Can I interface with this saved address book somehow rather than pinging the Exchange server?
Public Sub printAllReports()
Dim allReports As Collection
Set allReports = New Collection
Dim curLevelReports As Collection
Set curLevelReports = New Collection
Dim nextLevelReports As Collection
Set nextLevelReports = New Collection
Dim myTopLevelReport As ExchangeUser
Set myTopLevelReport = getExchangeUserFromString("name to resolve")
'add to both the next level of reports as well as all reports
allReports.Add myTopLevelReport
curLevelReports.Add myTopLevelReport
Dim tempAddressEntries As AddressEntries
Dim newExUser As ExchangeUser
Dim i, j As Integer
'flag for when another sublevel is found
Dim keepLooping As Boolean
keepLooping = False
'this is where the fun begins
Do
'get current reports for the current level
For i = curLevelReports.Count To 1 Step -1
'get all the reports for this person
Set tempAddressEntries = curLevelReports.Item(i).GetDirectReports
'add all reports (note .Count returns 0 on an empty collection)
For j = 1 To tempAddressEntries.Count
Set newExUser = tempAddressEntries.Item(j).getExchangeUser
'with no email or title they probably aren't real? this function checks that
If (isExchangeUserActualEmployee(newExUser) = True) Then
allReports.Add newExUser
nextLevelReports.Add newExUser
keepLooping = True
End If
Next j
Set tempAddressEntries = Nothing
Next i
'reset for next iteration
Set curLevelReports = nextLevelReports
Set nextLevelReports = New Collection
'no more levels to keep going
If keepLooping = False Then
Exit Do
End If
'reset flag for next iteration
keepLooping = False
Loop
Dim oMail As Outlook.MailItem
Set oMail = Application.CreateItem(olMailItem)
'do stuff with this information (currently just write to new email, could do other cool stuff)
For i = 1 To allReports.Count
oMail.Body = oMail.Body + allReports.Item(i).name + ";" + allReports.Item(i).JobTitle
'Debug.Print getFirstName(allReports.item(i).name) & " " & getLastName(allReports.item(i).name)
'oMail.Body = oMail.Body + allReports.Item(i).FirstName & " " & allReports.Item(i).LastName & ";" & allReports.Item(i).JobTitle & ";" & allReports.Item(i).Alias & vbCrLf
'Debug.Print allReports.Item(i).PrimarySmtpAddress
Next i
oMail.Display
End Sub