系列文章索引

Excel 也可以玩 REST
Excel 也可以玩 REST (2)
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 可能有一定难度。

我的相关文章链接：

• Flask 实现 Rest API
• SAP 如何提供 RESTful Web 服务？
• SAP 如何提供 RESTful Web 服务(2) – ABAP 与 JSON
• SAP 如何提供 RESTful Web 服务(3) – Rest 路径处理
• SAP Hana 数据库编程接口 – Node.js

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