0

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

enter image description here ().

I found existing code however this applies to an old version of the API: enter image description here

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

The Bitly API instructions also contain instructions on how to convert a V3 API call to a V4 API call:
enter image description here

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
Community
  • 1
  • 1
Jeroen Vest
  • 3
  • 1
  • Try to remove the brackets in your authorization: `objHTTP.setRequestHeader "Authorization", "Bearer " & AccToken` the token should be without `{ }` – Pᴇʜ Jan 11 '22 at 12:17
  • @Pᴇʜ that helped! It solved 1 issue, however I get another error message now:. I suppose my request is incorrect? {"message":"UNPROCESSABLE_ENTITY","resource":"bitlinks","description":"The JSON value provided is invalid." – Jeroen Vest Jan 11 '22 at 13:38
  • Well the issue is you `Dim Json` but you set no value to this variable (it is empty) and so you send and empty request `objHTTP.send (Json)`. • Additionally note that if you declare `Dim Json, URL, result, AccToken, LongURL As String` only `LongURL` will be of type `String` but all others of type `Variant`. In VBA you need to specify a type for **every** variable `Dim Json As String, URL As String, result As String, AccToken As String, LongURL As String` or they are `Variant` by default. – Pᴇʜ Jan 11 '22 at 14:16
  • Also your `objHTTP.Open "POST", URL, LongURL, False` should be `objHTTP.Open "POST", URL, False` and the `LongURL` probably needs to go into the `JSON` somehow, Like send teh parameters in `-d` of your image https://i.stack.imgur.com/HCohj.png as JSON encoded parameters with `objHTTP.send (Json)`. • Since you posted it as an image I cannot copy it to write an answer (see [An image of your code is not helpful](http://idownvotedbecau.se/imageofcode)). – Pᴇʜ Jan 11 '22 at 14:21
  • @Pᴇʜ I'm so sorry: `curl \ -H 'Authorization: Bearer {TOKEN}' \ -H 'Content-Type: application/json' \ -X POST \ -d '{ "long_url": "https://dev.bitly.com", "domain": "bit.ly", "group_guid": "Ba1bc23dE4F" }' \ https://api-ssl.bitly.com/v4/shorten` – Jeroen Vest Jan 11 '22 at 14:32
  • Set your `Json` variable like `Json = "{""long_url"": ""https://dev.bitly.com"", ""domain"": ""bit.ly"", ""group_guid"": ""Ba1bc23dE4F""}"` – Pᴇʜ Jan 11 '22 at 14:47
  • @Pᴇʜ You are the best, it's working. Thanks a lot! How do I mark this as solved? – Jeroen Vest Jan 11 '22 at 14:51

1 Answers1

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
Pᴇʜ
  • 56,719
  • 10
  • 49
  • 73