Replaces all hyperlinks in a Word doc with shortened Bitly links

ShortenAllMSWordURLs.bas

'Replaces all Hyperlinks in a Word doc with bitly links from your registered account

'Simply add in your Bitly Access Code
'or modify for whatever URL Shortner service you use
'and stir

Public BitlyAccessCode As String
Public BitlyURL As String
Public Salt As String

Sub shortenURLs()

    BitlyAccessCode = "" 'generic access token
    BitlyURL = "https://api-ssl.bitly.com/v3/shorten"
    Salt = ""
    
    'change this if you're pointing to a different doc
    Set myDoc = ActiveDocument
        
    For i = 1 To myDoc.Hyperlinks.Count
        'personally I only edit urls that don't have the link as the text
        If (myDoc.Hyperlinks(i).Address Like "http*") Then 'And Not (myDoc.Hyperlinks(i).TextToDisplay Like "http*") Then
            'Bitly only lets you create one bitly-link per one long url (so use #blarg)
            newLink = ShortenSingleURL(myDoc.Hyperlinks(i).Address & "#" & Salt)
            If (newLink = "INVALID_ARG_ACCESS_TOKEN") Then
                MsgBox ("Error: invalid access token. Make sure it's the generic access token not API/OAuth key")
                End
            End If
            If Not (newLink = "ALREADY_A_BITLY_LINK") Then
                myDoc.Hyperlinks(i).ScreenTip = myDoc.Hyperlinks(i).Address
                myDoc.Hyperlinks(i).Address = newLink
            End If
        End If
    Next
    MsgBox ("finished")
End Sub

Function ShortenSingleURL(url As String)
    Set reader = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    URLEncodePart = EncodeUriComponent(url)
    
    Dim myurl As String
    myurl = BitlyURL & "?access_token=" & BitlyAccessCode & "&longUrl=" & URLEncodePart & "&format=txt"
    
    reader.Open "GET", myurl, False
    reader.setRequestHeader "Accept", "application/json"
    reader.Send
    ShortenSingleURL = reader.responseText
End Function

'yuck VBA doesn't have a URLEncoder out-of-the-box
Function EncodeUriComponent(strText)
    Static objHtmlfile As Object
    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("htmlfile")
        objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
    End If
    EncodeUriComponent = objHtmlfile.parentWindow.encode(strText)
End Function