Bitly API call using VBA Excel Macro

Question

I'm trying to make an Excel Macro to automatically shorten URLs in an Excel file.

().

I found existing code however this applies to an old version of the API:

Bitly has instructions on how to connect to the new API version, however these are not written in VBA:

The Bitly API instructions also contain instructions on how to convert a V3 API call to a V4 API call:

I tried to fix this. In Excel I get the error

'{"message":"FORBIDDEN"'

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim objHTTP As Object
Dim Json, URL, result, AccToken, LongURL As String
If Not Intersect(Target, Range("B6:B100")) Is Nothing Then
    If Target.Count > 1 Then Exit Sub 'If users selects more than one cell, exit sub to prevent bugs
    If Target.Value = Empty Then Exit Sub
    AccToken = Sheet1.Range("C4").Value
    If AccToken = "" Then
        MsgBox "Please enter your Bitly Access Token to get started" & vbCrLf & "hoi"
        Exit Sub
    End If
    LongURL = Target.Value

    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    URL = "https://api-ssl.bitly.com/v4/shorten"

    objHTTP.Open "POST", URL, LongURL, False

    objHTTP.setRequestHeader "Authorization", "Bearer {" & AccToken & "}"
    'objHTTP.setRequestHeader "Authorization", "Bearer {TOKEN}"
    objHTTP.setRequestHeader "Content-type", "application/json"

    objHTTP.send (Json)
    result = objHTTP.responseText
    Range("C" & Target.Row).Value = Left(result, Len(result) - 1)

    Set objHTTP = Nothing

End If
End Sub

Answer 1

1. AccToken should be without brackets { } like: objHTTP.setRequestHeader "Authorization", "Bearer " & AccToken
2. You Dim Json but you set no value to this variable (it is empty) and so you send and empty request objHTTP.send (Json).
3. Your LongURL shoud not go into tho .Open but into your JSON so it needs to be objHTTP.Open "POST", URL, False and Json = "{""long_url"": ""https://dev.bitly.com"", ""domain"": ""bit.ly"", ""group_guid"": ""Ba1bc23dE4F""}"

It should look something like below:

If Not Intersect(Target, Me.Range("B6:B100")) Is Nothing Then
    If Target.Count > 1 Then Exit Sub 'If users selects more than one cell, exit sub to prevent bugs
    If Target.Value = vbNullString Then Exit Sub
    
    Dim AccToken As String
    AccToken = Sheet1.Range("C4").Value
    If AccToken = vbNullString Then
        MsgBox "Please enter your Bitly Access Token to get started" & vbCrLf & "hoi"
        Exit Sub
    End If
    
    Dim LongURL As String
    LongURL = Target.Value
    
    Dim objHTTP As Object
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    
    Dim URL As String
    URL = "https://api-ssl.bitly.com/v4/shorten"

    objHTTP.Open "POST", URL, False

    objHTTP.setRequestHeader "Authorization", "Bearer " & AccToken
    objHTTP.setRequestHeader "Content-type", "application/json"
    
    Dim Json As String
    Json = "{""long_url"": """ & LongURL & """,   ""domain"": ""bit.ly"",   ""group_guid"": ""Ba1bc23dE4F""}"
    
    objHTTP.send Json
    
    Dim result As String
    result = objHTTP.responseText
    
    Me.Range("C" & Target.Row).Value = Left(result, Len(result) - 1)
    
    Set objHTTP = Nothing
End If