Hiển thị tất cả các phông chữ đã cài đặt (Word) bằng VBA trong 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