Access 用 Edge 控件做 DataTable：从建窗体到完整 VBA 代码

摘要： 这次做一个 Access Edge DataTable Demo：手工建立窗体和 Edge 浏览器控件，用 VBA 读取任意表或查询，生成前端数据文件，实现搜索、排序、分页、CSV 导出和打印。

Hi，大家好！

最近的天气是真的热，这种持续40度天气，真难受。但开发的热情不能减。前两篇文章我一直在讲不用链接表该怎么处理，功能demo中显示数据的控件都是用的列表框，但这种方式明显还不够，所以，我想到了edge浏览器控件。

我们先来看看最终效果是：打开 Access 窗体，里面显示的不是传统子窗体，而是一张由 Edge 控件加载的网页表格。表头根据字段自动生成，数据变化后单击“刷新数据”就能重新加载。

这篇不讨论自动生成窗体，也不自动创建 Demo 表。我按实际制作顺序，从空白窗体开始做，最后把完整 VBA 模块贴出来。

先说明这个版本的定位：它目前只是一个功能 Demo，不建议直接用于生产环境。

当前版本主要验证 3 件事：

  1. Access 能不能把表或查询转换成网页可读的数据。

  2. Access 新版 Edge 控件能不能稳定加载本地 DataTable 页面。

  3. 搜索、排序、分页、CSV 导出这些前端功能能不能在 Access 窗体里正常运行。

真正用于业务系统时，还要继续处理大数据分页、权限、字段显示配置、异常日志、缓存、多用户部署等问题。后面我会把生产版实现开发到 Access 开发框架专业版里。

一、这次用的是 Access Edge 浏览器控件

这里用的不是以前基于 IE 的“Web 浏览器控件”，而是新版 Access 里的 Edge 浏览器控件。我为什么用edge控件呢，因为它的效果更好，能处理的样式更漂亮。

在窗体设计视图中，菜单位置一般是：

设计 → 控件 → Edge 浏览器控件

插入后，在属性表里可以看到它属于 Edge 浏览器控件。

如果你的 Access 控件列表里没有它，通常是 Office 版本较旧。这个 Demo 需要支持 Edge 浏览器控件的 Microsoft 365 Access 或较新的 Access 版本。

二、准备文件

先准备下面 3 个文件，并放在 Access 数据库同一目录：

你的数据库.accdb
datatable.html
datatable-data.js

datatable.html 是 DataTable 页面，里面包含：

  • Bootstrap 样式

  • jQuery

  • DataTables

  • 中文分页文字

  • CSV 导出

  • 打印

  • 日期、货币、是/否字段的显示格式

datatable-data.js 是数据文件。它不用手工维护，每次打开窗体或单击刷新按钮时，VBA 会重新生成。

HTML 代码比较长，整段贴进文章会影响阅读。需要完整 datatable.html 和相关静态文件的朋友，可以在公众号后台留言或私信我，我把 Demo 文件发给你。

要注意，HTML 里引用的 CSS 和 JavaScript 最好放在本地，不要依赖 CDN。客户电脑断网以后，本地文件仍然能正常加载。

三、准备一个表或查询

这个功能不限定表结构。产品表、客户表、订单查询、库存查询都可以。

为了测试，我准备了一张 t_DataTableDemo，字段如下：

字段名 Access 类型
ID 自动编号
Name 短文本
Position 短文本
Office 短文本
Age 数字
StartDate 日期/时间
Salary 货币
Active 是/否

实际项目里，我更建议给 Edge DataTable 绑定查询，而不是直接读取业务表。

比如建立一个查询 qry_库存明细，只放用户需要看的字段，还可以在查询中完成这些事情：

  • 调整字段顺序

  • 修改字段显示名称

  • 计算金额

  • 拼接规格型号

  • 过滤停用记录

  • 关联供应商名称

网页负责显示，业务数据的口径仍然留在 Access 查询里，这样比较好维护。

四、建立窗体

新建一个空白窗体，保存为：

frmAccessDataTable

窗体上放两个控件。

控件类型 控件名 用途
Edge 浏览器控件 edgeData 显示 DataTable 页面
命令按钮 cmdRefresh 重新导出并加载数据

选中 edgeData，在属性表的“其他”选项卡里找到 Tag，中文界面通常显示为“标记”。

填写要显示的表名或查询名：

t_DataTableDemo

以后想换数据源，只需要改这个属性。例如：

qry_库存明细

edgeData 的“控件来源”保持为空。

