I have a macro that does the following:
1. Open a form that asks the user to enter a source file and a destination folder.
2. Create two new Word documents named “Email Addresses” and “Exceptions”.
3. Read any paragraph in the source file to which the Distribution List Name style has been applied, which will usually be a name.
4. Populate the Email Addresses document with each name, including the email address if uniquely matched in the Global Address List.
5. For any name that does not have a unique match in the Global Address List, add to the Exceptions document.
The code works fine, but I need to add VB code that will bypass the Outlook lookup function if the names are David Wright or Peter Gaertner and add hard-coded email addresses to the Email Addresses file instead of including them in the Exceptions file.
Code:
'This code is a part of the Create Distribution List Emails D-MMM-YY document
'2025-0404 updated comments throughout
'References Needed (Menu: Tools > References)
'Microsoft Scripting Runtime
'Microsoft Outlook 16.0 Object Library
'Microsoft VBScript Regular Expressions is likely needed. This library is the file, "vbscript.dll".
Option Explicit
'An instance of this type is used to store person data while reading from Microsoft Exchange
Public docEmailList As Document
Public Type typUserManager
strDisplayName As String
strEmail As String
strMgr As String
End Type
Function FindTextGetPageNumber(myActiveDoc As Document, searchText As String, searchStyle As String) As Integer
Dim foundRange As Range
Dim pageNumber As Integer
' Initialize the range to the start of the document
Set foundRange = myActiveDoc.Content
' Find the text
With foundRange.Find
.Text = searchText
.Style = searchStyle
.Forward = True
.Wrap = wdFindStop
.Execute
End With
' Check if the text was found
If foundRange.Find.Found Then
' Get the page number of the found text
pageNumber = foundRange.Information(wdActiveEndPageNumber)
FindTextGetPageNumber = pageNumber
Else
FindTextGetPageNumber = -1
End If
End Function
Sub CreateDistributionEmailList(filePath As String, folderPath As String)
'Requires references set to
'Microsoft Scripting Runtime
'Microsoft Outlook 16.0 Object Library
On Error GoTo ErrorHandler
Dim strFileName As String
Dim MyWordDoc As Document
Dim strDistName As String
Dim strDisplayName As String
Dim strDistEmail As String
Dim strPerson As String
Dim strManager As String
Dim strTransmittalList As String
Dim strUnresolvedNames As String
Dim strExceptions As String
Dim strExternalParties As String
Dim strMsg As String
Dim myString As String
Dim intPos As Integer
Dim intStartPgNum As Integer
Dim intEndPgNum As Integer
Dim Response As Integer
Dim intNameCount As Integer
Dim startTime As Single
Dim elapsedTime As Single
Dim intSeconds As Integer
Dim docEmails As Document
Dim docExceptions As Document
Dim para As Word.Paragraph
Dim k
Dim myPerson As typUserManager
Dim Dict_People As Scripting.Dictionary
Dim Dict_Managers As Scripting.Dictionary
Dim myolApp As Outlook.Application
Dim myNamespace As NameSpace
Dim myAddrList As AddressList
Dim myAddrEntry As AddressEntry
Dim exchUser As Outlook.ExchangeUser
Dim myRecipient As recipient
Dim myRange As Range
' Get the start time
startTime = Timer
' Open the selected document
Set MyWordDoc = Documents.Open(filePath, , True, False, , , False, , , , , False)
strFileName = MyWordDoc.Name
Set Dict_People = New Scripting.Dictionary
Set Dict_Managers = New Scripting.Dictionary
Set myolApp = CreateObject("Outlook.Application")
Set myNamespace = myolApp.GetNamespace("MAPI")
Set myAddrList = myNamespace.AddressLists("Global Address List")
'Limit search to the distribution list section
intStartPgNum = FindTextGetPageNumber(MyWordDoc, "Managing Committee", "Distribution List Heading Box")
intEndPgNum = intStartPgNum + 2
' Use the GoTo method to navigate to the specific page
Set myRange = MyWordDoc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=intStartPgNum)
myRange.End = MyWordDoc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=intEndPgNum).Start
intNameCount = 0
For Each para In myRange.Paragraphs
If Len(para.Range.Text) > 4 Then
If para.Range.FormattedText.Style = "Distribution List Name" Then
strDistName = Trim(para.Range.Text)
'Confirm this string is not null, as InStr will return Null if string1 or string2 is Null
If Not IsNull(strDistName) Then
intNameCount = intNameCount + 1
Call UpdateProgress(intNameCount)
'
'clean up name
'
'is there a comma indicating a managing committee member or a job title? if so, remove title (i.e., after comma)
intPos = 0
intPos = InStr(1, strDistName, ",", vbTextCompare)
If intPos > 0 Then strDistName = Left(strDistName, (intPos - 1))
'is there a carriage return at the end of the line? If so, remove the return (length of vbCR is 1)
intPos = 0
intPos = InStr(1, strDistName, vbCr, vbTextCompare)
If intPos > 0 Then strDistName = Left(strDistName, Len(strDistName) - 1)
strDistName = Trim(strDistName)
'
'avoid these resolving errors
'
'Mazars resolves to Mazarsdata@usbank.onmicrosoft.com
'Narayan Subramaniam resolves to NarayanSubramaniamDirects@usbank.com
'
intPos = 0
'Narayan is no longer here, so if name drops to third party list, then it should spark research
intPos = intPos + InStr(1, strDistName, "Narayan Subramaniam", vbTextCompare)
'Also want to bypass these
intPos = intPos + InStr(1, strDistName, "Mazars", vbTextCompare)
intPos = intPos + InStr(1, strDistName, "Federal Reserve Board", vbTextCompare)
intPos = intPos + InStr(1, strDistName, "Office of the Comptroller of the Currency", vbTextCompare)
intPos = intPos + InStr(1, strDistName, "Ernst & Young LLP", vbTextCompare)
intPos = intPos + InStr(1, strDistName, "Central Bank of Ireland", vbTextCompare)
If intPos = 0 Then
'Attempt to resolve
Set myRecipient = myNamespace.CreateRecipient(strDistName)
myRecipient.Resolve
If myRecipient.Resolved Then
Set exchUser = myRecipient.AddressEntry.GetExchangeUser
If exchUser.AddressEntryUserType = olExchangeUserAddressEntry Then
myPerson.strDisplayName = exchUser.Name
If Not exchUser.GetExchangeUserManager Is Nothing Then
myPerson.strMgr = exchUser.GetExchangeUserManager
Else
myPerson.strMgr = "none listed"
End If
If exchUser.PrimarySmtpAddress <> "" Then
myPerson.strEmail = exchUser.PrimarySmtpAddress
Else
myPerson.strEmail = "none listed"
End If
End If
Else
'Add name for tracking
'Compile for Unresolved
strUnresolvedNames = strUnresolvedNames & vbCr & strDistName
'Do I need to note that the user did not resolve?
myPerson.strDisplayName = "not found"
myPerson.strEmail = "not found"
myPerson.strMgr = "not found"
End If
'Confirm the email is a USBank.com email address
intPos = 0
intPos = InStr(1, myPerson.strEmail, "@usbank.com", vbTextCompare) + InStr(1, myPerson.strEmail, "@elavon.com", vbTextCompare)
'Either way, update Distribution List - docEmails
If intPos > 0 Then
'Add email and name to Distribution List - docEmails
strDistEmail = myPerson.strDisplayName & " <" & myPerson.strEmail & ">;"
strTransmittalList = strTransmittalList & vbCr & strDistEmail
'Add each to a Dictionary and then look up
If Not Dict_People.Exists(myPerson.strDisplayName) Then
Dict_People.Add (myPerson.strDisplayName), 0
Else
Dict_People(myPerson.strDisplayName) = Dict_People(myPerson.strDisplayName) + 1
End If
If Not Dict_Managers.Exists(myPerson.strMgr) Then
Dict_Managers.Add (myPerson.strMgr), 0
Dict_Managers(myPerson.strMgr) = myPerson.strMgr & " for " & myPerson.strDisplayName
Else
Dict_Managers(myPerson.strMgr) = Dict_Managers(myPerson.strMgr) & " and for " & myPerson.strDisplayName
End If
Else
'Add name to Distribution List - docEmails
strTransmittalList = strTransmittalList & vbCr & Trim(strDistName) & ";"
End If
Else
'Third Party or known Issue
strExternalParties = strExternalParties & vbCr & strDistName
myPerson.strDisplayName = "not found"
myPerson.strEmail = "not found"
myPerson.strMgr = "not found"
End If
Else
'DistName was null, go on to next paragraph
End If
Else
'Wrong style, go on to next paragraph
End If
Else
'Nothing here, go on to next paragraph
End If
Next para
' Close the reviewed document without saving changes
MyWordDoc.Close SaveChanges:=wdDoNotSaveChanges
'
'Prep file name attributes
'
Dim strTime As String
Dim strPathFileNameVersion As String
strTime = Format$(Now(), "hh-mm")
strFileName = Trim(progressForm.txtAuditNumber.Value)
'
'Create Email List Doc
'
Set docEmails = Documents.Add
With docEmails.Range
.Font.Name = "Verdana"
.Font.Size = 9
End With
With docEmails.Range.ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
docEmails.Range.InsertAfter (strTransmittalList)
docEmails.Content.InsertBefore Text:="**Email Addresses**" & vbCr
strPathFileNameVersion = folderPath & "\" & strTime & " Email Addresses for " & strFileName
docEmails.SaveAs2 fileName:=strPathFileNameVersion, FileFormat:=wdFormatDocumentDefault
'docEmails.Close wdSaveChanges
Set docEmailList = docEmails
'
'Create Exceptions Doc which includes unresolved names
'
Set docExceptions = Documents.Add
With docExceptions.Range.Font
.Name = "Verdana"
.Size = 9
End With
With docExceptions.Range.ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
For Each k In Dict_People.Keys
If Dict_People(k) > 0 Then
strPerson = k
strExceptions = strExceptions & strPerson & vbCr
Else
'Ok
End If
Next k
If strExceptions = "" Then strExceptions = "None"
strExceptions = vbCr & "**Names Listed More Than Once**" & vbCr & vbCr & strExceptions & vbCr
docExceptions.Range.InsertAfter (strExceptions)
strExceptions = ""
If strUnresolvedNames = "" Then strUnresolvedNames = "None"
strUnresolvedNames = vbCr & vbCr & "**Unresolved Names**" & vbCr & strUnresolvedNames & vbCr
docExceptions.Range.InsertAfter (strUnresolvedNames)
strExceptions = ""
For Each k In Dict_Managers.Keys
strManager = Dict_Managers(k) '(i.e., the key)
If Dict_People.Exists(k) Then
'Great, do nothing
Else
strExceptions = strExceptions & strManager & vbCr
End If
Next k
If strExceptions = "" Then strExceptions = vbCr & "None"
strExceptions = vbCr & vbCr & "**Direct Managers Potentially Omitted From Distribution List**" & vbCr & vbCr & strExceptions & vbCr
docExceptions.Range.InsertAfter (strExceptions)
strExceptions = ""
If strExternalParties = "" Then strExternalParties = vbCr & "None"
strExternalParties = vbCr & "**External Parties**" & vbCr & strExternalParties
docExceptions.Range.InsertAfter (strExternalParties)
' No exceptions here, just extra content
strExceptions = vbCr & vbCr & "**U.S. Bank Europe External Parties**" & vbCr & vbCr
strExceptions = strExceptions & "If any of the following entities are on the report/memo Distribution List for a U.S. Bank Europe engagement, include the respective email addresses in the BCC section."
strExceptions = strExceptions & vbCr & vbCr & "Mazars: " _
& vbCr & "pgorry@mazars.ie" & vbCr
strExceptions = strExceptions & vbCr & "Central Bank of Ireland: " _
& vbCr & "tom.lowth@centralbank.ie;" _
& vbCr & "internationalbanks2@centralbank.ie;" _
& vbCr & "aine.mcpartlan@centralbank.ie; (Depositary Services only)" _
& vbCr & "Colin.ONeill@centralbank.ie; (Depositary Services only)" _
& vbCr & vbCr & "CSSF and GFS: The business line will share reports/memos with CSSF or the CBI if deemed appropriate by the audit team." _
& vbCr & vbCr & "For CSSF, the audit team should follow up with the business line after issuance to confirm distribution." _
& vbCr & vbCr & "For CBI, the audit team should direct the business line to work with Regulatory Services to facilitate submission through the online portal."
docExceptions.Range.InsertAfter (strExceptions)
strPathFileNameVersion = folderPath & "\" & strTime & " Exceptions for " & strFileName
docExceptions.SaveAs2 fileName:=strPathFileNameVersion, FileFormat:=wdFormatDocumentDefault
'docExceptions.Close wdSaveChanges
'
'All done - End Timer
'
elapsedTime = Timer - startTime
intSeconds = Int(elapsedTime)
'Report out
'strMsg = "Process complete." & vbCr & vbCr & intNameCount & " names were researched." & vbCr & vbCr & "Elapsed Time: " & intSeconds & " seconds"
strMsg = "Process complete." & vbCr & vbCr & "Elapsed Time: " & intSeconds & " seconds"
progressForm.lblStatusUpdate.Caption = strMsg
Cleanup:
Set docEmails = Nothing
Set docExceptions = Nothing
Set MyWordDoc = Nothing
Set Dict_People = Nothing
Set Dict_Managers = Nothing
Set myolApp = Nothing
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description, vbCritical
MsgBox "near: " & strDistEmail & " " & strDistName
Resume Cleanup
End Sub