显示在Excel中使用VBA所有已安装的字体（字）
下面的宏将显示所有已安装字体的列表。注意！如果您安装了许多字体，则宏可能由于缺少可用内存而停止响应。
Sub ShowInstalledFonts()
Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String
Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer
Dim stdFont As String
fontSize = 0
fontSize = InputBox("Enter Sample Font Size Between 8 And 30", _
"Select Sample Font Size", 12)
If fontSize = 0 Then Exit Sub
If fontSize < 8 Then fontSize = 8
If fontSize > 30 Then fontSize = 30
Set FontNamesCtrl = Application.CommandBars("Formatting").FindControl(ID:=1728)
If FontNamesCtrl Is Nothing Then
Set FontCmdBar = Application.CommandBars.Add("TempFontNamesCtrl", _
msoBarFloating, False, True)
Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728)
End If
Application.ScreenUpdating = False
fontCount = FontNamesCtrl.ListCount
Documents.Add
stdFont = ActiveDocument.Paragraphs(1).Range.Font.Name
' add heading
With ActiveDocument.Paragraphs(1).Range
.Text = "Installed fonts:"
End With
LS 2
' list font names and font example on every other line
For i = 0 To FontNamesCtrl.ListCount - 1
fontName = FontNamesCtrl.List(i + 1)
If i Mod 5 = 0 Then Application.StatusBar = "Listing font " & _
Format(i / (fontCount - 1), "0 %") & " " & _
fontName & "..."
With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range
.Text = fontName
.Font.Name = stdFont
End With
LS 1
tFormula = "abcdefghijklmnopqrstuvwxyz"
If Application.International(wdProductLanguageID) = 47 Then
tFormula = tFormula & "æøå"
End If
tFormula = tFormula & UCase(tFormula)
tFormula = tFormula & "1234567890"
With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range
.Text = tFormula
.Font.Name = fontName
End With
LS 2
Next i
ActiveDocument.Content.Font.Size = fontSize
Application.StatusBar = False
If Not FontCmdBar Is Nothing Then FontCmdBar.Delete
Set FontCmdBar = Nothing
Set FontNamesCtrl = Nothing
ActiveDocument.Saved = True
Application.ScreenUpdating = True
Application.ScreenRefresh
End Sub
Private Sub LS(lCount As Integer)
' adds lCount new paragraph(s) at the end of the document
Dim i As Integer
With ActiveDocument.Content
For i = 1 To lCount
.InsertParagraphAfter
Next i
End With
End Sub