我测试时发现，部分 Access 版本在代码里反复设置 Edge 控件的 ControlSource 并不稳定。这个 Demo 不修改 ControlSource，统一使用 Navigate 方法加载页面。

刷新按钮 cmdRefresh 的标题改为：

刷新数据

“单击”属性写：

=RefreshAccessDataTable()

五、为什么要使用窗体计时器

如果在窗体“加载”事件里马上执行：

edgeData.Navigate DataTableUrl

有时数据文件已经生成了，但 Edge 控件仍然停在 about:blank。

原因是窗体已经开始加载，不代表 Edge WebView2 已经初始化完成。

这个 Demo 的处理方式是让窗体延迟 500 毫秒再初始化。

打开 frmAccessDataTable 的属性表，设置：

计时器间隔：500
计时器触发：=InitializeAccessDataTable()

InitializeAccessDataTable 执行后，会立即把计时器间隔改成 0，所以只运行一次，不会每隔 500 毫秒不停刷新。

这不是为了做动画，而是给 Edge 控件留一点初始化时间。

六、导入 VBA 标准模块

按 Alt + F11 打开 VBA 编辑器，新建一个标准模块，模块名为：

Module_AccessDataTable

下面是这个 Demo 当前使用的完整 VBA 代码。

Attribute VB_Name = "Module_AccessDataTable"
Option Compare Database
Option Explicit

'============================================================
' Access 数据表 + Edge 浏览器
'
' 加载任意表或查询：
'   LoadAccessDataTable Forms!frmAccessDataTable, "edgeData", "数据源名称"
'============================================================

Private Const FORM_NAME As String = "frmAccessDataTable"
Private Const EDGE_NAME As String = "edgeData"
Private Const HTML_FILE_NAME As String = "datatable.html"
Private Const DATA_FILE_NAME As String = "datatable-data.js"

Public Sub LoadAccessDataTable(ByVal frm As Access.Form, _
                               ByVal edgeControlName As String, _
                               ByVal sourceName As String)
    On Error GoTo ErrHandler

    ExportAccessDataTable sourceName
    frm.Controls(edgeControlName).Tag = sourceName
    frm.Controls(edgeControlName).Navigate DataTableUrl
    Exit Sub

ErrHandler:
    MsgBox "无法加载数据表：" & Err.Description, _
           vbExclamation, "Access 数据表"
End Sub

Public Function InitializeAccessDataTable() As Boolean
    On Error GoTo ErrHandler

    Dim frm As Access.Form
    Dim edge As Object
    Dim sourceName As String

    Set frm = Forms(FORM_NAME)
    Set edge = frm.Controls(EDGE_NAME)
    sourceName = Nz(edge.Tag, vbNullString)
    frm.TimerInterval = 0

    ExportAccessDataTable sourceName
    edge.Navigate DataTableUrl
    InitializeAccessDataTable = True
    Exit Function

ErrHandler:
    MsgBox "无法初始化数据表：" & Err.Description, _
           vbExclamation, "Access 数据表"
End Function

Public Function RefreshAccessDataTable() As Boolean
    On Error GoTo ErrHandler

    Dim frm As Access.Form
    Dim edge As Object
    Dim sourceName As String

    Set frm = Forms(FORM_NAME)
    Set edge = frm.Controls(EDGE_NAME)
    sourceName = Nz(edge.Tag, vbNullString)

    ExportAccessDataTable sourceName
    edge.Navigate DataTableUrl
    RefreshAccessDataTable = True
    Exit Function

ErrHandler:
    MsgBox "无法刷新数据表：" & Err.Description, _
           vbExclamation, "Access 数据表"
End Function

