Excel 也可以玩 REST (3)

接下來，設計一個以 Excel 作爲用戶界面，通過 HTTP Request 對數據庫進行 CRUD 操作的實現。我們在日常工作中，經常需要用 Excel 來記錄事件和數據，比如，在項目實施的過程中，記錄和跟進實施過程中的問題、任務分派等等。但如果不是專門的軟件，如 Redmine ，基於 Excel 文件記錄數據還是有很多不便之處的。比如版本衝突，多個人員不能同時編輯數據等等。

這個時候，用 Excel 作爲前端界面，實現在線的數據輸入和數據同步，不失爲一個好的方式。但常規的方法中，Excel 與數據庫交互，需要藉助諸如 ADO 這樣的數據訪問模型。一般來說，每一臺 PC 都需要安裝相關驅動。比如，如果在 Linux 操作系統上部署 MySQL 數據庫，那麼通過 ADO 的數據訪問數據庫的話，可能採用 ODBC，需要爲每一臺 PC 安裝 MySQL for ODBC 驅動。

但 Excel 基於 HTTP Request 的話，從理論上來說，只要有網絡，就可以實現 CRUD ，達到在線輸入的要求。所以在本篇中，我將介紹如何用 WinHttp COM 對象，藉助 Http Request，實現對 MySQL 數據庫的增刪改查。

當然，前提是有服務器端提供的 Restful API。我在前面相關文章中，使用不同的方法實現過 Restful API，比如 Pthon Flask、 SAP Web Service 和 Node.js 等等，都提供瞭如何實現 Restful API 的說明，感興趣的讀者可以參考我的文章，或者網絡上其他文章。如果是非開發人員，使用其他語言實現 Restful API 可能有一定難度。

Json 數據轉換

Json 數據轉換使用 Github 上的 VBA-Json 模塊。前面的文章也介紹了使用方法。

封裝 HTTP Request 方法

爲了使用方便，對 Http Request 進行封裝，封裝爲四個方法：

doGet: 處理 GET 請求
doPost: 處理 POST 請求
doPut: 處理 PUT 請求
doDelete：處理 DELETE 請求

代碼放在 HttpRequests 模塊，完整的代碼如下：

Option Explicit

Public Type HttpResponse
    Status As Long
    ResponseText As String
    StatusText As String
End Type

Public Function doGet(url As String) As HttpResponse
    On Error GoTo errHandler

    Dim httpReq As WinHttp.WinHttpRequest
    Dim httpResp As HttpResponse

    Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")

    httpReq.SetTimeouts 60000, 60000, 60000, 60000
    httpReq.Open "GET", url, False
    httpReq.Send

    httpResp.Status = httpReq.Status
    httpResp.ResponseText = httpReq.ResponseText
    httpResp.StatusText = httpReq.StatusText

    doGet = httpResp
    Exit Function

errHandler:
    MsgBox Err.Description
    Exit Function
End Function


Public Function doPost(url As String, payload As String) As HttpResponse
On Error GoTo errHandler
    Dim httpReq As WinHttp.WinHttpRequest
    Dim httpResp As HttpResponse

    Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")

    httpReq.Open "POST", url, False
    httpReq.SetRequestHeader "Content-Type", "application/json"

    httpReq.Send payload

    httpResp.Status = httpReq.Status
    httpResp.ResponseText = httpReq.ResponseText
    httpResp.StatusText = httpReq.StatusText

    doPost = httpResp
    Exit Function

errHandler:
    MsgBox Err.Description
    Exit Function
End Function


Public Function doPut(url As String, payload As String) As HttpResponse
On Error GoTo errHandler
    Dim httpReq As WinHttp.WinHttpRequest
    Dim httpResp As HttpResponse

    Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")

    httpReq.Open "PUT", url, False
    httpReq.SetRequestHeader "Content-Type", "application/json"

    httpReq.Send payload

    httpResp.Status = httpReq.Status
    httpResp.ResponseText = httpReq.ResponseText
    httpResp.StatusText = httpReq.StatusText

    doPut = httpResp
    Exit Function

