Bitly API call using VBA Excel Macro-CodePudding

I have some understanding of VBA and coding in general, but what I want is above my skill level. I'm trying to make an Excel Macro to automatically shorten URLs in an Excel file (Screenshot of Excel file). I found some existing code from someone else, however this applies to an old version of the API: Code for old API version.

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

The Bitly API instructions also contain instructions on how to convert a V3 API call to a V4 API call: Instructions on how to convert V3 to V4 API call. I tried to fix this myself, however without any success. I get the error '{"message":"FORBIDDEN"' as current output in Excel.

This is my code so far:

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

I think this is all information needed, but if anything else is required I'm happy to provide this information. I really hope someone can help me with this problem, it'll probably save me a lot of time in my work.

Thanks a lot in advance!

CodePudding user response：

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