· 6 years ago · Nov 13, 2019, 08:17 PM
1Option Explicit
2
3Private Type FourBytes
4 a As Byte
5 b As Byte
6 c As Byte
7 d As Byte
8End Type
9
10Private Type OneLong
11 L As Long
12End Type
13
14Private InitDone As Boolean
15Private Map1(0 To 63) As Byte
16Private Map2(0 To 127) As Byte
17
18Sub CallAPI()
19 Dim objHTTP As Object
20 Dim Send As String, Username As String, Secret As String, EndPoint As String, URL As String
21 Dim Time As String, Nonce As String, Timestamp As String, digest As String, Header As String
22
23 Time = DateAdd("h", 7, Now())
24
25 Username = "USERNAME HERE"
26 Secret = "SECRETHERE"
27
28 Timestamp = generateTimestamp(Time)
29 Nonce = generateNonce()
30 digest = generateDigest(Nonce, Timestamp, Secret)
31
32 Debug.Print Timestamp
33 Debug.Print Nonce
34 Debug.Print digest
35
36
37 Header = "UsernameToken Username=""" & Username & """, PasswordDigest=""" & digest & """, Nonce=""" & Nonce & """, Created=""" & Timestamp & """"
38
39 Debug.Print Header
40
41 Send = Worksheets("Promo Code Data").Range("A1").Value
42
43 URL = "API URL"
44
45 Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
46 objHTTP.Open "POST", URL, False
47 objHTTP.SetRequestHeader "X-WSSE", Header
48 objHTTP.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
49 objHTTP.Send (Send)
50 Debug.Print objHTTP.Status
51 Debug.Print objHTTP.ResponseText
52
53End Sub
54
55Public Function generateTimestamp(Timestamp As String)
56 generateTimestamp = Application.WorksheetFunction.Text(Timestamp, "yyyy-MM-ddTHH:mm:ssZ")
57End Function
58
59Public Function generateDigest(Nonce, Timestamp, Secret)
60 generateDigest = Base64EncodeString(SHA1HASH(Nonce & Timestamp & Secret))
61End Function
62
63Public Function generateNonce()
64 Dim Nonce As String, alphaNumeric As Variant, i As Long
65 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")
66 Randomize
67 For i = 1 To 32
68 Nonce = Nonce & alphaNumeric(61 * Rnd)
69 Next
70 generateNonce = Nonce
71End Function
72
73Function HexDefaultSHA1(message() As Byte) As String
74 Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long
75 DefaultSHA1 message, H1, H2, H3, H4, H5
76 HexDefaultSHA1 = DecToHex5(H1, H2, H3, H4, H5)
77End Function
78
79Function HexSHA1(message() As Byte, ByVal Key1 As Long, ByVal Key2 As Long, ByVal Key3 As Long, ByVal Key4 As Long) As String
80 Dim H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long
81 xSHA1 message, Key1, Key2, Key3, Key4, H1, H2, H3, H4, H5
82 HexSHA1 = DecToHex5(H1, H2, H3, H4, H5)
83End Function
84
85Sub DefaultSHA1(message() As Byte, H1 As Long, H2 As Long, H3 As Long, H4 As Long, H5 As Long)
86 xSHA1 message, &H5A827999, &H6ED9EBA1, &H8F1BBCDC, &HCA62C1D6, H1, H2, H3, H4, H5
87End Sub
88
89Sub 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)
90 Dim U As Long, P As Long, FB As FourBytes, OL As OneLong, i As Integer
91 Dim w(80) As Long, a As Long, b As Long, c As Long, d As Long, e As Long, t As Long
92 H1 = &H67452301: H2 = &HEFCDAB89: H3 = &H98BADCFE: H4 = &H10325476: H5 = &HC3D2E1F0
93 U = UBound(message) + 1: OL.L = U32ShiftLeft3(U): a = U \ &H20000000: LSet FB = OL 'U32ShiftRight29(U)
94
95 ReDim Preserve message(0 To (U + 8 And -64) + 63)
96 message(U) = 128
97 U = UBound(message)
98 message(U - 4) = a
99 message(U - 3) = FB.d
100 message(U - 2) = FB.c
101 message(U - 1) = FB.b
102 message(U) = FB.a
103 While P < U
104 For i = 0 To 15
105 FB.d = message(P)
106 FB.c = message(P + 1)
107 FB.b = message(P + 2)
108 FB.a = message(P + 3)
109 LSet OL = FB
110 w(i) = OL.L
111 P = P + 4
112 Next i
113
114 For i = 16 To 79
115 w(i) = U32RotateLeft1(w(i - 3) Xor w(i - 8) Xor w(i - 14) Xor w(i - 16))
116 Next i
117
118 a = H1: b = H2: c = H3: d = H4: e = H5
119
120 For i = 0 To 19
121 t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key1), ((b And c) Or ((Not b) And d)))
122 e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
123 Next i
124 For i = 20 To 39
125 t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key2), (b Xor c Xor d))
126 e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
127 Next i
128 For i = 40 To 59
129 t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key3), ((b And c) Or (b And d) Or (c And d)))
130 e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
131 Next i
132 For i = 60 To 79
133 t = U32Add(U32Add(U32Add(U32Add(U32RotateLeft5(a), e), w(i)), Key4), (b Xor c Xor d))
134 e = d: d = c: c = U32RotateLeft30(b): b = a: a = t
135 Next i
136
137 H1 = U32Add(H1, a): H2 = U32Add(H2, b): H3 = U32Add(H3, c): H4 = U32Add(H4, d): H5 = U32Add(H5, e)
138 Wend
139End Sub
140
141Function U32Add(ByVal a As Long, ByVal b As Long) As Long
142 If (a Xor b) < 0 Then
143 U32Add = a + b
144 Else
145 U32Add = (a Xor &H80000000) + b Xor &H80000000
146 End If
147End Function
148
149Function U32ShiftLeft3(ByVal a As Long) As Long
150 U32ShiftLeft3 = (a And &HFFFFFFF) * 8
151 If a And &H10000000 Then U32ShiftLeft3 = U32ShiftLeft3 Or &H80000000
152End Function
153
154Function U32ShiftRight29(ByVal a As Long) As Long
155 U32ShiftRight29 = (a And &HE0000000) \ &H20000000 And 7
156End Function
157
158Function U32RotateLeft1(ByVal a As Long) As Long
159 U32RotateLeft1 = (a And &H3FFFFFFF) * 2
160 If a And &H40000000 Then U32RotateLeft1 = U32RotateLeft1 Or &H80000000
161 If a And &H80000000 Then U32RotateLeft1 = U32RotateLeft1 Or 1
162End Function
163Function U32RotateLeft5(ByVal a As Long) As Long
164 U32RotateLeft5 = (a And &H3FFFFFF) * 32 Or (a And &HF8000000) \ &H8000000 And 31
165 If a And &H4000000 Then U32RotateLeft5 = U32RotateLeft5 Or &H80000000
166End Function
167Function U32RotateLeft30(ByVal a As Long) As Long
168 U32RotateLeft30 = (a And 1) * &H40000000 Or (a And &HFFFC) \ 4 And &H3FFFFFFF
169 If a And 2 Then U32RotateLeft30 = U32RotateLeft30 Or &H80000000
170End Function
171
172Function DecToHex5(ByVal H1 As Long, ByVal H2 As Long, ByVal H3 As Long, ByVal H4 As Long, ByVal H5 As Long) As String
173 Dim H As String, L As Long
174 DecToHex5 = "00000000 00000000 00000000 00000000 00000000"
175 H = Hex(H1): L = Len(H): Mid(DecToHex5, 9 - L, L) = H
176 H = Hex(H2): L = Len(H): Mid(DecToHex5, 18 - L, L) = H
177 H = Hex(H3): L = Len(H): Mid(DecToHex5, 27 - L, L) = H
178 H = Hex(H4): L = Len(H): Mid(DecToHex5, 36 - L, L) = H
179 H = Hex(H5): L = Len(H): Mid(DecToHex5, 45 - L, L) = H
180End Function
181
182
183Public Function SHA1HASH(str)
184 Dim i As Integer, arr() As Byte
185 ReDim arr(0 To Len(str) - 1) As Byte
186 For i = 0 To Len(str) - 1
187 arr(i) = Asc(Mid(str, i + 1, 1))
188 Next i
189 SHA1HASH = Replace(LCase(HexDefaultSHA1(arr)), " ", "")
190End Function
191
192
193Public Function Base64EncodeString(ByVal s As String) As String
194 Base64EncodeString = Base64Encode(ConvertStringToBytes(s))
195End Function
196
197Public Function Base64Encode(InData() As Byte)
198 Base64Encode = Base64Encode2(InData, UBound(InData) - LBound(InData) + 1)
199End Function
200
201
202Public Function Base64Encode2(InData() As Byte, ByVal InLen As Long) As String
203 If Not InitDone Then Init
204 If InLen = 0 Then Base64Encode2 = "": Exit Function
205 Dim ODataLen As Long: ODataLen = (InLen * 4 + 2) \ 3 ' output length without padding
206 Dim OLen As Long: OLen = ((InLen + 2) \ 3) * 4 ' output length including padding
207 Dim Out() As Byte
208 ReDim Out(0 To OLen - 1) As Byte
209 Dim ip0 As Long: ip0 = LBound(InData)
210 Dim ip As Long
211 Dim op As Long
212 Do While ip < InLen
213 Dim i0 As Byte: i0 = InData(ip0 + ip): ip = ip + 1
214 Dim i1 As Byte: If ip < InLen Then i1 = InData(ip0 + ip): ip = ip + 1 Else i1 = 0
215 Dim i2 As Byte: If ip < InLen Then i2 = InData(ip0 + ip): ip = ip + 1 Else i2 = 0
216 Dim o0 As Byte: o0 = i0 \ 4
217 Dim o1 As Byte: o1 = ((i0 And 3) * &H10) Or (i1 \ &H10)
218 Dim o2 As Byte: o2 = ((i1 And &HF) * 4) Or (i2 \ &H40)
219 Dim o3 As Byte: o3 = i2 And &H3F
220 Out(op) = Map1(o0): op = op + 1
221 Out(op) = Map1(o1): op = op + 1
222 Out(op) = IIf(op < ODataLen, Map1(o2), Asc("=")): op = op + 1
223 Out(op) = IIf(op < ODataLen, Map1(o3), Asc("=")): op = op + 1
224 Loop
225 Base64Encode2 = ConvertBytesToString(Out)
226End Function
227
228Public Function Base64DecodeString(ByVal s As String) As String
229 If s = "" Then Base64DecodeString = "": Exit Function
230 Base64DecodeString = ConvertBytesToString(Base64Decode(s))
231End Function
232
233Public Function Base64Decode(ByVal s As String) As Byte()
234 If Not InitDone Then Init
235 Dim IBuf() As Byte: IBuf = ConvertStringToBytes(s)
236 Dim ILen As Long: ILen = UBound(IBuf) + 1
237 If ILen Mod 4 <> 0 Then Err.Raise vbObjectError, , "Length of Base64 encoded input string is not a multiple of 4."
238 Do While ILen > 0
239 If IBuf(ILen - 1) <> Asc("=") Then Exit Do
240 ILen = ILen - 1
241 Loop
242 Dim OLen As Long: OLen = (ILen * 3) \ 4
243 Dim Out() As Byte
244 ReDim Out(0 To OLen - 1) As Byte
245 Dim ip As Long
246 Dim op As Long
247 Do While ip < ILen
248 Dim i0 As Byte: i0 = IBuf(ip): ip = ip + 1
249 Dim i1 As Byte: i1 = IBuf(ip): ip = ip + 1
250 Dim i2 As Byte: If ip < ILen Then i2 = IBuf(ip): ip = ip + 1 Else i2 = Asc("A")
251 Dim i3 As Byte: If ip < ILen Then i3 = IBuf(ip): ip = ip + 1 Else i3 = Asc("A")
252 If i0 > 127 Or i1 > 127 Or i2 > 127 Or i3 > 127 Then _
253 Err.Raise vbObjectError, , "Illegal character in Base64 encoded data."
254 Dim b0 As Byte: b0 = Map2(i0)
255 Dim b1 As Byte: b1 = Map2(i1)
256 Dim b2 As Byte: b2 = Map2(i2)
257 Dim b3 As Byte: b3 = Map2(i3)
258 If b0 > 63 Or b1 > 63 Or b2 > 63 Or b3 > 63 Then _
259 Err.Raise vbObjectError, , "Illegal character in Base64 encoded data."
260 Dim o0 As Byte: o0 = (b0 * 4) Or (b1 \ &H10)
261 Dim o1 As Byte: o1 = ((b1 And &HF) * &H10) Or (b2 \ 4)
262 Dim o2 As Byte: o2 = ((b2 And 3) * &H40) Or b3
263 Out(op) = o0: op = op + 1
264 If op < OLen Then Out(op) = o1: op = op + 1
265 If op < OLen Then Out(op) = o2: op = op + 1
266 Loop
267 Base64Decode = Out
268End Function
269
270Private Sub Init()
271 Dim c As Integer, i As Integer
272 i = 0
273 For c = Asc("A") To Asc("Z"): Map1(i) = c: i = i + 1: Next
274 For c = Asc("a") To Asc("z"): Map1(i) = c: i = i + 1: Next
275 For c = Asc("0") To Asc("9"): Map1(i) = c: i = i + 1: Next
276 Map1(i) = Asc("+"): i = i + 1
277 Map1(i) = Asc("/"): i = i + 1
278 For i = 0 To 127: Map2(i) = 255: Next
279 For i = 0 To 63: Map2(Map1(i)) = i: Next
280 InitDone = True
281End Sub
282
283Private Function ConvertStringToBytes(ByVal s As String) As Byte()
284 Dim b1() As Byte: b1 = s
285 Dim L As Long: L = (UBound(b1) + 1) \ 2
286 If L = 0 Then ConvertStringToBytes = b1: Exit Function
287 Dim b2() As Byte
288 ReDim b2(0 To L - 1) As Byte
289 Dim P As Long
290 For P = 0 To L - 1
291 Dim c As Long: c = b1(2 * P) + 256 * CLng(b1(2 * P + 1))
292 If c >= 256 Then c = Asc("?")
293 b2(P) = c
294 Next
295 ConvertStringToBytes = b2
296End Function
297
298Private Function ConvertBytesToString(b() As Byte) As String
299 Dim L As Long: L = UBound(b) - LBound(b) + 1
300 Dim b2() As Byte
301 ReDim b2(0 To (2 * L) - 1) As Byte
302 Dim p0 As Long: p0 = LBound(b)
303 Dim P As Long
304 For P = 0 To L - 1: b2(2 * P) = b(p0 + P): Next
305 Dim s As String: s = b2
306 ConvertBytesToString = s
307End Function