Tipp 0367 Schriftarten auflisten
Autor/Einsender:
Datum:
  Angie
13.11.2003
Entwicklungsumgebung:   Word 97
Das FontNames-Objekt stellt eine Liste der in Word zur Verfügung stehenden Schriftarten dar. In folgendem Beispiel werden alle Schriftartnamen im FontNames-Objekt in einem neuen Dokument aufgelistet.
 
Public Sub ListFontsInApp()
  Dim strMsg   As String
  Dim fnt      As Variant
  Dim wdDocNew As Document

  strMsg = "Liste der in Word zur Verfügung stehenden "
  strMsg = strMsg & "Schriftarten" & vbCrLf
  strMsg = strMsg & "(" & Application.FontNames.Count
  strMsg = strMsg & " Schriftarten verfügbar):" & vbCrLf

  For Each fnt In Application.FontNames
    strMsg = strMsg & vbCrLf & fnt
  Next

  Set wdDocNew = Application.Documents.Add
  With wdDocNew
    .Range.Text = strMsg
    .UserControl = True
  End With
  Set wdDocNew = Nothing
End Sub
 
Verwendete Schriftarten im Dokument auflisten
Wird anhand der Liste der in Word zur Verfügung stehenden Schriftarten in Verbindung mit der Find-Methode überprüft, welche Schriftarten in einem Word-Dokument verwendet werden, so werden Schriftarten, die zwar im Dokument aber nicht in der Auflistung aufgeführt sind, nicht erfasst. Dies kann beispielsweise dann der Fall sein, wenn Dokumente auf andere Rechner übertragen werden, die weniger oder andere Schriftarten installiert haben, als der Rechner auf dem das Dokument erstellt wurde.
So ist es möglich mit dem FontNames-Objekt nicht nur aufzulisten, welche Schriftarten zur Verfügung stehen, sondern um auch, nach Ermittlung der im Dokument verwendeten Schriftarten, einen Vergleich durchzuführen, welche Schriftarten im Dokument verwendet werden, die nicht in der aktuellen Word-Version zur Verfügung stehen.
Um die einem Word-Dokument verwendeten Schriftarten ermitteln zu können, müssen alle Dokumentkomponenten (Haupttext, Kopf-/ und Fußzeilen, Textfelder und Kommentare usw.) durchsucht werden. Dabei wird zunächst der gesamte übergebene Bereich überprüft. Werden in diesem Bereich (StoryRange/Range) verschiedene Schriftarten verwendet, ist bereich.Font.Name = "" bzw. die Länge des zurückgegebenen Schriftnamens gleich 0, andernfalls wird der Schriftname zurückgegeben. Wenn also verschiedene Schriftarten im Bereich verwendet werden, muss der zu überprüfende Bereich immer weiter "verkleinert" werden, ggf. bis hin zu einem einzelnen Zeichen.
Beispiel:
-> Bereich - Haupttext, Fußnotentext, Kommentare, Kopf-/Fußzeilen usw.
   (StoryRange-Objekt)
   -> Absätze im Bereich (Paragraphs-Objekt)
      -> Sätze in den Absätzen (Sentences-Objekt)
          -> Wörter in den Sätzen (Words-Objekt)
             -> Zeichen in den Wörtern (Characters-Objekt)
In folgendem Beispiel werden die im Dokument verwendeten Schriftarten ermittelt, sortiert nach Dokumentkomponente und ggf. auch nach Dokumentabschnitt, und mit den in Word zur Verfügung stehenden Schriftarten verglichen, um ggf. nicht installierte Schriftarten zu ermitteln. Das Ergebnis wird in einem neuen Dokument ausgegeben.
 
Option Explicit

Private Const mc_DELIMITER As String = "|"

Private m_strFontList      As String
Private m_strFontListStory As String

Public Sub GetUsedFontsInDoc_1()
  Dim wdDoc  As Document

  m_strFontList = ""
  m_strFontListStory = ""

  On Error GoTo err_GetUsedFontsInDoc

  If Application.Documents.Count = 0 Then
    Exit Sub
  Else
    If ActiveDocument.ProtectionType <> wdNoProtection Then
      Exit Sub
    End If
  End If

  Set wdDoc = ActiveDocument

  LoopThruDocStoryRanges wdDoc
  PrintFontNames wdDoc

exit_Sub:
  On Error GoTo 0
  Set wdDoc = Nothing
  Exit Sub

err_GetUsedFontsInDoc:
  MsgBox Err.Description, vbOKOnly + vbCritical, _
        Title:="Liste der verwendeten Schriftarten"
  Resume exit_Sub
