Вызов API Adobe Analytics REST с помощью VBA (оригинальный код на 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 digestHeader = "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 StringDim 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 FunctionPublic 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