Vis installerte fonter (Word)

Ved hjelp av makroene nedenfor kan du lage en oversikt med skriftprøve over de installerte fontene på maskinen din.
NB! Dersom du har mange fonter installert kan du risikere at makroen slutter å virke p.g.a. lite tilgjengelig minne.

Sub VisInstallerteSkrifter()
Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar
Dim tFormula As String
Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer
Dim stdFont As String
    fontSize = 0
    fontSize = InputBox("Angi størrelsen på eksempelfonten (mellom 8 og 30)", _
        "Velg eksempelfont støttelse", 12)
    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 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
    Documents.Add
    stdFont = ActiveDocument.Paragraphs(1).Range.Font.Name
    ' legg til overskrift
    With ActiveDocument.Paragraphs(1).Range
        .Text = "Installerte fonter:"
    End With
    LS 2
    ' vis font navn og font eksempel på annenhver linje
    For i = 0 To FontNamesCtrl.ListCount - 1
        fontName = FontNamesCtrl.List(i + 1)
        If i Mod 5 = 0 Then Application.StatusBar = "Lister font " & _
            Format(i / (fontCount - 1), "0 %") & " " & fontName & "..."
        With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range
            .Text = fontName
            .Font.Name = stdFont
        End With
        LS 1
        tFormula = "abcdefghijklmnopqrstuvwxyzæøå"
        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 lCount nye avsnitt på slutten av dokumentet
Dim i As Integer
    With ActiveDocument.Content
        For i = 1 To lCount
            .InsertParagraphAfter
        Next i
    End With
End Sub

Dokumentet er sist oppdatert 2000-04-15 12:34:47 Utskriftsvennlig versjon