errHandler:
    MsgBox Err.Description
    Exit Function
End Function


Public Function doDelete(url As String) As HttpResponse
On Error GoTo errHandler
    Dim httpReq As WinHttp.WinHttpRequest
    Dim httpResp As HttpResponse

    Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")

    httpReq.Open "DELETE", url, False
    httpReq.Send

    httpResp.Status = httpReq.Status
    httpResp.ResponseText = httpReq.ResponseText
    httpResp.StatusText = httpReq.StatusText

    doDelete = httpResp
    Exit Function

errHandler:
    MsgBox Err.Description
    Exit Function
End Function

CRUD 的請求

後臺使用 MySQL 數據庫，表名爲 emp_master。表的創建腳本和示例數據請參考：Flask 實現 Rest API。代碼放在 Employee_CRUD 模塊，主要是進一步封裝，簡化前端的調用。

Option Explicit

Public Const BASE_URL As String = "http://localhost:5000"

Public Function get_employees() As HttpResponse
    Dim resp As HttpResponse
    resp = doGet(BASE_URL & "/employees")
    get_employees = resp
End Function

Public Function create_employee(payload As String) As HttpResponse
    Dim resp As HttpResponse
    resp = doPost(BASE_URL & "/employees/create", payload)

    create_employee = resp
End Function

Public Function modify_employee(empId As Integer, payload As String) As HttpResponse
    Dim resp As HttpResponse
    resp = doPut(BASE_URL & "/employees/" & empId, payload)

    modify_employee = resp
End Function

Public Function delete_employee_by_id(empId As Integer) As HttpResponse
    Dim resp As HttpResponse
    resp = doDelete(BASE_URL & "/employees/" & empId)

    delete_employee_by_id = resp
End Function

至此，後臺功能全部完畢。

界面實現邏輯

下面說明前端的實現方式。首先我們看一看前端的界面，以及我的思路：

數據刷新、提交修改等功能，都通過 “超鏈接” 的方法實現，沒有使用按鈕控件，這樣界面更加清爽。當用戶在數據區域操作時，自動對用戶所在行的狀態進行記錄。當用戶修改了數據，所在行的 A 列自動標記 M。如果點擊插入新行，在現有數據下面插入一行，並且所在行的 A 列自動標記爲 N。如果需要刪除某行，則在 A 列的所在行輸入 D。點擊提交修改按鈕，新增、修改和刪除的記錄被提交到後臺。

數據區域使用 Table 表格來實現

Excel 提供了一個叫做 Table 的對象，與一般的數據區域 Range 不同，Table 對象在數據操作、界面自動化等多個方面都更加強大。Table 對象創建的方法，就是選定一個區域，然後 CTRL + T。Table 在 VBA 中被稱作 ListObject，比操作 Range 要方便很多。因爲篇幅原因，不對 ListObject做過多解釋。

工作表保護與取消保護

在線編輯涉及多個用戶，Excel 界面不能是沒有任何制約，否則可能導致服務器端數據的衝突和數據毀損。所以我通過 VBA 代碼，對 Excel 工作表進行保護，需要的時候通過代碼取消保護。

Public Sub setWorksheetProtection(sht As Worksheet)
    Dim editRange As AllowEditRange
    For Each editRange In sht.Protection.AllowEditRanges
        editRange.Delete
    Next
    sht.Protection.AllowEditRanges.Add Title:="EditArea", Range:=sht.ListObjects("EmpTable").DataBodyRange
    sht.Protection.AllowEditRanges.Add Title:="ActionFlag", Range:=sht.Range("A:A")

    sht.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowFiltering:=True, Password:="123456"
End Sub


Public Sub removeWorkSheetProtection(sht As Worksheet)
    sht.Unprotect Password:="123456"
End Sub

行項目狀態的自動標記

