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 = 4Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As StringDim fontName As String, i As Long, fontCount As Long, fontSize As IntegerfontSize = 0fontSize = Application.InputBox("Enter Sample Font Size Between 8 And 30", _"Select Sample Font Size", 12, , , , , 1)If fontSize = 0 Then Exit SubIf fontSize < 8 Then fontSize = 8If fontSize > 30 Then fontSize = 30Set FontNamesCtrl = Application.CommandBars("Formatting").FindControl(ID:=1728)' If Font control is missing, create a temp CommandBarIf FontNamesCtrl Is Nothing ThenSet FontCmdBar = Application.CommandBars.Add("TempFontNamesCtrl", _msoBarFloating, False, True)Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728)End IfApplication.ScreenUpdating = FalsefontCount = FontNamesCtrl.ListCountWorkbooks.Add' list font names in column A and font example in column BFor i = 0 To FontNamesCtrl.ListCount - 1fontName = FontNamesCtrl.List(i + 1)Application.StatusBar = "Listing font " & _Format(i / (fontCount - 1), "0 %") & " " & _fontName & "..."Cells(i + StartRow, 1).Formula = fontNameWith Cells(i + StartRow, 2)tFormula = "abcdefghijklmnopqrstuvwxyz"If Application.International(xlCountrySetting) = 47 ThentFormula = tFormula & "æøå"End IftFormula = tFormula & UCase(tFormula)tFormula = tFormula & "1234567890".Formula = tFormula.Font.Name = fontNameEnd WithNext iApplication.StatusBar = FalseIf Not FontCmdBar Is Nothing Then FontCmdBar.DeleteSet FontCmdBar = NothingSet FontNamesCtrl = Nothing' add headingColumns(1).AutoFitWith Range("A1").Formula = "Installed fonts:".Font.Bold = True.Font.Size = 14End WithWith Range("A3").Formula = "Font Name:".Font.Bold = True.Font.Size = 12End WithWith Range("B3").Formula = "Font Example:".Font.Bold = True.Font.Size = 12End WithWith Range("B" & StartRow & ":B" & _StartRow + fontCount).Font.Size = fontSizeEnd WithWith Range("A" & StartRow & ":B" & _StartRow + fontCount).VerticalAlignment = xlVAlignCenterEnd WithRange("A4").SelectActiveWindow.FreezePanes = TrueRange("A2").SelectActiveWorkbook.Saved = TrueEnd Sub
Tags: VBA, Tips, Excel, Font, Fontes, install, instaladas
Nenhum comentário:
Postar um comentário