使用VBA调用Adobe Analytics REST API (PHP原始代码)

我找到了问题所在。我发现的SHA1和Base64编码器不准确。Send变量必须使用正确的有效负载更新，URL变量也需要使用正确的方法更新。

下面是完整版本的工作代码:

Sub CallAPI()
Dim objHTTP As New WinHttp.WinHttpRequest
Dim Send    As String
Dim Username As String
Dim Secret As String
Dim EndPoint As String
Dim Time As String
Dim Nonce As String
Dim Timestamp As String
Dim digest As String
Dim Header As String
Time = DateAdd("h", 7, Now())
'Time = Now()
Username = "USERNAME HERE"
Secret = "SECRETHERE"
Timestamp = generateTimestamp(Time)
Nonce = generateNonce()
digest = generateDigest(Nonce, Timestamp, Secret)
Debug.Print Timestamp
Debug.Print Nonce
Debug.Print digest

Header = "UsernameToken Username=""" & Username & """, PasswordDigest=""" & digest & """, Nonce=""" & Nonce & """, Created=""" & Timestamp & """"
Debug.Print Header
Send = Worksheets("Promo Code Data").Range("A1").Value
URL = "https://api.omniture.com/admin/1.4/rest/?method=Report.Queue"
objHTTP.Open "POST", URL, False
objHTTP.SetRequestHeader "X-WSSE", Header
objHTTP.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
objHTTP.Send (Send)
Debug.Print objHTTP.Status
Debug.Print objHTTP.ResponseText
End Sub
Public Function generateTimestamp(Timestamp As String)
'Debug.Print Application.WorksheetFunction.Text(TimeStamp, "yyyy-MM-ddTHH:mm:ssZ");
generateTimestamp = Application.WorksheetFunction.Text(Timestamp, "yyyy-MM-ddTHH:mm:ssZ")
End Function
Public Function generateNonce()
Dim Nonce As String

Dim alphaNumeric As Variant
alphaNumeric = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
Randomize
For i = 1 To 32
    Nonce = Nonce & alphaNumeric(61 * Rnd)
Next
generateNonce = Nonce
End Function

Public Function generateDigest(Nonce, Timestamp, Secret)
 generateDigest = Base64EncodeString(SHA1HASH(Nonce & Timestamp & Secret))
End Function

' Based on: http://vb.wikia.com/wiki/SHA-1.bas
Option Explicit
Private Type FourBytes
    a As Byte
    b As Byte
    c As Byte
    d As Byte
End Type
Private Type OneLong
    L As Long
End Type
Function HexDefaultSHA1(message() As Byte) As String
 Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long
 DefaultSHA1 message, H1, H2, H3, H4, H5
 HexDefaultSHA1 = DecToHex5(H1, H2, H3, H4, H5)
End Function
Function HexSHA1(message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long) As String
 Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long
 xSHA1 message, Key1, Key2, Key3, Key4, H1, H2, H3, H4, H5
 HexSHA1 = DecToHex5(H1, H2, H3, H4, H5)
End Function
Sub DefaultSHA1(message() As Byte, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long)
 xSHA1 message, &H5A827999, &H6ED9EBA1, &H8F1BBCDC, &HCA62C1D6, H1, H2, H3, H4, H5
End Sub
Sub xSHA1(message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long)
 'CA62C1D68F1BBCDC6ED9EBA15A827999 + "abc" = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D"
 '"abc" = "A9993E36 4706816A BA3E2571 7850C26C 9CD0D89D"
 Dim U As Long, P As Long
 Dim FB As FourBytes, OL As OneLong
 Dim i As Integer
 Dim w(80) As Long
 Dim a As Long, b As Long, c As Long, d As Long, e As Long
 Dim t As Long
 H1 = &H67452301: H2 = &HEFCDAB89: H3 = &H98BADCFE: H4 = &H10325476: H5 = &HC3D2E1F0
 U = UBound(message) + 1: OL.L = U32ShiftLeft3(U): a = U ' &H20000000: LSet FB = OL 'U32ShiftRight29(U)
 ReDim Preserve message(0 To (U + 8 And -64) + 63)
 message(U) = 128
 U = UBound(message)
 message(U - 4) = a
 message(U - 3) = FB.d
 message(U - 2) = FB.c
 message(U - 1) = FB.b
 message(U) = FB.a
 While P < U
     For i = 0 To 15
         FB.d = message(P)
         FB.c = message(P + 1)
         FB.b = message(P + 2)
         FB.a = message(P + 3)
         LSet OL = FB
         w(i) = OL.L
         P = P + 4
     Next i
     For i = 16 To 79
         w(i) = U32RotateLeft1(w(i - 3) Xor w(i - 8) Xor w(i - 14) Xor w(i - 16))
     Next i
     a = H1: b = H2: c = H3: d = H4: e = H5
     For i = 0 To 19
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key1), ((b And c) Or ((Not b) And d)))
         e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i
     For i = 20 To 39
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key2), (b Xor c Xor d))
         e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i
     For i = 40 To 59
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key3), ((b And c) Or (b And d) Or (c And d)))
         e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i
     For i = 60 To 79
         t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key4), (b Xor c Xor d))
         e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
     Next i
     H1 = U32Add(H1, a): H2 = U32Add(H2, b): H3 = U32Add(H3, c): H4 = U32Add(H4, d): H5 = U32Add(H5, e)
 Wend
End Sub
Function U32Add(ByVal a As Long, ByVal b As Long) As Long
 If (a Xor b) < 0 Then
     U32Add = a + b
 Else
     U32Add = (a Xor &H80000000) + b Xor &H80000000
 End If
End Function
Function U32ShiftLeft3(ByVal a As Long) As Long
 U32ShiftLeft3 = (a And &HFFFFFFF) * 8
 If a And &H10000000 Then U32ShiftLeft3 = U32ShiftLeft3 Or &H80000000
End Function
Function U32ShiftRight29(ByVal a As Long) As Long
 U32ShiftRight29 = (a And &HE0000000) ' &H20000000 And 7
End Function
Function U32RotateLeft1(ByVal a As Long) As Long
 U32RotateLeft1 = (a And &H3FFFFFFF) * 2
 If a And &H40000000 Then U32RotateLeft1 = U32RotateLeft1 Or &H80000000
 If a And &H80000000 Then U32RotateLeft1 = U32RotateLeft1 Or 1
End Function
Function U32RotateLeft5(ByVal a As Long) As Long
 U32RotateLeft5 = (a And &H3FFFFFF) * 32 Or (a And &HF8000000) ' &H8000000 And 31
 If a And &H4000000 Then U32RotateLeft5 = U32RotateLeft5 Or &H80000000
End Function
Function U32RotateLeft30(ByVal a As Long) As Long
 U32RotateLeft30 = (a And 1) * &H40000000 Or (a And &HFFFC) ' 4 And &H3FFFFFFF
 If a And 2 Then U32RotateLeft30 = U32RotateLeft30 Or &H80000000
End Function
Function DecToHex5(ByVal H1 As Long, ByVal H2 As Long, ByVal H3 As Long, ByVal H4 As Long, ByVal H5 As Long) As String
 Dim H As String, L As Long
 DecToHex5 = "00000000 00000000 00000000 00000000 00000000"
 H = Hex(H1): L = Len(H): Mid(DecToHex5, 9 - L, L) = H
 H = Hex(H2): L = Len(H): Mid(DecToHex5, 18 - L, L) = H
 H = Hex(H3): L = Len(H): Mid(DecToHex5, 27 - L, L) = H
 H = Hex(H4): L = Len(H): Mid(DecToHex5, 36 - L, L) = H
 H = Hex(H5): L = Len(H): Mid(DecToHex5, 45 - L, L) = H
End Function
' Convert the string into bytes so we can use the above functions
' From Chris Hulbert: http://splinter.com.au/blog
Public Function SHA1HASH(str)
  Dim i As Integer
  Dim arr() As Byte
  ReDim arr(0 To Len(str) - 1) As Byte
  For i = 0 To Len(str) - 1
   arr(i) = asc(Mid(str, i + 1, 1))
  Next i
  SHA1HASH = Replace(LCase(HexDefaultSHA1(arr)), " ", "")
End Function

' A Base64 Encoder/Decoder.
'
' This module is used to encode and decode data in Base64 format as described in RFC 1521.
'
' Home page: www.source-code.biz.
' License: GNU/LGPL (www.gnu.org/licenses/lgpl.html).
' Copyright 2007: Christian d'Heureuse, Inventec Informatik AG, Switzerland.
' This module is provided "as is" without warranty of any kind.
Option Explicit
Private InitDone  As Boolean
Private Map1(0 To 63)  As Byte
Private Map2(0 To 127) As Byte
' Encodes a string into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
'   S         a String to be encoded.
' Returns:    a String with the Base64 encoded data.
Public Function Base64EncodeString(ByVal s As String) As String
   Base64EncodeString = Base64Encode(ConvertStringToBytes(s))
   End Function
' Encodes a byte array into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
'   InData    an array containing the data bytes to be encoded.
' Returns:    a string with the Base64 encoded data.
Public Function Base64Encode(InData() As Byte)
   Base64Encode = Base64Encode2(InData, UBound(InData) - LBound(InData) + 1)
   End Function
' Encodes a byte array into Base64 format.
' No blanks or line breaks are inserted.
' Parameters:
'   InData    an array containing the data bytes to be encoded.
'   InLen     number of bytes to process in InData.
' Returns:    a string with the Base64 encoded data.
Public Function Base64Encode2(InData() As Byte, ByVal InLen As Long) As String
   If Not InitDone Then Init
   If InLen = 0 Then Base64Encode2 = "": Exit Function
   Dim ODataLen As Long: ODataLen = (InLen * 4 + 2) ' 3     ' output length without padding
   Dim OLen As Long: OLen = ((InLen + 2) ' 3) * 4           ' output length including padding
   Dim Out() As Byte
   ReDim Out(0 To OLen - 1) As Byte
   Dim ip0 As Long: ip0 = LBound(InData)
   Dim ip As Long
   Dim op As Long
   Do While ip < InLen
      Dim i0 As Byte: i0 = InData(ip0 + ip): ip = ip + 1
      Dim i1 As Byte: If ip < InLen Then i1 = InData(ip0 + ip): ip = ip + 1 Else i1 = 0
      Dim i2 As Byte: If ip < InLen Then i2 = InData(ip0 + ip): ip = ip + 1 Else i2 = 0
      Dim o0 As Byte: o0 = i0 ' 4
      Dim o1 As Byte: o1 = ((i0 And 3) * &H10) Or (i1 ' &H10)
      Dim o2 As Byte: o2 = ((i1 And &HF) * 4) Or (i2 ' &H40)
      Dim o3 As Byte: o3 = i2 And &H3F
      Out(op) = Map1(o0): op = op + 1
      Out(op) = Map1(o1): op = op + 1
      Out(op) = IIf(op < ODataLen, Map1(o2), asc("=")): op = op + 1
      Out(op) = IIf(op < ODataLen, Map1(o3), asc("=")): op = op + 1
      Loop
   Base64Encode2 = ConvertBytesToString(Out)
   End Function
' Decodes a string from Base64 format.
' Parameters:
'    s        a Base64 String to be decoded.
' Returns     a String containing the decoded data.
Public Function Base64DecodeString(ByVal s As String) As String
   If s = "" Then Base64DecodeString = "": Exit Function
   Base64DecodeString = ConvertBytesToString(Base64Decode(s))
   End Function
' Decodes a byte array from Base64 format.
' Parameters
'   s         a Base64 String to be decoded.
' Returns:    an array containing the decoded data bytes.
Public Function Base64Decode(ByVal s As String) As Byte()
   If Not InitDone Then Init
   Dim IBuf() As Byte: IBuf = ConvertStringToBytes(s)
   Dim ILen As Long: ILen = UBound(IBuf) + 1
   If ILen Mod 4 <> 0 Then Err.Raise vbObjectError, , "Length of Base64 encoded input string is not a multiple of 4."
   Do While ILen > 0
      If IBuf(ILen - 1) <> asc("=") Then Exit Do
      ILen = ILen - 1
      Loop
   Dim OLen As Long: OLen = (ILen * 3) ' 4
   Dim Out() As Byte
   ReDim Out(0 To OLen - 1) As Byte
   Dim ip As Long
   Dim op As Long
   Do While ip < ILen
      Dim i0 As Byte: i0 = IBuf(ip): ip = ip + 1
      Dim i1 As Byte: i1 = IBuf(ip): ip = ip + 1
      Dim i2 As Byte: If ip < ILen Then i2 = IBuf(ip): ip = ip + 1 Else i2 = asc("A")
      Dim i3 As Byte: If ip < ILen Then i3 = IBuf(ip): ip = ip + 1 Else i3 = asc("A")
      If i0 > 127 Or i1 > 127 Or i2 > 127 Or i3 > 127 Then _
         Err.Raise vbObjectError, , "Illegal character in Base64 encoded data."
      Dim b0 As Byte: b0 = Map2(i0)
      Dim b1 As Byte: b1 = Map2(i1)
      Dim b2 As Byte: b2 = Map2(i2)
      Dim b3 As Byte: b3 = Map2(i3)
      If b0 > 63 Or b1 > 63 Or b2 > 63 Or b3 > 63 Then _
         Err.Raise vbObjectError, , "Illegal character in Base64 encoded data."
      Dim o0 As Byte: o0 = (b0 * 4) Or (b1 ' &H10)
      Dim o1 As Byte: o1 = ((b1 And &HF) * &H10) Or (b2 ' 4)
      Dim o2 As Byte: o2 = ((b2 And 3) * &H40) Or b3
      Out(op) = o0: op = op + 1
      If op < OLen Then Out(op) = o1: op = op + 1
      If op < OLen Then Out(op) = o2: op = op + 1
      Loop
   Base64Decode = Out
   End Function
Private Sub Init()
   Dim c As Integer, i As Integer
   ' set Map1
   i = 0
   For c = asc("A") To asc("Z"): Map1(i) = c: i = i + 1: Next
   For c = asc("a") To asc("z"): Map1(i) = c: i = i + 1: Next
   For c = asc("0") To asc("9"): Map1(i) = c: i = i + 1: Next
   Map1(i) = asc("+"): i = i + 1
   Map1(i) = asc("/"): i = i + 1
   ' set Map2
   For i = 0 To 127: Map2(i) = 255: Next
   For i = 0 To 63: Map2(Map1(i)) = i: Next
   InitDone = True
   End Sub
Private Function ConvertStringToBytes(ByVal s As String) As Byte()
   Dim b1() As Byte: b1 = s
   Dim L As Long: L = (UBound(b1) + 1) ' 2
   If L = 0 Then ConvertStringToBytes = b1: Exit Function
   Dim b2() As Byte
   ReDim b2(0 To L - 1) As Byte
   Dim P As Long
   For P = 0 To L - 1
      Dim c As Long: c = b1(2 * P) + 256 * CLng(b1(2 * P + 1))
      If c >= 256 Then c = asc("?")
      b2(P) = c
      Next
   ConvertStringToBytes = b2
   End Function
Private Function ConvertBytesToString(b() As Byte) As String
   Dim L As Long: L = UBound(b) - LBound(b) + 1
   Dim b2() As Byte
   ReDim b2(0 To (2 * L) - 1) As Byte
   Dim p0 As Long: p0 = LBound(b)
   Dim P As Long
   For P = 0 To L - 1: b2(2 * P) = b(p0 + P): Next
   Dim s As String: s = b2
   ConvertBytesToString = s
   End Function