自動標記通過 Workbook_SheetChange 事件來實現。當然，我們不能始終都觸發這些事件，所以，我用一個全局變量 isRecordingChange 來記錄是否要自動記錄修改。

Public isRecordingChange As Boolean

Public Sub setRecordingFlag(flag As Boolean)
    isRecordingChange = flag
End Sub

工作簿打開的時候，isRecordingChange 爲 True:

Private Sub Workbook_Open()
    setRecordingFlag True
End Sub

如果用戶在數據區域（用戶可編輯的數據區域爲 ListObject EmpTable ）修改了記錄，自動將 A 列標記爲 M:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If isRecordingChange = False Then Exit Sub

    Dim cell As Range
    Dim actionMarkCell As Range

    For Each cell In Target.Cells
        If isCellInRange(cell, SheetCRUD.ListObjects("EmpTable").DataBodyRange) Then
            Set actionMarkCell = SheetCRUD.Cells(cell.row, 1)
            If Len(actionMarkCell.Value) = 0 Then

                Call removeWorkSheetProtection(SheetCRUD)
                actionMarkCell.Value = "M"
                Call setWorksheetProtection(SheetCRUD)

            End If
        End If
    Next
End Sub

注意 isCellInRange(cell, SheetCRUD.ListObjects("EmpTable").DataBodyRange) 用於判斷數據修改過的單元格是否在 EmpTable 的 DataBodyRange 範圍內。isCellInRange 是一個自定義函數，判斷單元格 (cell) 是否在某一個範圍 (rng) 內。代碼如下：

Public Function isCellInRange(cell As Range, rng As Range) As Boolean    
    If rng Is Nothing Then
        isCellInRange = False
        Exit Function
    End If

    If cell Is Nothing Then
        isCellInRange = False
        Exit Function
    End If

    Dim isect As Object
    Set isect = Application.Intersect(cell, rng)

    If isect Is Nothing Then
        isCellInRange = False
    Else
        isCellInRange = True
    End If
End Function

如果用戶點擊了插入新行超鏈接，則自動在 A 列標記 N:

Public Sub insert_new_row()
    Call setRecordingFlag(False)
    Call removeWorkSheetProtection(SheetCRUD)

    Dim tbl As ListObject
    Set tbl = SheetCRUD.ListObjects("EmpTable")
    tbl.ListRows.Add alwaysinsert:=True
    tbl.Range(tbl.ListRows.Count, 1).Offset(1, -1).Value = "N"

    Call setRecordingFlag(True)
    Call setWorksheetProtection(SheetCRUD)
End Sub

超鏈接與宏代碼綁定

如何用超鏈接來完成操作呢？我以 “刷新” 爲例，介紹相關步驟。首先，在 B1 單元中輸入刷新，然後右鍵，選擇 超鏈接。在下面的界面中，“鏈接到” 選擇本文檔中的位置，單元格引用輸入本身所在的單元格，“屏幕提示” 可以輸入一個更加清晰的提示，否則，當光標在這個單元格，Excel 顯示鏈接的目標地址。

接下來，進入 VBE 代碼編寫環境，Excel 對於工作薄和工作表，都有相應的 FollowHyperLink 事件。本示例只有一個工作表，所以我就在 Worksheet_FollowHyperLink 事件中編寫代碼：

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Dim rng As Range
    Set rng = Target.Range

    Select Case rng.Value
        Case "刷新"
            Call refresh_data

        Case "插入新行"
            Call insert_new_row

        Case "提交修改"
            Call submit_change_requests
    End Select
End Sub

根據 Target.Value，執行不同的操作。

前臺功能的實現

刷新數據

當用戶點擊刷新數據 按按鈕，觸發 refresh_data 過程。refresh_data 過程調用 get_employees() 函數：

Public Sub refresh_data()
    Call setRecordingFlag(False)
    Call removeWorkSheetProtection(SheetCRUD)

    Dim resp As HttpResponse
    resp = get_employees()
    If resp.Status = 200 Then
        Call writeJson(resp.ResponseText, SheetCRUD)
    End If

    setRecordingFlag True

    Call setWorksheetProtection(SheetCRUD)
