Makroen herunder viser en liste over alle installerede skrifttyper. Bemærk! Hvis du har mange skrifttyper installeret,
makroen kan stoppe med at reagere på grund af mangel på tilgængelig hukommelse. Hvis dette sker, kan du prøve
prøve til Word senere i dette dokument.
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 Skriftstørrelse mellem 8 og 30 ", _" Vælg prøve skrifttype ", 12,,,,, 1) If fontSize = 0 Exit Sub If fontSize 30 Then fontSize = 30 Set FontNamesCtrl = Application.CommandBars (" Formatting "). FindControl (ID: = 1728) 'Hvis skrifttypekontrol mangler, skal du oprette en midlertidig kommandolinje Hvis FontNamesCtrl ikke er noget, så indstil FontCmdBar = Application.CommandBars.Add ("TempFontNamesCtrl", _ msoBarFloating, False, True) Angiv FontNamesCtrl = FontCmdBar.Controls. Tilføj (ID: = 1728) End If Application.ScreenUpdating = False fontCount = FontNamesCtrl.ListCount Workbooks.Add 'list fontnavne i kolonne A og skrifttypeeksempel i kolonne B For i = 0 Til FontNamesCtrl.ListCount - 1 fontName = FontNamesCtrl.List (i + 1) Application.StatusBar = "Listing font" & _ Format (i / (fontCount - 1), "0 %") & "" & _ fontName & "…" Celler (i + StartRow, 1) .Formula = fontName Med celler (i + StartRow, 2) tFormula = " abcdefghijklmnopqrstuvwxyz "If Application.International (xlCountrySetting) = 47 Herefter tFormula = tFormula &" æøå "End If tFormula = tFormula & UCase (tFormula) tFormula = tFormula &" 1234567890 ".Formula = TFormula. Application.StatusBar = False If Not FontCmdBar Is Nothing Then FontCmdBar.Delete Set FontCmdBar = Nothing Set FontNamesCtrl = Nothing 'tilføj overskrift Kolonner (1) .AutoFit With Range ("A1") .Formula = "Installerede skrifttyper:" .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 = " Skrifteksempel: ".Font.Bold = True .Font.Size = 12 Slut med område (" B "& StartRow &": B "& _ StartRow + fontCount) .Font.Size = fontSize Slut med område (" A "& StartRow &": B "& _ StartRow + fontCount) .VerticalAlignment = xlVAl ignCenter End With Range ("A4"). Vælg ActiveWindow.FreezePanes = True Range ("A2"). Vælg ActiveWorkbook.Saved = True End Sub