VBA调用DHL沙箱退货标签API遇401未授权问题求助

我正尝试通过DHL沙箱API创建退货运单标签，该请求在Postman中可正常执行，但用VBA实现HTTP请求时始终返回401未授权状态，推测问题出在凭证传递方式上。以下是沙箱环境的用户数据及VBA代码，寻求解决思路。

沙箱账号信息 #

• 用户名: 2222222222_customer
• 密码: uBQbZ62!ZiBiVVbhc

VBA代码 #

主请求过程 #

Sub restAPICall()
Dim objRequest As MSXML2.ServerXMLHTTP60
Dim id_header_name As String, id_key As String, secret_header_name As String, secret_key As String
Dim strUrl As String
Dim blnAsync As Boolean
Dim strResponse As String
Dim json As Object
Dim authKey As String
Set objRequest = New ServerXMLHTTP60
strUrl = "https://api-sandbox.dhl.com/parcel/de/shipping/returns/v1/orders?labelType=BOTH" 'Endpoint Test
blnAsync = False

id_key = "2222222222_customer"
pass = "uBQbZ62!ZiBiVVbhc"

apiKey = "123456789"

body = "{""receiverId"":""deu"", " _
& " ""customerReference"":""Kundenreferenz"", " _
& " ""shipmentReference"":""Sendungsreferenz"", " _
& " ""shipper"": { " _
    & " ""name1"":""Absender Retoure Zeile 1"", " _
    & " ""name2"":""Absender Retoure Zeile 2"", " _
    & " ""name3"":""Absender Retoure Zeile 3"", " _
    & " ""addressStreet"":""Charles-de-Gaulle Str."", " _
    & " ""addressHouse"":""20"", " _
    & " ""city"":""Bonn"", " _
    & " ""email"":""Max.Mustermann@dhl.local"", " _
    & " ""phone"":""+49 421 987654321"", " _
    & " ""postalCode"":""53113"", " _
    & " ""state"":""NRW"", " _
& " }, " _
& " ""itemWeight"": { " _
    & " ""uom"": ""g"", " _
    & " ""value"":""1000"", " _
& " }, " _
& " ""itemValue"": { " _
    & " ""currency"": ""EUR"", " _
    & " ""value"":""100"", " _
& " }, " _
& "}"

With objRequest
    .Open "POST", strUrl, blnAsync ', gkpuser, gkpass
    .setRequestHeader "Authorization", "Basic " + EncodeBase64(id_key + ":" + pass)
    .setRequestHeader "Content-Type", "application/json"
    .setRequestHeader "Accept", "application/json"
    .setRequestHeader "dhl-api-key", "apiKey"
    .Send body
    
    While objRequest.readyState <> 4
        DoEvents
    Wend
    
    strResponseHeaders = .StatusText
    strResponse = .responseText
    allResponseHeader = .GetAllResponseHeaders
End With

Debug.Print body
Debug.Print allResponseHeader
Debug.Print strResponse

End Sub

Base64编码函数 #

Function EncodeBase64(text$)
    Dim b
    With CreateObject("ADODB.Stream")
        .Open: .Type = 2: .Charset = "utf-8"
        .WriteText text: .Position = 0: .Type = 1: b = .Read
        With CreateObject("Microsoft.XMLDOM").createElement("b64")
            .DataType = "bin.base64": .nodeTypedValue = b
            EncodeBase64 = Replace(Mid(.text, 5), vbLf, "")
        End With
        .Close
    End With
End Function

解决思路 #

• 修正dhl-api-key头传递错误：代码中"dhl-api-key"头的值写死为字符串"apiKey"，实际应该传递变量apiKey的值。修改为：

  .setRequestHeader "dhl-api-key", apiKey
  

• 修复Base64编码函数的截取问题：原函数中Mid(.text, 5)是错误的，Microsoft.XMLDOM生成的base64编码开头没有固定偏移，直接取完整文本并移除换行即可：

  EncodeBase64 = Replace(.text, vbLf, "")
  

• 替换字符串拼接运算符：VBA中+用于字符串拼接可能出现类型错误，改用&更安全。修改Authorization头的拼接：

  .setRequestHeader "Authorization", "Basic " & EncodeBase64(id_key & ":" & pass)
  

• 验证JSON格式正确性：检查body拼接的JSON是否有语法错误，比如原代码中引号与冒号的间距问题，建议用Chr(34)代替双引号转义，提升可读性：

  body = "{" & Chr(34) & "receiverId" & Chr(34) & ":" & Chr(34) & "deu" & Chr(34) & "," & _
         " " & Chr(34) & "customerReference" & Chr(34) & ":" & Chr(34) & "Kundenreferenz" & Chr(34) & "," & _
         ' 其余字段同理
  

内容的提问来源于stack exchange，提问作者Alex