Whitelist all subdomains VBA macro - vba

Question

I have implemented a macro to append a string before any hyperlinks in an outlook email. however, I put a domain whitelist which is working fine for example if I whitelist https : //google.com then it will whitelist it in addition to https : //google.com/etc.. and anything that follows it.
My problem is if someone wants to visit https://mail.google.com or any other subdomain it will not work and will append it to be APPEND_THIS_https://mail.google.com. How can I allow all subdomains to be in the whitelist?
Dim myStr As String
Dim myURL As String
' Declare whitlist URL variables
'Dim whiteURL01 As String
'Dim whiteURL02 as string
myURL = "APPEND_THIS_"
' Add URLs to whitelist here
whiteURL01 = "https://google.com"
' Store the HTML Bodyin a variable
myStr = Msg.htmlbody
' Update all URLs
myStr = Replace(myStr, "href=""", "a href=" & myURL, , , vbTextCompare)
' Process whitelist
myStr = Replace(myStr, myURL & whiteURL01, whiteURL01, , , vbTextCompare)
' Assign back to HTML Body
Msg.htmlbody = myStr
' Save the mail
Msg.Save

Answer 1

Here is how I would do it. I added an extra loop to look thru the entire message body in case there are several loops.
Dim myStr As String
Dim myURL As String
Dim white_url_found As Boolean
myStr=Msg.HTMLBody
myURL = "APPEND_THIS_"
Dim whiteURL(0 To 2) As String
whiteURL(0) = ".google.com"
whiteURL(1) = ".facebook.com"
whiteURL(2) = "mailto:"
searchstart = InStr(1, myStr, "href=")
While searchstart <> 0
nextstart = InStr(searchstart + 1, myStr, "href=")
white_url_found = False
For i = LBound(whiteURL()) To UBound(whiteURL())
URL_pos = InStr(searchstart, myStr, whiteURL(i))
If URL_pos > 0 And (URL_pos < nextstart Or nextstart = 0) Then
white_url_found = True
Exit For
End If
Next i
If Not white_url_found Then
myStr = Left(myStr, searchstart - 1) & Replace(myStr, "href=" & Chr(34), "href=" & Chr(34) & myURL, searchstart, 1, vbTextCompare)
If nextstart <> 0 Then nextstart = nextstart + Len(myURL)
End If
searchstart = nextstart
Wend
Msg.HTMLBody = myStr
Msg.Save