Update to Chandoo's GetTinyURL code - help with authentication please!

[Jaspos]

Hi all

For several years I have used Chandoo's GetTinyURL code to get shortened URLs via VBA. This now requires authentication, and whilst I know how to GET the required API key, I don't know how to USE it!

FYI this is a summary of the old code:

Set xml = CreateObject("MSXML2.XMLHTTP.6.0")
xml.Open "POST", "https://tinyurl.com/api-create.php?url=" & LongURL, False
xml.Send
GetTinyUrl = xml.ResponseText

But now we need to add an authentication token somehow. I have found one question on Stack Overflow on this - but it has no answers!

Can anyone here help, the original code came from Chandoo so hoping here is the right place!

 

[Jaspos]

OK, so figured this out myself, if anyone else needs this, here's the code (2 x functions) that I got to work:

--------------------------------------------------------------------------------------------
Function GetTinyUrl(LongURL As String) As String

Dim http As Object
Dim postData As String
Dim response As String

Const apiToken = "Your API token"

On Error GoTo ErrorHandler

GetTinyUrl = LongURL
postData = "{""url"":""" & LongURL & """, ""domain"":""tinyurl.com""}"

Set http = CreateObject("MSXML2.XMLHTTP.6.0")
http.Open "POST", "https://api.tinyurl.com/create", False
http.setRequestHeader "Authorization", "Bearer " & apiToken
http.setRequestHeader "Content-Type", "application/json"
http.Send postData

response = http.ResponseText

GetTinyUrl = GetTinyURL_FromReponse(response)

CleanExit:
Set http = Nothing
On Error GoTo 0
Exit Function

ErrorHandler:
Resume CleanExit

End Function

--------------------------------------------------------------------------------------------
Private Function GetTinyURL_FromReponse(ResponseText As String)

Dim arr, arr1, arr2
Dim urlA As String, urlB As String, url As String

arr = Split(ResponseText, ":")

arr1 = arr(2)
arr2 = arr(3)

arr1 = Split(arr1, ",")
arr2 = Split(arr2, ",")

urlA = arr1(0)
urlB = arr2(0)

url = urlA & "/" & urlB

GetTinyURL_FromReponse = Replace(url, """", vbNullString)

End Function