Need VBA code to bypass certain logic and use hard-coded information under specific circumstances

kevinbradley57 · #1 06-08-2025, 03:36 PM

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

macropod · #2 06-08-2025, 11:49 PM

I don't propose to work through & debug 300+ lines of code.

What you could do is something like:

Code:

For Each para In myRange.Paragraphs
    If para.Style = "Distribution List Name" Then
        'Remove paragraph break & clean up name by deleting anything after a comma,
        'which indicates a managing committee member or a job title.
        strDistName = Trim(Split(Split(para.Range.Text, vbCr)(0), ",")(0))
        If strDistName <> "" Then
            intNameCount = intNameCount + 1
            Call UpdateProgress(intNameCount)
            Select Case strDistName
                Case "Federal Reserve Board", "Office of the Comptroller of the Currency", "Ernst & Young LLP", "Central Bank of Ireland"
                Case "Narayan Subramaniam" 'resolves to NarayanSubramaniamDirects@usbank.com
                    strTransmittalList = strTransmittalList & vbCr & "NarayanSubramaniamDirects@usbank.com" & ";"
                Case "Mazars" 'resolves to Mazarsdata@usbank.onmicrosoft.com
                    strTransmittalList = strTransmittalList & vbCr & "Mazarsdata@usbank.onmicrosoft.com" & ";"
                Case "David Wright"
                    strTransmittalList = strTransmittalList & vbCr & "hard-coded email address" & ";" 'Insert hard-coded email address here
                Case "Peter Gaertner"
                    strTransmittalList = strTransmittalList & vbCr & "hard-coded email address" & ";" 'Insert hard-coded email address here
                Case Else
                    'Attempt to resolve
                   ......
            End Select

and/or:

Code:

For Each k In Dict_People.Keys
    If Dict_People(k) > 0 Then
        strPerson = k
        Select Case strPerson
        Case "David Wright", "Peter Gaertner"
        Case Else: strExceptions = strExceptions & strPerson & vbCr
        End Select
    Else
        'Ok
    End If
Next k

kevinbradley57 · #3 Yesterday, 01:07 PM

Thank you.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Bypass VBA macro password in Excel	daniel.smith.10	Excel Programming	2	07-11-2017 01:58 AM
how to enter information to outline code column	ketanco	Project	3	02-04-2015 03:07 PM
Merge not Displaying as Coded	Dmo	Mail Merge	5	07-24-2014 03:24 PM
writing task logic and task information box	ketanco	Project	1	06-15-2014 09:02 AM
Retrieving Microsoft Outlook 2007 information after formatted hard disk (C drive)	SWEngineer	Outlook	0	09-23-2012 01:47 AM