Public Function ExportAccessDataTable( _
    ByVal sourceName As String) As String

    On Error GoTo ErrHandler

    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim fld As DAO.Field
    Dim output As String
    Dim separator As String
    Dim i As Long

    If Len(Trim$(sourceName)) = 0 Then
        Err.Raise vbObjectError + 7200, , _
                  "表或查询名称不能为空。"
    End If

    If Not RecordSourceExists(sourceName) Then
        Err.Raise vbObjectError + 7201, , _
                  "找不到表或查询：" & sourceName
    End If

    Set db = CurrentDb
    Set rs = db.OpenRecordset( _
        "SELECT * FROM " & BracketName(sourceName), _
        dbOpenSnapshot)

    output = "window.ACCESS_DATATABLE_PAYLOAD = {" & vbCrLf
    output = output & _
             "  ""source"": " & _
             JsonQuote(sourceName) & "," & vbCrLf
    output = output & _
             "  ""generatedAt"": " & _
             JsonQuote(Format$(Now, "yyyy-mm-dd hh:nn:ss")) & _
             "," & vbCrLf
    output = output & "  ""columns"": ["

    separator = vbNullString

    For Each fld In rs.Fields
        output = output & separator & vbCrLf & _
                 "    {""name"":" & _
                 JsonQuote(fld.Name) & _
                 ",""label"":" & _
                 JsonQuote(fld.Name) & _
                 ",""type"":" & _
                 JsonQuote(JsonFieldType(fld.Type)) & "}"
        separator = ","
    Next fld

    If rs.Fields.Count > 0 Then
        output = output & vbCrLf & "  "
    End If

    output = output & "]," & vbCrLf & "  ""rows"": ["
    separator = vbNullString

    Do Until rs.EOF
        output = output & separator & vbCrLf & "    {"

        For i = 0 To rs.Fields.Count - 1
            If i > 0 Then output = output & ","

            output = output & _
                     JsonQuote(rs.Fields(i).Name) & ":" & _
                     JsonValue(rs.Fields(i).Value, _
                               rs.Fields(i).Type)
        Next i

        output = output & "}"
        separator = ","
        rs.MoveNext
    Loop

    If Len(separator) > 0 Then
        output = output & vbCrLf & "  "
    End If

    output = output & "]" & vbCrLf & "};" & vbCrLf

    WriteUtf8Text DataFilePath(), output
    ExportAccessDataTable = DataFilePath()

CleanExit:
    On Error Resume Next
    If Not rs Is Nothing Then rs.Close
    Set rs = Nothing
    Set db = Nothing
    Exit Function

ErrHandler:
    Dim errorNumber As Long
    Dim errorDescription As String

    errorNumber = Err.Number
    errorDescription = Err.Description
    Resume CleanError

CleanError:
    On Error Resume Next
    If Not rs Is Nothing Then rs.Close
    Set rs = Nothing
    Set db = Nothing
    On Error GoTo 0

    Err.Raise errorNumber, _
              "ExportAccessDataTable", _
              errorDescription
End Function

Private Function DataTableUrl() As String
    DataTableUrl = "https://msaccess/" & HtmlFilePath()
End Function

Private Function HtmlFilePath() As String
    HtmlFilePath = CurrentProject.Path & _
                   "\" & HTML_FILE_NAME

    If Len(Dir$(HtmlFilePath)) = 0 Then
        Err.Raise vbObjectError + 7202, , _
                  "找不到 HTML 文件：" & HtmlFilePath
    End If
End Function

Private Function DataFilePath() As String
    DataFilePath = CurrentProject.Path & _
                   "\" & DATA_FILE_NAME
End Function

Private Function RecordSourceExists( _
    ByVal sourceName As String) As Boolean

    RecordSourceExists = _
        TableExists(sourceName) Or _
        QueryExists(sourceName)
End Function

Private Function TableExists( _
    ByVal tableName As String) As Boolean

    On Error Resume Next

    Dim ignored As String
    ignored = CurrentDb.TableDefs(tableName).Name
    TableExists = (Err.Number = 0)
    Err.Clear
End Function

Private Function QueryExists( _
    ByVal queryName As String) As Boolean

    On Error Resume Next

    Dim ignored As String
    ignored = CurrentDb.QueryDefs(queryName).Name
    QueryExists = (Err.Number = 0)
    Err.Clear
End Function

Private Function BracketName( _
    ByVal objectName As String) As String

    BracketName = "[" & _
                  Replace(objectName, "]", "]]") & _
                  "]"
End Function

Private Function JsonFieldType( _
    ByVal daoType As Long) As String

    Select Case daoType
        Case dbBoolean
            JsonFieldType = "boolean"

        Case dbByte, dbInteger, dbLong, _
             dbSingle, dbDouble, dbDecimal
            JsonFieldType = "number"

        Case dbCurrency
            JsonFieldType = "currency"

        Case dbDate
            JsonFieldType = "date"

        Case Else
            JsonFieldType = "text"
    End Select
End Function

Private Function JsonValue( _
    ByVal value As Variant, _
    ByVal daoType As Long) As String

    If IsNull(value) Then
        JsonValue = "null"
        Exit Function
    End If

    Select Case daoType
        Case dbBoolean
            JsonValue = LCase$(CStr(CBool(value)))

        Case dbByte, dbInteger, dbLong, _
             dbSingle, dbDouble, _
             dbDecimal, dbCurrency

            JsonValue = Replace( _
                Format$(value, "0.################"), _
                ",", ".")

        Case dbDate
            JsonValue = JsonQuote( _
                Format$(CDate(value), _
                        "yyyy-mm-dd hh:nn:ss"))

        Case Else
            JsonValue = JsonQuote(CStr(value))
    End Select
