动态

Excel 有「缩小字体填充」，Access 也能做到

3.png

Hi，大家好！

五一假期结束，收收心，继续搞 Access。

用 Excel 做表的人应该都知道一个很方便的小功能：单元格格式里有个「缩小字体填充」，勾上之后文字太长就自动把字号缩小，不用手动调列宽，内容也不会被截断。


2.png


回到 Access，报表里其实有完全一样的需求——文本框列宽固定，数据长度千差万别。比如产品名称，短的叫「螺栓」两个字，长的叫「M12×123 304 不锈钢六角螺栓全螺纹带螺母平垫」二十几个字。列宽设窄了长内容截断，设宽了短内容后面空一大片。


但 Access 偏偏没有这个选项。


没关系，自己做一个。本文从零实现一个模块，在 Access 窗体和报表中实现和 Excel 一样的「缩小字体填充」效果——文本框宽度不变，文字太长时自动缩小字号，刚好完整显示在框内。


比如产品名称，最短的两个字，最长的二十几个字。列宽设窄了长内容被截断，设宽了版面塞不下。让用户每次手工调字号也不现实——几十页的报表，每条记录长度都不同。


如果在 Access 里能做到：文本框宽度不变，文字太长时自动把字号缩小，刚好完整显示在框内——体验会好很多。


这就是文字自适应（Text Auto-Size），和 Excel 的「缩小字体填充」效果类似。本文从零实现一个模块，在 Access 窗体和报表中按内容长度自动调节字号。


技术原理分析

核心逻辑是逐级缩小：

步骤做什么
1用 GDI 测量文本在当前字号下的渲染宽度
2如果宽度 ≤ 文本框可用宽度 → 当前字号 OK，不调整
3如果宽度 > 可用宽度 → 字号减 1 磅，回到步骤 1
4重复直到文本能完整显示，或字号触及最小底线

不是简单按字符数线性缩——那样中英文混排会翻车。每一步都要用 GDI 真实测量渲染宽度，然后决定是否继续缩小。

测量仍然靠 Win32 API，但和之前不一样的是：这次控制变量是字号，测完不是设 .Width，而是设 .FontSize。

实现步骤

1
第一步：创建标准模块

在 VBA 编辑器中新建标准模块，命名为 basTextAutoFit，复制以下完整代码：


Option Compare Database
Option Explicit

' ============================================
' 模块: basTextAutoFit
' 用途: 文本框文字自适应——宽度固定，
'       内容过长时自动缩小字号，直到装下
' 场景: 报表中的固定列宽文本框、标签等
' 说明: 通过 GDI Unicode API 逐级测量，
'       字号从大到小递减，找到能完整显示
'       内容的最大字号
' ============================================

' === API 声明（32/64 位兼容，Unicode 版本） ===
#If VBA7 Then
    Private Declare PtrSafe Function CreateFontIndirectW Lib "gdi32" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function GetTextExtentPoint32W Lib "gdi32" (ByVal hDC As LongPtr, ByVal lpString As LongPtr, ByVal c As Long, lpSize As SIZE) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
#Else
    Private Declare Function CreateFontIndirectW Lib "gdi32" (lpLogFont As LOGFONT) As Long
    Private Declare Function GetTextExtentPoint32W Lib "gdi32" (ByVal hDC As Long, ByVal lpString As Long, ByVal c As Long, lpSize As SIZE) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
#End If

' === 结构体 ===
Private Type LOGFONT
    lfHeight         As Long
    lfWidth          As Long
    lfEscapement     As Long
    lfOrientation    As Long
    lfWeight         As Long
    lfItalic         As Byte
    lfUnderline      As Byte
    lfStrikeOut      As Byte
    lfCharSet        As Byte
    lfOutPrecision   As Byte
    lfClipPrecision  As Byte
    lfQuality        As Byte
    lfPitchAndFamily As Byte
    lfFaceName       As String * 32
End Type

Private Type SIZE
    cx As Long
    cy As Long
End Type

' === 常量 ===
Private Const LOGPIXELSY As Long = 90
Private Const FW_NORMAL  As Long = 400
Private Const FW_BOLD    As Long = 700

' ============================================
' 公开方法
' ============================================

