Views

Histats

Vitrine

VBA Excel - Mostra todas as fontes disponíveis para o MS Excel - Display all installed fonts

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 


LinkWithinBrazilVBAExcelSpecialist

Related Posts Plugin for WordPress, Blogger...