End Sub

Private Sub LoopThruDocStoryRanges(ByVal Doc As Document)
  Dim rngStory        As Range
  Dim rngSection      As Section
  Dim rngHeaderFooter As HeaderFooter
  Dim shpShape        As Shape
  Dim blnLinkToPrev   As Boolean

  For Each rngStory In Doc.StoryRanges
    If rngStory.StoryType < 6 Then
      GetUsedFontsInRange rngStory
      Do Until (rngStory.NextStoryRange Is Nothing)
        Set rngStory = rngStory.NextStoryRange
        GetUsedFontsInRange rngStory
      Loop
    End If
  Next

  For Each rngSection In Doc.Sections
    For Each rngHeaderFooter In rngSection.Headers
      blnLinkToPrev = rngHeaderFooter.LinkToPrevious
      If Not blnLinkToPrev Then
        GetUsedFontsInRange rngHeaderFooter.Range
        For Each shpShape In rngHeaderFooter.Shapes
          If shpShape.Type = msoTextBox Then
            GetUsedFontsInRange shpShape.TextFrame.TextRange
          End If
        Next
      End If
    Next

    For Each rngHeaderFooter In rngSection.Footers
      blnLinkToPrev = rngHeaderFooter.LinkToPrevious
      If Not blnLinkToPrev Then
        GetUsedFontsInRange rngHeaderFooter.Range
      End If
    Next
  Next
End Sub

Private Sub GetUsedFontsInRange(ByVal StoryRng As Range)
  Dim para    As Paragraph

  Dim rngPara As Range
  Dim rngSent As Range
  Dim rngWord As Range
  Dim rngChar As Range

  If Len(StoryRng.Font.Name) = 0 Then
    For Each para In StoryRng.Paragraphs
      Set rngPara = para.Range

      If Len(rngPara.Font.Name) = 0 Then
        For Each rngSent In rngPara.Sentences
          If Len(rngSent.Font.Name) = 0 Then
            For Each rngWord In rngSent.Words
              If Len(rngWord.Font.Name) = 0 Then
                For Each rngChar In rngWord.Characters
                  SaveFontName rngChar
                Next
              Else
                SaveFontName rngWord
              End If
            Next
          Else
            SaveFontName rngSent
          End If
        Next
      Else
        SaveFontName rngPara
      End If
    Next
  Else
    SaveFontName StoryRng
  End If
End Sub

Private Sub SaveFontName(ByVal rngRange As Range)
  Dim strFontName As String

  Dim lngSection  As Long
  Dim varStryType As Variant
  Dim strTmp      As String

  strFontName = rngRange.Font.Name

  If InStr(1, m_strFontList, strFontName) = 0 Then
    m_strFontList = m_strFontList & strFontName & mc_DELIMITER
  End If

  lngSection = rngRange.Sections(1).Index
  varStryType = (rngRange.StoryType * 1000) + lngSection
  varStryType = Format$(varStryType, "00000")

  strTmp = varStryType & " " & strFontName
  If InStr(1, m_strFontListStory, strTmp) = 0 Then
    m_strFontListStory = m_strFontListStory & strTmp & mc_DELIMITER
  End If
End Sub

