Quantas fontes estão disponíveis para serem utilizadas ? Descubra.
Sub ShowInstalledFonts()
Const StartRow As Integer = 4
Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String
Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer
fontSize = 0
fontSize = Application.InputBox("Enter Sample Font Size Between 8 And 30", _
"Select Sample Font Size", 12, , , , , 1)
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 Font control is missing, create a temp CommandBar
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
Workbooks.Add
' list font names in column A and font example in column B
For i = 0 To FontNamesCtrl.ListCount - 1
fontName = FontNamesCtrl.List(i + 1)
Application.StatusBar = "Listing font " & _
Format(i / (fontCount - 1), "0 %") & " " & _
fontName & "..."
Cells(i + StartRow, 1).Formula = fontName
With Cells(i + StartRow, 2)
tFormula = "abcdefghijklmnopqrstuvwxyz"
If Application.International(xlCountrySetting) = 47 Then
tFormula = tFormula & "æøå"
End If
tFormula = tFormula & UCase(tFormula)
tFormula = tFormula & "1234567890"
.Formula = tFormula
.Font.Name = fontName
End With
Next i
Application.StatusBar = False
If Not FontCmdBar Is Nothing Then FontCmdBar.Delete
Set FontCmdBar = Nothing
Set FontNamesCtrl = Nothing
' add heading
Columns(1).AutoFit
With Range("A1")
.Formula = "Installed fonts:"
.Font.Bold = True
.Font.Size = 14
End With
With Range("A3")
.Formula = "Font Name:"
.Font.Bold = True
.Font.Size = 12
End With
With Range("B3")
.Formula = "Font Example:"
.Font.Bold = True
.Font.Size = 12
End With
With Range("B" & StartRow & ":B" & _
StartRow + fontCount)
.Font.Size = fontSize
End With
With Range("A" & StartRow & ":B" & _
StartRow + fontCount)
.VerticalAlignment = xlVAlignCenter
End With
Range("A4").Select
ActiveWindow.FreezePanes = True
Range("A2").Select
ActiveWorkbook.Saved = True
End Sub
Tags: Bernardes, MS, Microsoft, Office, Excel, show, fonts,
André Luiz Bernardes
A&A® - Work smart, not hard in any place.
Skype: inanyplace