End Function

Private Function JsonQuote( _
    ByVal value As String) As String

    Dim text As String

    text = Replace(value, "\", "\\")
    text = Replace(text, """", "\""")
    text = Replace(text, vbCrLf, "\n")
    text = Replace(text, vbCr, "\n")
    text = Replace(text, vbLf, "\n")
    text = Replace(text, vbTab, "\t")

    JsonQuote = """" & text & """"
End Function

Private Sub WriteUtf8Text( _
    ByVal filePath As String, _
    ByVal text As String)

    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")

    With stream
        .Type = 2
        .Charset = "utf-8"
        .Open
        .WriteText text
        .SaveToFile filePath, 2
        .Close
    End With
End Sub

这段代码不需要额外的 JSON 类库，字段和值不多时，用字符串拼接更容易部署。

有几个处理不能少：

  • Null 必须输出成 null。

  • 是/否字段必须输出成 true 或 false。

  • 数字不能加双引号，否则前端会按文本排序。

  • 日期统一输出为 yyyy-mm-dd hh:nn:ss。

  • 文本里的双引号、反斜杠、换行必须转义。

  • 数据文件要按 UTF-8 写入，否则中文容易乱码。

七、编译并运行

代码粘贴完成后，在 VBA 编辑器中执行：

调试 → 编译

没有错误后，保存并关闭 VBA 编辑器。

重新打开 frmAccessDataTable，运行顺序是：

窗体启动
  ↓
500 毫秒计时器触发
  ↓
读取 edgeData.Tag
  ↓
打开对应表或查询
  ↓
生成 datatable-data.js
  ↓
Edge 控件 Navigate 到 datatable.html
  ↓
网页显示数据

测试时可以按下面顺序检查：

  1. 在搜索框输入姓名或城市，确认结果会即时筛选。

  2. 单击“年龄”或“薪资”表头，确认数字排序正确。

  3. 切换每页 10、25、50 条。

  4. 单击“导出 CSV”，确认导出的是筛选后的记录。

  5. 直接修改 Access 表中的一条数据。

  6. 回到窗体单击“刷新数据”，确认页面显示新值。

八、常见问题

1. Edge 控件一直显示空白

先检查 datatable.html 是否和数据库放在同一目录。

再检查窗体计时器：

计时器间隔：500
计时器触发：=InitializeAccessDataTable()

如果直接在“加载”事件里导航，某些电脑上会因为 Edge 控件尚未初始化而停在 about:blank。

2. 提示找不到表或查询

检查 edgeData 的“标记”属性。名称必须和导航窗格中的表名或查询名完全一致。

3. 中文显示乱码

确认 VBA 使用 ADODB.Stream 写文件，并设置：

.Charset = "utf-8"

同时确认 HTML 头部有：

<meta charset="utf-8">

4. 控件列表里找不到 Edge 浏览器控件

这个 Demo 用的是 Access 新版 Edge 浏览器控件，不是旧版 IE WebBrowser。旧版 Access 无法按本文方法直接运行，需要升级到支持该控件的版本。

5. 数据量大时打开很慢

当前 Demo 是一次性把查询结果全部写进 JavaScript 文件，再由浏览器做客户端分页。

几百条、几千条记录可以用来测试。几十万条记录不能这样直接加载，需要改成服务端分页或按条件分批查询。这也是我不建议把当前 Demo 直接用于生产环境的原因之一。

九、当前 Demo 的限制

这次的重点是验证 Access、VBA、Edge 控件和 DataTables 之间的数据链路，所以我有意控制了范围。

当前版本没有实现：

  • 网页中直接新增、编辑、删除 Access 记录

  • 服务端分页

  • 字段权限

  • 用户自定义列

  • 多表配置管理

  • 导出权限控制

  • 统一异常日志

  • 多用户并发处理

  • 前端文件自动部署和版本更新

所以它更适合学习、测试和展示思路，目前不能作为生产版组件直接放进正式项目。

如果只做内部只读查询，而且数据量不大，可以在备份后的测试库中尝试。涉及正式业务数据时，还是要把权限、异常处理和数据规模考虑完整。

HTML 部分因为代码较长，这篇没有全文展开。需要完整 HTML、CSS、JavaScript 和示例数据库的朋友，可以在公众号后台留言或私信我。

posted @ 2026-08-05 15:35  edonsoft  阅读(7)  评论(0)    收藏  举报