End Sub

如果 Http 請求的狀態碼爲 200，將獲取的 json 數據寫到工作表中 (writeJson)：

Public Sub writeJson(jsonText As String, sht As Worksheet)
    Dim parsedDict As Object
    Set parsedDict = JsonConverter.parseJson(jsonText)("rows")

    Dim tbl As ListObject
    Set tbl = sht.ListObjects("EmpTable")
    If Not tbl.DataBodyRange Is Nothing Then
        tbl.DataBodyRange.Rows.Delete
    End If

    ' Print headers
    Dim startCell As Range
    Set startCell = sht.Range("B2")

    startCell.Offset(0, 0) = "僱員ID"
    startCell.Offset(0, 1) = "性別"
    startCell.Offset(0, 2) = "年齡"
    startCell.Offset(0, 3) = "Email"
    startCell.Offset(0, 4) = "電話號碼"
    startCell.Offset(0, 5) = "教育程度"
    startCell.Offset(0, 6) = "婚姻狀況"
    startCell.Offset(0, 7) = "子女數"

    ' Print items
    Dim item As Dictionary
    Dim valArray() As Variant
    ReDim valArray(1 To parsedDict.Count, 1 To 8)

    Dim rowIdx As Long
    rowIdx = 1
    For Each item In parsedDict
        valArray(rowIdx, 1) = item("EMP_ID")
        valArray(rowIdx, 2) = item("GENDER")
        valArray(rowIdx, 3) = item("AGE")
        valArray(rowIdx, 4) = item("EMAIL")
        valArray(rowIdx, 5) = item("PHONE_NR")
        valArray(rowIdx, 6) = item("EDUCATION")
        valArray(rowIdx, 7) = item("MARITAL_STAT")
        valArray(rowIdx, 8) = item("NR_OF_CHILDREN")

        rowIdx = rowIdx + 1
    Next

    startCell.Offset(1, 0).Resize(parsedDict.Count, 8).Value = valArray
End Sub

插入新行

用戶點擊插入新行超鏈接，插入一個新行，並且標記爲 N。insert_new_row 的代碼剛剛已經介紹了，請自行參考。

提交修改

如果用戶點擊了提交修改超鏈接，自動將修改的數據提交到後臺：

Public Sub submit_change_requests()
    Dim empId As Integer
    Dim tbl As ListObject

    Set tbl = SheetCRUD.ListObjects("EmpTable")

    ' 取消工作表保護
    Call removeWorkSheetProtection(SheetCRUD)

    ' 根據 A 列確定相應的操作
    ' N: 新增， M: 修改, D: 刪除
    Dim idx As Long
    Dim action As String

    For idx = 1 To tbl.ListRows.Count
        action = tbl.ListRows(idx).Range(1, 1).Offset(0, -1).Value

        If UCase(action) = "N" Then
            If str(tbl.ListRows(idx).Range(1, 1).Value) = "" Then
                tbl.ListRows(idx).Range(1, 1).Offset(0, -1).Value = ""
            Else
                Dim newEmp As Employee
                Dim payload As String

                newEmp = build_employee_from_range(idx)
                payload = convert_emp_to_json_text(newEmp)

                Dim resp As HttpResponse
                resp = create_employee(payload)

                If resp.Status = 201 Then
                    tbl.ListRows(idx).Range(1, 1).Offset(0, -1).Value = ""
                End If
            End If
        End If

        If UCase(action) = "M" Then
            Application.ScreenUpdating = False

            Dim modifiedEmp As Employee
            modifiedEmp = build_employee_from_range(idx)
            empId = tbl.ListRows(idx).Range(1, 1).Value

            payload = convert_emp_to_json_text(modifiedEmp)
            Call modify_employee(empId, payload)

            tbl.ListRows(idx).Range(1, 1).Offset(0, -1).Value = ""
            Application.ScreenUpdating = True
        End If

        If UCase(action) = "D" Then
            empId = tbl.ListRows(idx).Range(1, 1).Value

            Call delete_employee_by_id(empId)

            tbl.ListRows(idx).Range(1, 1).Offset(0, -1).Value = ""
            tbl.ListRows(idx).Delete
        End If
    Next

    Call setWorksheetProtection(SheetCRUD)