' 函数说明: 固定文本框宽度，自动缩小字号以适应内容
' 参数: txt        - 目标文本框
'       lMinFont   - 最小字号（磅），缩到此后不再缩小，默认 6
'       lPadding   - 左右内边距（缇），文本与边框之间的留白，默认 60
' 返回: 最终应用的字号（磅）
' 说明: 如果内容为空或已能完整显示，保持原字号不变
Public Function AutoFontSize(ByRef txt As Access.TextBox, _
                             Optional ByVal lMinFont As Long = 6, _
                             Optional ByVal lPadding As Long = 60) As Double
    On Error GoTo ErrHandler

    Dim sText As String
    sText = Nz(txt.value, "")
    AutoFontSize = txt.FontSize

    ' 空内容无需调整
    If Len(sText) = 0 Then Exit Function

    ' 可用宽度 = 控件宽度 - 左右内边距
    Dim lAvailWidth As Long
    lAvailWidth = txt.Width - lPadding * 2
    If lAvailWidth <= 0 Then Exit Function

    Dim dFontSize As Double
    dFontSize = txt.FontSize

    ' 当前字号已经能装下，不用调
    If TextWidthTwips(sText, txt.FontName, dFontSize, txt.FontBold, txt.FontItalic) <= lAvailWidth Then
        Exit Function
    End If

    ' 逐级缩小，直到文字能装下或触底
    Do While dFontSize > lMinFont
        dFontSize = dFontSize - 1
        If TextWidthTwips(sText, txt.FontName, dFontSize, txt.FontBold, txt.FontItalic) <= lAvailWidth Then
            Exit Do
        End If
    Loop

    txt.FontSize = dFontSize
    AutoFontSize = dFontSize
    Exit Function

ErrHandler:
    AutoFontSize = txt.FontSize
End Function

' 函数说明: 对窗体/报表上所有文本框批量自适应字号
' 参数: frm - 目标 Form 或 Report 对象
Public Sub AutoFontSizeAll(ByRef frm As Object)
    Dim ctl As Control
    For Each ctl In frm.Controls
        If ctl.ControlType = acTextBox Then
            AutoFontSize ctl
        End If
    Next ctl
End Sub

' ============================================
' 核心测量函数
' ============================================

' 函数说明: 测量指定文本在给定字号下的渲染宽度
'           使用 GDI Unicode API，中文宽度准确
Private Function TextWidthTwips(ByVal sText As String, _
                                ByVal sFontName As String, _
                                ByVal dFontSize As Double, _
                                ByVal bBold As Boolean, _
                                ByVal bItalic As Boolean) As Long
    On Error GoTo Fail

    Dim hDC      As LongPtr
    Dim hFont    As LongPtr
    Dim hOldFont As LongPtr
    Dim lf       As LOGFONT
    Dim sz       As SIZE
    Dim dpiY     As Long

    TextWidthTwips = 0

    hDC = GetDC(0)
    If hDC = 0 Then Exit Function

    dpiY = GetDeviceCaps(hDC, LOGPIXELSY)

    ' 构建字体：传入的字号是多少磅，就按多少磅建 GDI 字体
    lf.lfHeight = -MulDiv(CLng(dFontSize), dpiY, 72)
    lf.lfWidth = 0
    lf.lfWeight = IIf(bBold, FW_BOLD, FW_NORMAL)
    lf.lfItalic = IIf(bItalic, 1, 0)
    lf.lfCharSet = 1
    lf.lfFaceName = sFontName & vbNullChar

    hFont = CreateFontIndirectW(lf)
    If hFont = 0 Then GoTo Cleanup

    hOldFont = SelectObject(hDC, hFont)

    ' 关键：StrPtr 传 Unicode 指针，中文宽度不失真
    GetTextExtentPoint32W hDC, StrPtr(sText), Len(sText), sz

    SelectObject hDC, hOldFont

    ' 像素 → 缇
    TextWidthTwips = MulDiv(sz.cx, 1440, dpiY)

Cleanup:
    If hFont <> 0 Then DeleteObject hFont
    ReleaseDC 0, hDC
    Exit Function

Fail:
    TextWidthTwips = 0
    Resume Cleanup
End Function


3
第二步：在窗体/报表中调用

窗体场景

' 加载记录时自动适配Private Sub Form_Current()    AutoFontSize Me.txtProductName    AutoFontSize Me.txtSpecEnd Sub

报表场景

报表的文本框自适应要在 Detail_Format 事件中调用，因为报表每行数据在格式化时才会赋值：


' 报表每行格式化时触发Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)    AutoFontSize Me.txtProductName, 6    AutoFontSize Me.txtSpec, 6End Sub


