VBA用户窗体动态生成TextBox字体大小不一致问题求助

问题原因 #

这个现象是VBA UserForm动态创建控件时的字体渲染兼容性问题，具体原因如下：

• 当设置的字体大小（如11号）无法被系统字体引擎映射为整数像素时（受系统DPI缩放、默认字体设置影响），部分TextBox会自动 fallback 到系统默认字体尺寸，导致显示不一致。
• 10、14号属于系统字体引擎能稳定识别的标准尺寸，因此所有控件显示效果统一。
• 另外你代码里有个拼写错误：Text = tB_X.Font.Size中的tB_X应为tb_X，虽不直接引发字体问题，但会导致运行错误（若未关闭错误提示），建议修正。

解决方案 #

1. 明确指定字体类型 #

在设置字体大小前，先指定系统已安装的字体名称，避免系统自动选择不同字体（不同字体的同号字渲染尺寸可能存在差异）：

Private Sub CreateBoxes()
    Dim lastRow As Long ' 修正变量类型：行数应为Long而非String
    Dim tb_X As MSForms.TextBox
    Dim TopPos As Integer

    lastRow = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
    
    TopPos = -15
    For i = 1 To lastRow
        If Sheets("Data").Range("C" & i).Value = "Booking" Then
            Set tb_X = Frame6.Controls.Add("Forms.TextBox.1", "tb_" & i, True)
            TopPos = TopPos + 15
            With tb_X
                .Height = 18 ' 调整高度适配11号字
                .Width = 190
                .SpecialEffect = fmSpecialEffectFlat
                .Left = 5
                .Top = TopPos
                .Font.Name = "微软雅黑" ' 或Arial等系统已安装字体
                .Font.Size = 11
                .Text = tb_X.Font.Size ' 修正拼写错误
            End With
        End If
    Next
End Sub

2. 禁用UserForm自动缩放 #

若UserForm的AutoScaleMode设为fmAutoScaleModeFont，可能导致动态控件的字体缩放不一致，可在初始化事件中关闭自动缩放：

Private Sub UserForm_Initialize()
    Me.AutoScaleMode = fmAutoScaleModeNone
    CreateBoxes
End Sub

3. 用API强制设置字体像素尺寸（进阶方案） #

如果上述方法无效，可通过Windows API绕过系统字体映射，直接设置字体的像素尺寸：

' 模块顶部声明API函数
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal Wt As Long, ByVal It As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal Fnm As String) As Long
Private Const WM_SETFONT = &H30
Private Const FW_NORMAL = 400
Private Const DEFAULT_CHARSET = 1
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const FF_DONTCARE = 0

Private Sub CreateBoxes()
    Dim lastRow As Long
    Dim tb_X As MSForms.TextBox
    Dim TopPos As Integer
    Dim hFont As Long
    
    lastRow = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
    ' 创建96DPI下的11号字体（DPI不同需调整：11*DPI值/72）
    hFont = CreateFont(0, 11 * 96 / 72, 0, 0, FW_NORMAL, False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_DONTCARE, "微软雅黑")
    
    TopPos = -15
    For i = 1 To lastRow
        If Sheets("Data").Range("C" & i).Value = "Booking" Then
            Set tb_X = Frame6.Controls.Add("Forms.TextBox.1", "tb_" & i, True)
            TopPos = TopPos + 15
            With tb_X
                .Height = 18
                .Width = 190
                .SpecialEffect = fmSpecialEffectFlat
                .Left = 5
                .Top = TopPos
                .Text = "测试文本"
            End With
            ' 用API绑定字体
            SendMessage tb_X.hwnd, WM_SETFONT, hFont, True
        End If
    Next
End Sub

额外建议 #

• 动态创建TextBox时，可直接通过.BackColor = RGB(255,255,200)设置背景色，满足自定义需求；
• 变量lastRow需设为Long类型，避免行数超过32767时出现溢出错误。

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