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