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.

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:

1. 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.
2. 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