Anzeige aller installierten Schriftarten (Word) mit VBA in Microsoft Excel

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