Innholdsfortegnelse
Makroene nedenfor viser en liste over alle installerte fonter. Merk! Hvis du har mange fonter installert,
Makroen kan slutte å svare på grunn av mangel på tilgjengelig minne.
Sub ShowInstalledFonts () Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer Dim stdFont As String fontSize = 0 fontSize = InputBox ("Enter Sample Font Size Between 8 Og 30 ", _" Select Sample Font Size ", 12) If fontSize = 0 Exit Sub If fontSize 30 Then fontSize = 30 Set FontNamesCtrl = Application.CommandBars (" Formatting "). FindControl (ID: = 1728) 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.L. Add stdFont = ActiveDocument.Paragraphs (1) .Range.Font.Name 'add heading With ActiveDocument.Paragraphs (1) .Range .Text = "Installed fonts:" End With LS 2' list font names and font example on every other line For i = 0 Til FontNamesCtrl.ListCount - 1 fontName = FontName sCtrl.List (i + 1) Hvis i Mod 5 = 0 Deretter Application.StatusBar = "Listing font" & _ Format (i / (fontCount - 1), "0 %") & "" & _ fontName & "…" Med ActiveDocument.Paragraphs (ActiveDocument.Paragraphs.Count) .Range .Text = fontName .Font.Name = stdFont Slutt med LS 1 tFormula = "abcdefghijklmnopqrstuvwxyz" If Application.International (wdProductLanguageID) = 47 ThenFFormula = "æåFormula" If tFormula = tFormula & UCase (tFormula) tFormula = tFormula & "1234567890" With ActiveDocument.Paragraphs (ActiveDocument.Paragraphs.Count) .Range .Text = tFormula .Font.Name = fontName End with LS 2 Next i ActiveDocument.Content.Font .Size = fontSize Application.StatusBar = False If Not FontCmdBar Is Nothing Then FontCmdBar.Delete Set FontCmdBar = Nothing Set FontNamesCtrl = Nothing ActiveDocument.Saved = True Application.ScreenUpdating = True Application.ScreenRefresh End Sub Private Sub LS (lCount As Integer) ' legger til lTell nye avsnitt (er) på slutten av dokumentet Dim i As Integer With ActiveDo cument.Content For i = 1 To lCount .InsertParagraphAfter Next i End with End Sub
