在MS Word中打印字体的所有字符

Question

对于某些自动化测试，我需要创建一个Word Doc，其中包含字体的所有字符（适用于几种不同的字体）。有没有一种简单的方法来创建一个宏，该宏循环遍历字体中的所有可用字符（并将它们插入文档中）？

Answer 1

天哪...我很久以前就做过类似的东西...是的，这是可能做到的。

MSDN是一个好的开始

编辑添加：

我知道我以前也做过类似的事情。通过查看我的一些旧电子邮件，我发现了一个我发送给我的朋友的宏，其中包含这个内容。这里是：

Sub GenerateFontCatalog()
'
' Macro created in 05/14/2008 by Paulo Santos
'
Dim i As Long
Dim j As Long
Dim fnt As String
Dim doc As Document
Dim fnts() As String

'*
'* Get all font names
'*
Word.StatusBar = "Reading Font Names..."
ReDim fnts(Word.FontNames.Count)
For i = 1 To Word.FontNames.Count
    fnts(i) = Word.FontNames.Item(i)
    DoEvents
Next

'*
'* Sort alphabetically
'*
Word.StatusBar = "Sorting Font Names..."
For i = 1 To UBound(fnts)
    For j = i + 1 To UBound(fnts)
        If (fnts(i) > fnts(j)) Then
            fnt = fnts(i)
            fnts(i) = fnts(j)
            fnts(j) = fnt
        End If
    Next
    DoEvents
Next

Word.StatusBar = "Generating Font Catalog..."

Set doc = Application.Documents.Add()
doc.Activate

'*
'* Page configuration
'*
With ActiveDocument.PageSetup
    .Orientation = wdOrientPortrait
    .TopMargin = CentimetersToPoints(2)
    .BottomMargin = CentimetersToPoints(2)
    .LeftMargin = CentimetersToPoints(2)
    .RightMargin = CentimetersToPoints(2)
End With

For i = 1 To UBound(fnts)
    '*
    '* Write font name
    '*
    Selection.Font.Name = "Arial"
    Selection.Font.Size = 10
    If (i > 1) Then
        Selection.TypeParagraph
        Selection.ParagraphFormat.KeepTogether = False
        Selection.ParagraphFormat.KeepWithNext = False
        Selection.TypeParagraph
    End If
    Selection.TypeText fnts(i)
    Selection.ParagraphFormat.KeepWithNext = True
    Selection.TypeParagraph

    '*
    '* Write font sample
    '*
    Selection.Font.Name = fnts(i)
    Selection.Font.Size = 16
    Selection.TypeText "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & Chr(11)
    Selection.TypeText "abcdefghijklmnopqrstuvwxyz" & Chr(11)
    Selection.TypeText "0123456789"
    Selection.ParagraphFormat.KeepTogether = True

    DoEvents
Next

'*
'* Adjust cursor position
'*
Selection.HomeKey Unit:=wdStory
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveUp Unit:=wdLine, Count:=1

Word.StatusBar = "Generating Font Index..."
For i = 1 To UBound(fnts)
    Selection.Font.Name = "Arial"
    Selection.Font.Size = 10
    Selection.TypeText fnts(i) & vbTab
    Selection.Font.Name = fnts(i)
    Selection.TypeText "ABC abc 123"
    Selection.TypeParagraph
Next

'*
'* Split the document in two columns
'*
With Selection.Sections(1).PageSetup.TextColumns
    .SetCount NumColumns:=2
    .EvenlySpaced = True
    .LineBetween = False
End With
Selection.HomeKey Unit:=wdStory, Extend:=True
Selection.ParagraphFormat.TabStops.Add Position:=Selection.Sections(1).PageSetup.TextColumns(1).Width, Alignment:=wdAlignTabRight, Leader:=wdTabLeaderSpaces

Selection.HomeKey Unit:=wdStory
Word.StatusBar = ""

End Sub