也可以批量处理：

Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)    AutoFontSizeAll MeEnd Sub

运行效果


1.png


4
第三步：效果对比

假设文本框宽度 2880 缇（2 英寸），默认 11pt 等线字体：

内容11pt 宽度适配结果
「螺栓」≈ 400 缇保持 11pt（已经装得下）
「M12×60 不锈钢六角螺栓」≈ 2800 缇保持 11pt（刚好）
「M12×60 不锈钢六角螺栓（全螺纹）」≈ 3400 缇缩到 9pt
「M12×60 304 不锈钢六角螺栓全螺纹带螺母平垫」≈ 4500 缇缩到 7pt

短内容保持原字号不缩，长内容逐级缩小直到装下——每一条记录都找到刚好够用的字号。

为什么逐级降而不是二分查找？

两种方案对比：

方案测量次数优点缺点
逐级降（每次减 1pt）最多约 10 次代码简单，结果稳定极长文本多量几次
二分查找约 4-5 次快逻辑复杂，边界条件多

实际场景中，文本框宽度通常是设计好的合理值，大多数内容在当前字号下就能显示，只有少数超长记录需要缩一两磅。逐级降的方案够用且不易出错。

如果数据里大量内容需要从 20 pt 缩到 6 pt，可以改为二分查找减少测量次数。但在常规报表场景中不需要。

注意点

  1. 报表里一定要用 Detail_Format 事件，不是 Detail_Print。 Format 在数据绑定后、分页计算前触发，此时修改字号 Access 会重新计算布局；Print 只是渲染阶段，改了不生效。

  2. 最小字号不要设太低。 默认 6pt 是打印可读的底线。如果 6pt 还装不下，应该调整的是列宽或数据截断策略，而不是继续缩。

  3. 字号是离散值。 FontSize 属性接受小数，但逐级减 1pt 的整数步进在视觉上更统一。如果需要 0.5pt 精度，把 dFontSize = dFontSize - 1 改成 dFontSize = dFontSize - 0.5 即可。

  4. 报表里字号缩小后，行高不会自动变。 如果原行高是按 11pt 设计的，缩到 7pt 后文字上方会显得空旷。可以在 Detail_Format 中同步调整 Detail.Height，或保持统一行高接受留白。

  5. 换行符不处理。 本文只针对单行内容做字号自适应。如果文本框 EnterKeyBehavior = True 且内容含换行符，TextWidthTwips 测量的是最长那一行的宽度，配合多行高度自适应需要额外处理，不在本文范围内。

5
总结

本文实现了一个文本框字号自适应模块，代码不到 100 行，核心思路：

  1. 固定文本框宽度，用 GDI Unicode API 测量文本在不同字号下的渲染宽度。

  2. 从当前字号逐级递减，找到刚好能完整显示内容的最大字号。

  3. 设置 txt.FontSize，控件尺寸不变，内容自动适应。

一行 AutoFontSize Me.txtXXX 就能让报表里的长文本自动缩小，不被截断，也不用放大列宽。

测试环境：Access 2010 及以上版本，Windows 7/10/11。


社区版 Access 开发框架已开放下载。 关注公众号或添加微信 Access开发 即可获取，欢迎下载测试。


如果你的团队正在用 Access，或者计划用 Access 搭建业务系统，我们可以提供从培训到落地的全流程支持：

📚 技术培训

  • Access VBA 从入门到精通（线上/线下均可）

  • Access + SQL Server 企业级开发实战

  • Access 系统性能优化与架构设计

  • AI + Access 融合开发专题培训

💼 定制开发

  • 企业 ERP / CRM / 进销存 / WMS / MES 等系统开发

  • 旧 Access 系统升级、性能优化与架构重构

  • AI 能力集成到现有 Access 业务系统

🔧 技术支持

  • 代码审查与重构建议

  • 疑难问题远程诊断

  • 一对一技术辅导

无论是想让团队快速上手 Access 开发，还是需要把现有系统接上 AI，都可以直接联系我们聊聊方案。

联系方式：




标签
access开发 access数据库 access vba vba开发 定制系统开发 系统开发 ERP MRP CRM MES OA 进销存 Excel office office2024 word PPT SQL sql SQL Server MySQL 条码 AI DeepSeek AI 批量修改 字段名 文件浏览器 互联网 开发技巧 字段类型 技术服务 Excel 图表