Visual Basic for Applications/Font Utilities

Summary This page lists VBA procedures that are mainly to do with fonts. That is to say, how VBA handles fonts. The function GetTextPoints() finds the width of text in points. A label on a userform extends when loaded with the string. The width is then read from the control. The userform and its contents are loaded but never shown. Despite its seeming lack of elegance, this method is perhaps the simplest way of getting the fitting width for text, correct for any variation in the font. The function is useful in the precise sizing of controls for complex layouts, such as tables within text boxes. The procedure ListAllExcelFonts() lists Excel's fonts on a worksheet. It makes use of GetTextPoints(). While listing whether or not the font is monospaced, it also makes a sample of test text in each font. It also lists the width in points for the sample text in each font. Normalizing these width figures might be more useful but it is unclear as to which font is best to represent the standard. As ever, informed comments would be useful. The procedure FontExists() tests whether or not a font exists. It returns true in the function name if the parameter font name exists, otherwise it returns false. Run testit() to try the function. Font Tests The function GetTextPoints() can be used to determine whether or not a font is monospaced. Although at first sight it would appear suitable for determining the presence of kerning, the userform control used to measure the width of text does not kern the text applied to it in any case. As such, kerning will always be found to be absent. The tests, whether used visually or in an automated mode, compare the lengths of selected strings. If the strings of the first pair below are the same length, then the font is monospaced. Elsewhere, if kerning had been applied, then the strings of the second pair would be different in length. Monospace test strings: IIIIIIIIII HHHHHHHHHH Kerning test strings: for completeness only. AAAAATTTTT ATATATATAT Code Module Notes Code Module Revisions 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 See Also External Links