寻求VBA中基于OAuth2实现MS Access发票同步至Xero的示例代码

前置准备 #

• 在Xero开发者平台创建应用，获取Client ID和Client Secret，设置重定向URI为https://login.microsoftonline.com/common/oauth2/nativeclient（适配桌面原生应用）
• 在VBA编辑器中启用Microsoft XML, v6.0引用（工具→引用→勾选对应项）
• 导入VBA-JSON模块用于JSON解析（直接将代码导入Access模块即可）

核心代码模块 #

模块级配置与变量 #

Option Compare Database
Option Explicit

' Xero OAuth2 基础配置
Private Const XERO_CLIENT_ID As String = "你的Client ID"
Private Const XERO_CLIENT_SECRET As String = "你的Client Secret"
Private Const XERO_AUTH_URL As String = "https://login.xero.com/identity/connect/authorize"
Private Const XERO_TOKEN_URL As String = "https://identity.xero.com/connect/token"
Private Const XERO_API_BASE As String = "https://api.xero.com/api.xro/2.0/"

' 令牌存储（建议实际项目中存入加密表，避免重启丢失）
Private m_strAccessToken As String
Private m_strRefreshToken As String
Private m_dtExpiresAt As Date
Private m_strTenantID As String ' Xero租户ID，授权后获取

获取OAuth2授权与令牌 #