End Sub

除了前面已經說明過的 create_employee() 函數和 modify_employee() 函數，submit_change_requests 過程還調用了 build_employee_from_range 函數，該函數將 Excel 某一行的數據轉換成 Dictionary 對象，convert_emp_to_json_text 函數，將 Dictionary 轉換成 json 格式。

因爲我們處理的數據都是針對 employee master，爲了方便，先定義一個結構：

Public Type Employee
    Emp_ID As Integer
    Gender As String
    Age As Integer
    Email As String
    Phone_Nr As String
    Education As String
    Marital_Stat As String
    Nr_Of_Children As Integer
End Type

build_employee_from_range 函數:

Public Function build_employee_from_range(rowNumber As Long) As Employee
    Dim tbl As ListObject
    Set tbl = SheetCRUD.ListObjects("EmpTable")

    Dim emp As Employee
    Dim idx As Long
    idx = rowNumber
    emp.Emp_ID = tbl.DataBodyRange(idx, 1).Value
    emp.Gender = tbl.DataBodyRange(idx, 2).Value
    emp.Age = tbl.DataBodyRange(idx, 3).Value
    emp.Email = tbl.DataBodyRange(idx, 4).Value
    emp.Phone_Nr = tbl.DataBodyRange(idx, 5).Value
    emp.Education = tbl.DataBodyRange(idx, 6).Value
    emp.Marital_Stat = tbl.DataBodyRange(idx, 7).Value
    emp.Nr_Of_Children = tbl.DataBodyRange(idx, 8).Value

    build_employee_from_range = emp
End Function

convert_emp_to_json_text 函數:

Public Function convert_emp_to_json_text(emp As Employee) As String
    Dim payloadDict As New Dictionary

    payloadDict.Add "EMP_ID", emp.Emp_ID
    payloadDict.Add "GENDER", emp.Gender
    payloadDict.Add "AGE", emp.Age
    payloadDict.Add "EMAIL", emp.Email
    payloadDict.Add "PHONE_NR", emp.Phone_Nr
    payloadDict.Add "EDUCATION", emp.Education
    payloadDict.Add "MARITAL_STAT", emp.Marital_Stat
    payloadDict.Add "NR_OF_CHILDREN", emp.Nr_Of_Children

    Dim payload As String
    payload = JsonConverter.ConvertToJson(payloadDict)

    convert_emp_to_json_text = payload
End Function

Excel 也可以玩 REST (3)

Json 數據轉換

封裝 HTTP Request 方法

CRUD 的請求

界面實現邏輯

數據區域使用 Table 表格來實現

工作表保護與取消保護

行項目狀態的自動標記

超鏈接與宏代碼綁定

前臺功能的實現

刷新數據

插入新行

提交修改

杭州的 IT 崩盤了麼？

開源高性能結構化日誌模塊NanoLog

【簡寫Mybatis-02】註冊機的實現以及SqlSession處理

手繪二維碼

.NET藉助虛擬網卡實現一個簡單異地組網工具

如何對SAP數據庫表進行增刪改查操作

如何對SAP數據庫表進行增刪改查操作(2)?

SAP FI 系列 006 : COA 的概念和配置

PyCharm如何使用Qt Designer

SAP FI 系列 009: LSMW導入會計科目主數據

Mac下配置sublime實現LaTeX

https://yachay.unat.edu.pe/blog/index.php?comment_area=format_blog&comment_component=blog&comment_co

linux以太網驅動總結