Visual Basic for Applications/字体实用程序

摘要

• 此页面列出了主要与字体相关的 VBA 过程。 也就是说，VBA 如何处理字体。
• 函数 GetTextPoints() 查找文本的宽度（以磅为单位）。 用户窗体上的标签在加载字符串时会扩展。然后从控件中读取宽度。用户窗体及其内容已加载但未显示。尽管看似缺乏优雅，但这种方法可能是获取文本合适宽度的最简单方法，适用于任何字体的变化。该函数在对复杂布局（如文本框内的表格）中的控件进行精确大小调整时很有用。
• 过程 ListAllExcelFonts() 在工作表上列出 Excel 的字体。 它使用了 GetTextPoints()。在列出字体是否为等宽字体时，它还会在每个字体中生成一个示例文本。它还会列出每个字体中示例文本的宽度（以磅为单位）。对这些宽度数字进行标准化可能更有用，但尚不清楚哪种字体最适合代表标准。一如既往，有见地的评论将很有用。
• 过程 FontExists() 测试字体是否存在。 如果参数字体名存在，则在函数名中返回 true，否则返回 false。运行 testit() 以尝试该函数。

字体测试

函数 GetTextPoints() 可用于确定字体是否为等宽字体。虽然乍一看似乎适合确定是否存在字距调整，但用于测量文本宽度的用户窗体控件在任何情况下都不会对应用于它的文本进行字距调整。因此，将始终发现不存在字距调整。这些测试（无论是在视觉模式下使用还是在自动模式下使用）都比较所选字符串的长度。如果下面第一对字符串的长度相同，则字体为等宽字体。在其他情况下，如果应用了字距调整，则第二对字符串的长度将不同。

等宽字体测试字符串
IIIIIIIIII
HHHHHHHHHH

字距调整测试字符串：仅供完整性
AAAAATTTTT
ATATATATAT

代码模块

修订

Sub TestGetTextPoints()
    'Run this to obtain the points width of text
    
    ' Get the net width in points for the string
    MsgBox GetTextPoints("The quick brown fox jumps over the lazy dog", "Consolas", 12, 0, 0) & _
                         " points width"
End Sub

Function GetTextPoints(sIn As String, sFontName As String, _
    nFontSize As Single, bFontBold As Boolean, _
    bFontItalic As Boolean) As Long
    'GetTextPoints returns points width of text.
    'When setting a control width, add two additional
    'space widths to these values to avoid end clipping.
    'Needs a user form called CountPoints. Form
    'is loaded and unloaded but never shown.
        
    'Monospace test: could be used here to identify monospaced fonts
    'If pair is same width then monospaced
    'IIIIIIIIII
    'HHHHHHHHHH
    
    'Kerning test pair used by printers: Wont work here since there is no kerning in userform controls.   
    'If pair are different width then there is kerning.
    'AAAAATTTTT
    'ATATATATAT

    Dim oLbl As Control
    
    Load CountPoints
    Set oLbl = CountPoints.Controls.Add("Forms.Label.1", "oLbl")

    'format the label with same fonts as sIn
    With oLbl
        .Width = 0
        .WordWrap = False
        .Visible = False
        .AutoSize = True
        .Caption = ""
        .font.SIZE = nFontSize
        .font.Name = sFontName
        .font.Bold = bFontBold
        .font.Italic = bFontItalic
    End With

    'get points for sIn
    oLbl.Caption = sIn
    GetTextPoints = oLbl.Width

    Unload CountPoints

End Function

Sub ListAllExcelFonts()
    'Lists Excel fonts as monospaced or proportional
    'with a sample of text and its width in points
    'calls GetTextPoints to measure test strings
    'needs use of Sheet1 - clears all existing
    
    Dim FontList, sht As Worksheet, i As Long
    Dim sM1 As String, sM2 As String, sFN As String
    Dim sTest As String, nSize As Single
    Dim bBold As Boolean, bItalic As Boolean
    
    'monospaced test strings
    sM1 = "IIIIIIIIII"
    sM2 = "MMMMMMMMMM"
    
    'set a suitable test string here
    sTest = "The quick brown fox jumps over the lazy dog 1234567890"
    
    'set test parameters
    nSize = 10 'ten point for all tests
    bBold = False
    bItalic = False
    
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    With sht
        .Activate
        .Range("A1:Z65536").ClearContents
        .Range("A1:Z65536").ClearFormats
    End With
    
    'get reference to the font list
    Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
    
    On Error Resume Next
    'work loop
    For i = 1 To FontList.ListCount
        
        sFN = FontList.List(i) 'font name
        
        'print general data to sheet
        With sht
            .Cells(i, 1) = sFN                                              'name
            .Cells(i, 3) = GetTextPoints(sTest, sFN, nSize, bBold, bItalic) 'test string pts width
        End With
        
        'set fonts for sample cell
        With sht.Cells(i, 4).font
            .Name = sFN
            .SIZE = nSize
            .Italic = bItalic
            .Bold = bBold
        End With
        
        'sample string to sheet
        sht.Cells(i, 4) = sTest
        
        'monospaced  test - true if both test strings equal in length
        If GetTextPoints(sM1, sFN, nSize, bBold, bItalic) = GetTextPoints(sM2, sFN, nSize, bBold, bItalic) Then
            'the test font is monospaced
            sht.Cells(i, 2) = "Monospaced"  'mono or prop
        Else
            sht.Cells(i, 2) = "Proportional"
        End If
    Next i
        
    With sht
        .Columns.AutoFit
        .Cells(1, 1).Select
    End With

End Sub

Private Sub testit()
    ' Find whether or not a font exists
    Dim sFontName As String
    
    sFontName = "Consolas"
    
    If FontExists(sFontName) Then
        MsgBox sFontName & " exists"
    Else
        MsgBox sFontName & " does not exist"
    End If

End Sub

Public Function FontExists(FontName As String) As Boolean
    ' Returns true in function name
    ' if parameter font name exists
    
    Dim oFont As New StdFont
    
    oFont.Name = FontName
    If StrComp(FontName, oFont.Name, vbTextCompare) = 0 Then
        FontExists = True
    End If
    
End Function