Bitly API 调用使用 VBA Excel 宏

Question

我正在尝试创建一个 Excel 宏来自动缩短 Excel 文件中的 URL。

().

我找到了现有代码，但这适用于 API 的旧版本：

Bitly 有关于如何连接到新 API 版本的说明，但是这些没有写在 VBA:

Bitly API 说明还包含有关如何将 V3 API 调用转换为 V4 API 调用的说明：

我试图解决这个问题。在 Excel 我得到错误

'{"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 应该没有括号 { } 如：objHTTP.setRequestHeader "Authorization", "Bearer " & AccToken
你 Dim Json 但你没有为这个变量设置值（它是空的）所以你发送并清空请求 objHTTP.send (Json).
您的 LongURL 不应进入 .Open，而应进入您的 JSON，因此它需要 objHTTP.Open "POST", URL, False 和 Json = "{""long_url"": ""https://dev.bitly.com"", ""domain"": ""bit.ly"", ""group_guid"": ""Ba1bc23dE4F""}"

它应该如下所示：

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

Bitly API 调用使用 VBA Excel 宏

Bitly API call using VBA Excel Macro

json

excel

vba

api

bitly