Bitly API call using VBA Excel Macro - json

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

AccToken should be without brackets { } like: objHTTP.setRequestHeader "Authorization", "Bearer " & AccToken
You Dim Json but you set no value to this variable (it is empty) and so you send and empty request objHTTP.send (Json).
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