✔ Programação GLOBAL®: VBA Excel - Liste todas as Fontes instaladas no MS Excel - Display all installed fonts using VBA in Microsoft Excel

VBA Excel - Liste todas as Fontes instaladas no MS Excel - Display all installed fonts using VBA in Microsoft Excel

DESENVOLVO APLICAÇÕES VBA

Perguntas, Questões e Esclarecimentos

O que é o fenômeno chamado BIG DATA?

Acesse uma ENORME lista de Dashboards e Infográficos

Aprenda a detectar gráficos que precisam mudar

Dados ou Informações?

Dashboards - 8 Importantes características desejáveis

Dashboards e Infocharts - Diversas Visualizações de Dados

Diversos exemplos de Gráficos

Excel - DashMap - Mapa do Brasil

Key Performance Indicators - 7 Características desejáveis

MIS - Usufruindo a excelência na análise das suas Informações

O Melhor do Business Intelligence

Os 10 mandamentos do gerenciamento de projetos

Receba 3 Calendários Customizáveis de 2013 em Excel

Usando Gauges em Dashboards no MS Access

Sim, é possível listar todas as fontes que estiverem instaladas no seu computador. Como?

Use o código abaixo:

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