Белые списки всех поддоменов VBA macro

Question

Я внедрил макрос, чтобы добавить строку перед любыми гиперссылками в Outlook. однако я помещаю белый список доменов, который работает нормально, например, если я белым списком https: //google.com, то он будет белым списком в дополнение к https: //google.com/etc .. и все, что следует за ним.

Моя проблема: если кто-то хочет посетить https://mail.google.com или любой другой подобласт, он не будет работать и добавит его как APPEND_THIS_https: //mail.google.com. Как я могу разрешить все субдомены в белом списке?

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

Вот как я это сделаю. Я добавил дополнительный цикл для просмотра всего тела сообщения в случае, если есть несколько циклов.

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