Xero OAuth 1.0 VBA Connector
Let’s program like it’s 1999 … I have the unfortunate memory of actually programming around that time and having a little exposure to Visual Basic 6.0 which is what VBA in Excel is all about. One of my first projects in 1995 at Credit Suisse I was building a COM adapter in C++ to feed an excel spread sheet from a Tibco feed. Way before webservices, JSON etc.got popular. A sense of deja vu.
I did this Oauth implementation with with Excel 2016 (that is what Office 365 says…) on Windows. This will not work on any other platform. I haven’t gotten around to putting a JSON parser in there yet to actually do something useful with the data which comes back.
Note: This code is here for historical interest only. If you are not an iNTERFACEWARE customer please understand that this VBA code is not supported. For your information as this project progressed we found in practice it was much easier to leverage Iguana to extract the information from Xero and map into a set of SQLite tables to mirror the data from Xero.
The reason for this is that some APIs like those that get invoices, only give you the detail information if you loop around and get pages of data. Other things like credit notes have to be retrieved one at time which is really slow. Repeating invoice templates have another pattern to get those. None of these things are that consistent. So the architecture we ended up going for was getting Iguana to do all this back end extraction and then serving the data up via Excel using the Excel adapter.
That has been working really effectively for us in terms of being able to cross reference and correlate data with our CRM system – we tried out salesforce.com for a while and found it cumbersome so we switched to using pipedrive.com together with Harvest and Basecamp to handle the professional services function. It’s been very effective to do things like looking at revenue per territory, make sure data is consistent between the two systems and so on.
We’ve also been able to give feeds of data to our account managers to help give the visibility into accounts receivable, orders etc. within their territories which has had a really positive impact.
Excel is a nice spreadsheet. Shame about the VBA language. I thought this would be a trivial project to knock off but it turned out to a little non trivial due to the impoverished nature of Visual Basic environment.
This script is huge in comparison to the Python and Lua implementations.
The code here has two extra dependencies to worry about:
- It uses the openssl command line tool. This doesn’t seem like a big deal since you need to use that anyway to generate your private and public key pem files to register with Xero.
- Out of the box VBA doesn’t have a dictionary (aka hash table) so I needed to add the “Reference” through Tools->References for C:\Windows\System32\scrrun.dll which is the Microsoft Scripting Runtime. This gave me access to a Dictionary object.
To get this code working and understand it I would recommend reading through the rest of this article. I would suggest starting with my Lua example if you are an Iguana customer, or the python example if you are not. Starting with this example will be hard.
Working with VBA presented a lot of challenges that didn’t exist in Lua and Python.
No easy way to get GMT unix epoch time for the oauth_timestamp.
So I hacked it with this code DateDiff(“s”, #1/1/1970#, Now()) + TIMEZONE_OFFSET * 360. For my timezone in Toronto I picked the value of 5. It will probably break with daylight savings. More work could be done there.
No easy way to invoke a process and fetch its output.
I needed to do this for the openssl signing. Non trivial in VBA. I had to borrow some code I found that invokes the native WIN32 APIs CreateProcess to get that working. It makes for some fairly scary looking code but it works.
Now with more digging one could probably research a native COM object that supports RSA-SHA1 signing and that would enable one to get rid of much of this code.
No easy way to write a straight binary file with newlines being left alone
I finally found this code and used it:
Private Sub StringToFile(FileName As String, Content As String) Const adTypeBinary = 1 Const adSaveCreateOverWrite = 2 Dim Data() As Byte Data = StrConv(Content, vbFromUnicode) Dim BinaryStream Set BinaryStream = CreateObject("ADODB.Stream") BinaryStream.Type = adTypeBinary BinaryStream.Open BinaryStream.Write Data BinaryStream.SaveToFile FileName, adSaveCreateOverWrite End Sub
VBA gives you a lot of grief the way that strings are UTF16 strings instead of going the single byte route with UTF8.
No easy sorting solutions
There isn’t any easy built in sorting functionality in VBA either. So to sort the parameters for OAuth signing I ended up putting the keys into an array and sorting with a bubble sort.
Not super efficient but fine for the purpose.
No built in URI or base64 Encoding
I scrounged some code from the net which did the trick. Sure does add to the volume of code for this thing though.
WinHttp.WinHttpRequest.5.1 for HTTP requests
This was one part of the whole code which was actually a little easier than using command line code. This object made it fairly easy to package up the HTTP request and send it off.
No JSON Parser
I have to go and do a bit more scrounging off the net to find one and try it out. I’ll leave that as an exercise to the reader. Anyway here is the code. If you are not familiar with Oauth 1.0 and Xero I would recommend reading my explanation about the Lua and Python implementation.
' These are constants required for base64 encoding Private Const clOneMask = 16515072 '000000 111111 111111 111111 Private Const clTwoMask = 258048 '111111 000000 111111 111111 Private Const clThreeMask = 4032 '111111 111111 000000 111111 Private Const clFourMask = 63 '111111 111111 111111 000000 Private Const clHighMask = 16711680 '11111111 00000000 00000000 Private Const clMidMask = 65280 '00000000 11111111 00000000 Private Const clLowMask = 255 '00000000 00000000 11111111 Private Const cl2Exp18 = 262144 '2 to the 18th power Private Const cl2Exp12 = 4096 '2 to the 12th Private Const cl2Exp6 = 64 '2 to the 6th Private Const cl2Exp8 = 256 '2 to the 8th Private Const cl2Exp16 = 65536 '2 to the 16th ' This is a load of horrendous code just to be able to have the privillege of invoking a process and getting the standard output out ' I need this to invoke openssl for certificate signing Private Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As Long End Type Private Type PROCESS_INFORMATION hProcess As Long hThread As Long dwProcessId As Long dwThreadId As Long End Type Private Type STARTUPINFO cb As Long lpReserved As Long lpDesktop As Long lpTitle As Long dwX As Long dwY As Long dwXSize As Long dwYSize As Long dwXCountChars As Long dwYCountChars As Long dwFillAttribute As Long dwFlags As Long wShowWindow As Integer cbReserved2 As Integer lpReserved2 As Byte hStdInput As Long hStdOutput As Long hStdError As Long End Type Private Const WAIT_INFINITE As Long = (-1&) Private Const STARTF_USESHOWWINDOW As Long = &H1 Private Const STARTF_USESTDHANDLES As Long = &H100 Private Const SW_HIDE As Long = 0& Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As Long) As Long Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long Private Declare Sub GetStartupInfo Lib "kernel32" Alias "GetStartupInfoA" (lpStartupInfo As STARTUPINFO) Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long Public Function Redirect(szBinaryPath As String, szCommandLn As String) As String Dim tSA_CreatePipe As SECURITY_ATTRIBUTES Dim tSA_CreateProcessPrc As SECURITY_ATTRIBUTES Dim tSA_CreateProcessThrd As SECURITY_ATTRIBUTES Dim tSA_CreateProcessPrcInfo As PROCESS_INFORMATION Dim tStartupInfo As STARTUPINFO Dim hRead As Long Dim hWrite As Long Dim bRead As Long Dim abytBuff() As Byte Dim lngResult As Long Dim szFullCommand As String Dim lngExitCode As Long Dim lngSizeOf As Long tSA_CreatePipe.nLength = Len(tSA_CreatePipe) tSA_CreatePipe.lpSecurityDescriptor = 0& tSA_CreatePipe.bInheritHandle = True tSA_CreateProcessPrc.nLength = Len(tSA_CreateProcessPrc) tSA_CreateProcessThrd.nLength = Len(tSA_CreateProcessThrd) If (CreatePipe(hRead, hWrite, tSA_CreatePipe, 0&) <> 0&) Then tStartupInfo.cb = Len(tStartupInfo) GetStartupInfo tStartupInfo With tStartupInfo .hStdOutput = hWrite .hStdError = hWrite .dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES .wShowWindow = SW_HIDE End With szFullCommand = """" & szBinaryPath & """" & " " & szCommandLn lngResult = CreateProcess(0&, szFullCommand, tSA_CreateProcessPrc, tSA_CreateProcessThrd, True, 0&, 0&, vbNullString, tStartupInfo, tSA_CreateProcessPrcInfo) If (lngResult <> 0&) Then lngResult = WaitForSingleObject(tSA_CreateProcessPrcInfo.hProcess, WAIT_INFINITE) lngSizeOf = GetFileSize(hRead, 0&) If (lngSizeOf > 0) Then ReDim abytBuff(lngSizeOf - 1) If ReadFile(hRead, abytBuff(0), UBound(abytBuff) + 1, bRead, ByVal 0&) Then Redirect = StrConv(abytBuff, vbUnicode) End If End If Call GetExitCodeProcess(tSA_CreateProcessPrcInfo.hProcess, lngExitCode) CloseHandle tSA_CreateProcessPrcInfo.hThread CloseHandle tSA_CreateProcessPrcInfo.hProcess ' Eliot - I commented this out 'If (lngExitCode <> 0&) Then Err.Raise vbObject + 1235&, "GetExitCodeProcess", "Non-zero Application exist code" CloseHandle hWrite CloseHandle hRead Else Err.Raise vbObject + 1236&, "CreateProcess", "CreateProcess Failed, Code: " & Err.LastDllError End If End If End Function ' End of all the stuff needed for the "Redirect" function to invoke a process and get it's output ' Base 64 encoding function. Public Function Encode64(sString As String) As String Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, lOutSize As Long For lTemp = 0 To 63 'Fill the translation table. Select Case lTemp Case 0 To 25 bTrans(lTemp) = 65 + lTemp 'A - Z Case 26 To 51 bTrans(lTemp) = 71 + lTemp 'a - z Case 52 To 61 bTrans(lTemp) = lTemp - 4 '1 - 0 Case 62 bTrans(lTemp) = 43 'Chr(43) = "+" Case 63 bTrans(lTemp) = 47 'Chr(47) = "/" End Select Next lTemp For lTemp = 0 To 255 'Fill the 2^8 and 2^16 lookup tables. lPowers8(lTemp) = lTemp * cl2Exp8 lPowers16(lTemp) = lTemp * cl2Exp16 Next lTemp iPad = Len(sString) Mod 3 'See if the length is divisible by 3 If iPad Then 'If not, figure out the end pad and resize the input. iPad = 3 - iPad sString = sString & String(iPad, Chr(0)) End If bIn = StrConv(sString, vbFromUnicode) 'Load the input string. lLen = ((UBound(bIn) + 1) \ 3) * 4 'Length of resulting string. lTemp = lLen \ 72 'Added space for vbCrLfs. lOutSize = ((lTemp * 2) + lLen) - 1 'Calculate the size of the output buffer. ReDim bOut(lOutSize) 'Make the output buffer. lLen = 0 'Reusing this one, so reset it. For lChar = LBound(bIn) To UBound(bIn) Step 3 lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2) 'Combine the 3 bytes lTemp = lTrip And clOneMask 'Mask for the first 6 bits bOut(lPos) = bTrans(lTemp \ cl2Exp18) 'Shift it down to the low 6 bits and get the value lTemp = lTrip And clTwoMask 'Mask for the second set. bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12) 'Shift it down and translate. lTemp = lTrip And clThreeMask 'Mask for the third set. bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6) 'Shift it down and translate. bOut(lPos + 3) = bTrans(lTrip And clFourMask) 'Mask for the low set. If lLen = 68 Then 'Ready for a newline bOut(lPos + 4) = 13 'Chr(13) = vbCr bOut(lPos + 5) = 10 'Chr(10) = vbLf lLen = 0 'Reset the counter lPos = lPos + 6 Else lLen = lLen + 4 lPos = lPos + 4 End If Next lChar If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf. If iPad = 1 Then 'Add the padding chars if any. bOut(lOutSize) = 61 'Chr(61) = "=" ElseIf iPad = 2 Then bOut(lOutSize) = 61 bOut(lOutSize - 1) = 61 End If Encode64 = StrConv(bOut, vbUnicode) 'Convert back to a string and return it. End Function ' This is used to build an array of keys to sort them along with the BubbleSortArray Private Sub BuildArray(Dict As Dictionary, TempArray) Dim Count, Key Count = 0 ReDim TempArray(Dict.Count - 1) For Each Key In Dict.Keys TempArray(Count) = Key Count = Count + 1 Next End Sub Sub BubbleSortArray(TempArray) Dim i, j, Temp For i = 0 To UBound(TempArray) For j = 0 To i If StrComp(TempArray(j), TempArray(i)) > 0 Then 'Swap the array positions Temp = TempArray(j) TempArray(j) = TempArray(i) TempArray(i) = Temp End If Next Next End Sub ' URLEncoding because VBA ain't got anything built in... Private Function URLEncode(StringVal As String, Optional SpaceAsPlus As Boolean = False) As String Dim StringLen As Long: StringLen = Len(StringVal) If StringLen > 0 Then ReDim Result(StringLen) As String Dim i As Long, CharCode As Integer Dim Char As String, Space As String If SpaceAsPlus Then Space = "+" Else Space = "%20" For i = 1 To StringLen Char = Mid$(StringVal, i, 1) CharCode = Asc(Char) Select Case CharCode Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126 Result(i) = Char Case 32 Result(i) = Space Case 0 To 15 Result(i) = "%0" & Hex(CharCode) Case Else Result(i) = "%" & Hex(CharCode) End Select Next i URLEncode = Join(Result, "") End If End Function Private Function ConcatenateSigParams(AllParams As Dictionary) As String Dim Result As String Result = "" BuildArray AllParams, SortedKeys BubbleSortArray SortedKeys For i = 0 To UBound(SortedKeys) Result = Result & SortedKeys(i) & "=" & URLEncode(AllParams.Item(SortedKeys(i))) & "&" Next ConcatenateSigParams = Left(Result, Len(Result) - 1) End Function Private Sub StringToFile(FileName As String, Content As String) Const adTypeBinary = 1 Const adSaveCreateOverWrite = 2 Dim Data() As Byte Data = StrConv(Content, vbFromUnicode) Dim BinaryStream Set BinaryStream = CreateObject("ADODB.Stream") BinaryStream.Type = adTypeBinary BinaryStream.Open BinaryStream.Write Data BinaryStream.SaveToFile FileName, adSaveCreateOverWrite End Sub Private Function SignText(Text As String, KeyPath As String, TempDir As String) As String Dim SigFile As String Dim Output As String StringToFile TempDir & "request.txt", Text SignText = Redirect("openssl", "dgst -sha1 -sign " & KeyPath & " -binary " & TempDir & "request.txt") SignText = Encode64(SignText) SignText = Replace(SignText, vbCrLf, "") ' get rid of newlines into the base64 output - ugh End Function Private Function AuthInfo(AuthDict As Dictionary) As String AuthInfo = "" For Each It In AuthDict AuthInfo = AuthInfo & " " & It & "=""" + AuthDict.Item(It) & """," Next End Function Private Function MakeHttpRequest(Params As Dictionary, Headers As Dictionary, Url As String) As String Dim Request As Object Set Request = CreateObject("WinHttp.WinHttpRequest.5.1") If (Params.Count > 0) Then Url = Url & "?" For Each It In Params Url = Url & It & "=" & URLEncode(Params.Item(It), True) & "&" Next Url = Left(Url, Len(Url) - 1) End If Request.Open "GET", Url, False For Each It In Headers Request.SetRequestHeader It, Headers.Item(It) Next Request.Send MakeHttpRequest = Request.responseText End Function Private Sub XeroFetch_Click() Dim Params As Scripting.Dictionary Dim Headers As Scripting.Dictionary Dim Auth As Scripting.Dictionary Dim AllParams As Scripting.Dictionary Dim TempDir As String Dim Url As String Dim PrivateKey As String Dim CONSUMER_KEY As String Dim SortedParamAuthString As String Dim SignatureText As String Dim Signature As String Set Params = New Dictionary Set Auth = New Dictionary Set Headers = New Dictionary Set AllParams = New Dictionary ' TODO YOU MUST EDIT THESE PARAMETERS FOR YOUR SETUP CONSUMER_KEY = "C00WGMXDTS5QSXWVN5WDOAJ1JHBRKA" TempDir = "C:\temp\" PrivateKey = "Y:\xero2\privatekey.pem" TIMEZONE_OFFSET = 5 ' It's hard in VB to get the darn time zone offset ' END EDITING OF SITE SPECIFIC PARAMETERS Url = "https://api.xero.com/api.xro/2.0/Contacts" Params.Add "where", "Name == ""Expresso 31""" Headers.Add "Accept", "application/json" ' Horrendous hack to get the unix epoch time and correct it for our time zone Auth.Add "oauth_timestamp", CStr(DateDiff("s", #1/1/1970#, Now()) + TIMEZONE_OFFSET * 3600) Auth.Add "oauth_nonce", CStr(Auth.Item("oauth_timestamp")) & CStr(Round(Rnd() * 100000000)) Auth.Add "oauth_version", "1.0" Auth.Add "oauth_signature_method", "RSA-SHA1" Auth.Add "oauth_consumer_key", CONSUMER_KEY Auth.Add "oauth_token", CONSUMER_KEY For Each It In Params AllParams.Add It, Params.Item(It) Next For Each It In Auth AllParams.Add It, Auth.Item(It) Next SortedParamAuthString = ConcatenateSigParams(AllParams) SignatureText = "GET&" & URLEncode(Url, False) & "&" & URLEncode(SortedParamAuthString) Signature = SignText(SignatureText, PrivateKey, TempDir) Headers.Add "Authorization", "OAuth" & AuthInfo(Auth) & " oauth_signature=""" + URLEncode(Signature) & """" Result = MakeHttpRequest(Params, Headers, Url) MsgBox Result End Sub