' 触发授权流程，获取初始令牌
Public Sub GetXeroOAuth2Auth()
    Dim strAuthUrl As String
    Dim strAuthCode As String
    Dim objHTTP As MSXML2.XMLHTTP60
    Dim strPostData As String
    Dim strResponse As String
    Dim objJSON As Object
    
    ' 构造授权URL，引导用户在浏览器中授权
    strAuthUrl = XERO_AUTH_URL & "?" & _
        "response_type=code" & _
        "&client_id=" & XERO_CLIENT_ID & _
        "&redirect_uri=https://login.microsoftonline.com/common/oauth2/nativeclient" & _
        "&scope=openid profile email accounting.transactions offline_access" & _
        "&state=access_sync_123" ' 自定义随机字符串，防CSRF攻击
    
    ' 打开浏览器授权页面
    Shell "explorer.exe """ & strAuthUrl & """", vbNormalFocus
    strAuthCode = InputBox("授权完成后，复制地址栏中的code参数并粘贴到此处：")
    
    If strAuthCode = "" Then Exit Sub
    
    ' 用授权码交换令牌
    Set objHTTP = New MSXML2.XMLHTTP60
    strPostData = "grant_type=authorization_code" & _
        "&code=" & strAuthCode & _
        "&redirect_uri=https://login.microsoftonline.com/common/oauth2/nativeclient" & _
        "&client_id=" & XERO_CLIENT_ID & _
        "&client_secret=" & XERO_CLIENT_SECRET
    
    With objHTTP
        .Open "POST", XERO_TOKEN_URL, False
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .Send strPostData
        
        If .Status <> 200 Then
            MsgBox "令牌获取失败：" & .Status & " " & .StatusText
            Exit Sub
        End If
        
        strResponse = .ResponseText
    End With
    
    ' 解析JSON响应
    Set objJSON = JsonConverter.ParseJson(strResponse)
    m_strAccessToken = objJSON("access_token")
    m_strRefreshToken = objJSON("refresh_token")
    m_dtExpiresAt = Now() + TimeSerial(0, 0, objJSON("expires_in"))
    
    ' 获取并存储租户ID（必须项，用于后续API请求）
    GetXeroTenantID
    
    MsgBox "授权成功，令牌已初始化"
End Sub

' 获取Xero租户ID
Private Sub GetXeroTenantID()
    Dim objHTTP As MSXML2.XMLHTTP60
    Dim strResponse As String
    Dim objJSON As Object
    Dim objConnection As Object
    
    Set objHTTP = New MSXML2.XMLHTTP60
    With objHTTP
        .Open "GET", "https://api.xero.com/connections", False
        .SetRequestHeader "Authorization", "Bearer " & m_strAccessToken
        .Send
        
        If .Status <> 200 Then
            MsgBox "租户ID获取失败：" & .Status & " " & .StatusText
            Exit Sub
        End If
        
        strResponse = .ResponseText
    End With
    
    Set objJSON = JsonConverter.ParseJson(strResponse)
    For Each objConnection In objJSON
        m_strTenantID = objConnection("tenantId")
        Exit For ' 取第一个租户ID，多租户场景需调整
    Next
    
    Set objHTTP = Nothing
End Sub

刷新访问令牌 #

' 自动刷新过期的访问令牌
Public Sub RefreshXeroToken()
    Dim objHTTP As MSXML2.XMLHTTP60
    Dim strPostData As String
    Dim strResponse As String
    Dim objJSON As Object
    
    If m_strRefreshToken = "" Then
        MsgBox "无有效刷新令牌，请重新授权"
        Exit Sub
    End If
    
    Set objHTTP = New MSXML2.XMLHTTP60
    strPostData = "grant_type=refresh_token" & _
        "&refresh_token=" & m_strRefreshToken & _
        "&client_id=" & XERO_CLIENT_ID & _
        "&client_secret=" & XERO_CLIENT_SECRET
    
    With objHTTP
        .Open "POST", XERO_TOKEN_URL, False
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .Send strPostData
        
        If .Status <> 200 Then
            MsgBox "令牌刷新失败：" & .Status & " " & .StatusText
            Exit Sub
        End If
        
        strResponse = .ResponseText
    End With
    
    Set objJSON = JsonConverter.ParseJson(strResponse)
    m_strAccessToken = objJSON("access_token")
    m_strRefreshToken = objJSON("refresh_token")
    m_dtExpiresAt = Now() + TimeSerial(0, 0, objJSON("expires_in"))
End Sub

同步Access发票到Xero #

' 同步指定发票到Xero（示例从tblInvoices读取待同步记录）
Public Sub SyncInvoiceToXero()
    Dim objHTTP As MSXML2.XMLHTTP60
    Dim strInvoiceJSON As String
    Dim rsInvoice As Recordset
    
    ' 检查令牌是否过期，自动刷新
    If Now() >= m_dtExpiresAt Then
        RefreshXeroToken
    End If
    
    ' 读取Access中未同步的发票（示例取第一条，实际可循环处理）
    Set rsInvoice = CurrentDb.OpenRecordset("SELECT * FROM tblInvoices WHERE IsSynced = False")
    If rsInvoice.EOF Then
        MsgBox "无待同步发票"
        Exit Sub
    End If
    
    ' 构造Xero兼容的发票JSON（根据实际字段调整）
    strInvoiceJSON = "{""Invoices"": [{" & _
        """Type"": ""ACCREC""," & _
        """Contact"": {""ContactID"": """ & rsInvoice!XeroContactID & """}," & _
        """Date"": """ & Format(rsInvoice!InvoiceDate, "yyyy-mm-dd") & """," & _
        """DueDate"": """ & Format(rsInvoice!DueDate, "yyyy-mm-dd") & """," & _
        """LineItems"": [{" & _
            """Description"": """ & Replace(rsInvoice!Description, """", """""""") & """," & _
            """Quantity"": " & rsInvoice!Quantity & "," & _
            """UnitAmount"": " & rsInvoice!UnitAmount & "," & _
            """AccountCode"": ""200"" " & ' 替换为你的Xero收入科目代码
        "}]" & _
    "}]}]"
    
    ' 发送POST请求到Xero API
    Set objHTTP = New MSXML2.XMLHTTP60
    With objHTTP
        .Open "POST", XERO_API_BASE & "Invoices", False
        .SetRequestHeader "Authorization", "Bearer " & m_strAccessToken
        .SetRequestHeader "Content-Type", "application/json"
        .SetRequestHeader "Xero-Tenant-Id", m_strTenantID
        
        .Send strInvoiceJSON
        
        If .Status >= 200 And .Status < 300 Then
            MsgBox "发票同步成功：" & rsInvoice!InvoiceNumber
            ' 更新Access中的同步状态
            rsInvoice.Edit
            rsInvoice!IsSynced = True
            rsInvoice!SyncDate = Now()
            rsInvoice.Update
        Else
            MsgBox "同步失败：" & .Status & " " & .StatusText & vbCrLf & .ResponseText
        End If
    End With
    
    rsInvoice.Close
    Set rsInvoice = Nothing
    Set objHTTP = Nothing
End Sub

关键注意事项 #

• 令牌请存储在Access加密表中，避免明文暴露或重启丢失
• 多租户场景需调整GetXeroTenantID逻辑，让用户选择目标租户
• 发票字段需与Xero API规范对齐，比如AccountCode必须是Xero中已存在的科目代码
• 建议添加完整的错误处理（On Error语句），提升稳定性

内容的提问来源于stack exchange，提问作者Brian