Private Sub PrintFontNames(ByVal Doc As Document)

  Dim astrFontList()  As String
  Dim strMsg          As String
  Dim wdDocNew        As Document

  m_strFontList = Left$(m_strFontList, Len(m_strFontList) - 1)

  #If VBA6 Then
    astrFontList() = VBA.Split(m_strFontList, mc_DELIMITER)
  #Else
    SplitString m_strFontList, astrFontList(), mc_DELIMITER
  #End If

  WordBasic.SortArray astrFontList()

  #If VBA6 Then
    m_strFontList = VBA.Join(astrFontList(), vbLf)
  #Else
    m_strFontList = Join(astrFontList(), vbLf)
  #End If

  strMsg = strMsg & "Liste der im Dokument '" & Doc.Name
  strMsg = strMsg & "' verwendeten Schriftarten sortiert:"
  strMsg = strMsg & vbLf & vbLf
  strMsg = strMsg & m_strFontList

  strMsg = strMsg & CompareFonts(astrFontList())

  Erase astrFontList()

  Dim astrStoryTypes()    As String
  Dim astrFontListStory() As String
  Dim strFontName         As String

  Dim nSections       As Integer
  Dim intUBound       As Integer
  Dim i               As Integer

  Dim lngStory        As Long
  Dim lngStoryPrev    As Long
  Dim lngSection      As Long
  Dim lngSectionPrev  As Long

  ReDim astrStoryTypes(11)

  astrStoryTypes(1) = "Haupttext"
  astrStoryTypes(2) = "Fussnotentext"
  astrStoryTypes(3) = "Endnotentext"
  astrStoryTypes(4) = "Kommentar"
  astrStoryTypes(5) = "Textfeld"
  astrStoryTypes(6) = "Kopfzeile gerade Seite(n)"
  astrStoryTypes(7) = "Kopfzeile/ungerade Seite(n)"
  astrStoryTypes(8) = "Fusszeile gerade Seite(n)"
  astrStoryTypes(9) = "Fusszeile/ungerade Seite(n)"
  astrStoryTypes(10) = "Kopfzeile erste Seite"
  astrStoryTypes(11) = "Fusszeile erste Seite"

  m_strFontListStory = Left$(m_strFontListStory, _
        Len(m_strFontListStory) - 1)

  #If VBA6 Then
    astrFontList() = VBA.Split(m_strFontListStory, mc_DELIMITER)
  #Else
    SplitString m_strFontListStory, astrFontList(), mc_DELIMITER
  #End If

  intUBound = UBound(astrFontList)
  ReDim astrFontListStory(2, intUBound)

  For i = 0 To intUBound
    astrFontListStory(0, i) = Mid$(astrFontList(i), 1, 2)
    astrFontListStory(1, i) = Mid$(astrFontList(i), 3, 3)
    astrFontListStory(2, i) = Mid$(astrFontList(i), 7)
  Next

  WordBasic.SortArray astrFontListStory(), 0, 0, intUBound, 1, 2
  WordBasic.SortArray astrFontListStory(), 1, 0, intUBound, 1, 1
  WordBasic.SortArray astrFontListStory(), 0, 0, intUBound, 1, 0

  strMsg = strMsg & vbLf & vbLf
  strMsg = strMsg & "Liste der im Dokument verwendeten Schriftarten "
  strMsg = strMsg & vbLf & "sortiert nach Dokumentkomponenten:"
  strMsg = strMsg & vbLf

  nSections = Doc.Sections.Count

  For i = 0 To intUBound
    lngStory = Val(astrFontListStory(0, i))
    lngSection = Val(astrFontListStory(1, i))
    strFontName = astrFontListStory(2, i)

    If lngStory <> lngStoryPrev Then
      strMsg = strMsg & vbLf
      strMsg = strMsg & astrStoryTypes(lngStory) & vbLf

      If nSections > 1 Then
        strMsg = strMsg & vbTab
        strMsg = strMsg & "Abschnitt " & _
              CStr(lngSection) & vbLf
      End If

    Else
      If nSections > 1 Then
        If lngSection <> lngSectionPrev Then
          strMsg = strMsg & vbTab
          strMsg = strMsg & "Abschnitt " & _
                CStr(lngSection) & vbLf
        End If
      End If
    End If

    strMsg = strMsg & vbTab & vbTab
    strMsg = strMsg & strFontName & vbLf

    lngStoryPrev = lngStory
    lngSectionPrev = lngSection
  Next

  Set wdDocNew = Application.Documents.Add
  wdDocNew.Range.Text = strMsg
  wdDocNew.UserControl = True
  Set wdDocNew = Nothing

  Erase astrFontList()
  Erase astrFontListStory()
  Erase astrStoryTypes()
End Sub

Private Function CompareFonts(ByRef FontList() As String) As String
  Dim fnt         As Variant
  Dim strAppFonts As String
  Dim i           As Integer
  Dim intUBound   As Integer
  Dim strFonts    As String
  Dim strMsg      As String

  For Each fnt In Application.FontNames
    strAppFonts = strAppFonts & vbLf & fnt
  Next

  intUBound = UBound(FontList)
  For i = 0 To intUBound
    If InStr(strAppFonts, FontList(i)) = 0 Then
      strFonts = strFonts & vbLf & FontList(i)
    End If
  Next

  If Len(strFonts) > 0 Then
    strMsg = strMsg & vbLf & vbLf
    strMsg = strMsg & "Folgende Schriftarten im Dokument stehen"
    strMsg = strMsg & vbLf & "in Word  n i c h t  zur Verfügung:"
    strMsg = strMsg & vbLf & strFonts
  End If
  CompareFonts = strMsg
End Function
 
Links zum Thema
Installierte Schriftarten mit Vorschau anzeigen
Schriftart installiert?

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
Word-Version
95
97
2000
2002 (XP)
2003
2007
2010


Download  (79 kB) Downloads bisher: [ 844 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Sonntag, 29. Mai 2011