Mit Word können Sie die Schriftarten verwenden, die auf dem von Ihnen verwendeten System installiert sind. Schriftarten werden in Windows installiert, sodass sie nicht nur für Word, sondern für alle auf Ihrem System installierten Programme verfügbar sind.

Wenn Sie ein Dokument auf Ihrem System erstellen, ist es leicht zu erkennen, welche Schriftarten verwendet werden. Die Liste der Schriftarten ist auf die auf dem System verfügbaren beschränkt. Wenn Sie jedoch ein Dokument von einer anderen Person erhalten, sind auf dem System der anderen Person möglicherweise andere Schriftarten installiert als Sie. Dies bedeutet, dass das Word-Dokument mit Schriftarten formatiert werden kann, die Sie noch nicht einmal auf Ihrem System haben.

Wenn Sie eine Liste der in einem Dokument verwendeten Schriftarten erstellen möchten (im Gegensatz zu einer Liste der auf einem System verfügbaren Schriftarten), haben Sie mehrere Möglichkeiten. Zunächst können Sie das Word-Dokument in einem Texteditor öffnen und sich in den Teilen des Dokuments umsehen, die Sie normalerweise in Word nicht sehen. Gegen Ende der Datei sollte eine Liste der im Dokument verwendeten Schriftarten angezeigt werden. Wenn Sie dies tun, sollten Sie jedoch sehr vorsichtig sein, um keine Änderungen am Word-Dokument vorzunehmen, während es in Ihrem Texteditor geöffnet ist. Dadurch kann das Dokument leicht in Word nicht mehr verwendet werden.

Eine wortbasierte Lösung besteht darin, einfach jedes Zeichen in einem Dokument zu durchsuchen und herauszufinden, welche Schriftart zum Formatieren des Zeichens verwendet wird. Ein zeichenweiser Ansatz ist erforderlich, da jedes Zeichen mit einer anderen Schriftart formatiert werden kann und Sie mit VBA nicht auf eine Schriftsammlung in Bezug auf das Dokument selbst zugreifen können. Es scheint, dass keine solche Sammlung beibehalten wird. Somit ist der sicherste (und langsamste)

Methode ist einfach durch jedes Zeichen zu gehen und Ihre eigene Liste zu erstellen. Das folgende VBA-Makro führt die Aufgabe aus:

Public Sub ListFontsInDoc1()

Dim FontList(199) As String   Dim FontCount As Integer   Dim FontName As String   Dim J As Integer, K As Integer, L As Integer   Dim X As Long, Y As Long   Dim FoundFont As Boolean   Dim rngChar As Range   Dim strFontList As String

FontCount = 0   X = ActiveDocument.Characters.Count   Y = 0   ' For-Next loop through every character   For Each rngChar In ActiveDocument.Characters     Y = Y + 1     FontName = rngChar.Font.Name     StatusBar = Y & ":" & X     ' check if font used for this char already in list     FoundFont = False     For J = 1 To FontCount       If FontList(J) = FontName Then FoundFont = True     Next J     If Not FoundFont Then       FontCount = FontCount + 1       FontList(FontCount) = FontName     End If   Next rngChar

' sort the list   StatusBar = "Sorting Font List"

For J = 1 To FontCount - 1     L = J     For K = J + 1 To FontCount       If FontList(L) > FontList(K) Then L = K     Next K     If J <> L Then       FontName = FontList(J)

FontList(J) = FontList(L)

FontList(L) = FontName     End If   Next J

StatusBar = ""

' put in new document   Documents.Add   Selection.TypeText Text:="There are " & _    FontCount & " fonts used in the document, as follows:"

Selection.TypeParagraph   Selection.TypeParagraph   For J = 1 To FontCount     Selection.TypeText Text:=FontList(J)

Selection.TypeParagraph   Next J End Sub

Je länger Ihr Dokument ist, desto länger dauert es natürlich, bis das Makro fertig ist. (Ich habe das Makro für ein Dokument mit 1.100 Seiten ausgeführt und es dauerte ungefähr 46 Minuten. Bei einem fünfseitigen Dokument dauerte es weniger als eine Minute.) Wenn Sie fertig sind, erstellt das Makro ein neues Dokument, das eine sortierte Liste der verwendeten Schriftarten enthält.

Das obige Makro führt nur das Hauptdokument durch. Möglicherweise werden in anderen Elementen Ihres Dokuments andere, andere Schriftarten verwendet. Wenn Sie möchten, dass diese in die Liste aufgenommen werden, müssen Sie eine Variation des Makros verwenden, die diese anderen Elemente berücksichtigt. Das folgende Makro (ListFontsInDoc2) ist viel länger und die Auflistung enthält auch drei weitere Makros, die aus dem Hauptmakro heraus aufgerufen werden.

Public Sub ListFontsInDoc2()

Dim rngStory As Word.Range   Dim rngChar As Range   Dim oShp As Word.Shape   Dim FontName As String   Dim lngIndex As Long   Dim lngChar As Long   Dim lngCharCount As Long   Dim colFontsUsed As New Collection   Dim oDocList As Word.Document

For Each rngStory In ActiveDocument.StoryRanges     lngChar = 0     lngCharCount = rngStory.Characters.Count     Do       'Evaluate each character       Set rngChar = rngStory.Characters(1)

If rngStory.End > 1 Then         Do           lngChar = lngChar + 1           FontName = rngChar.Font.Name           StatusBar = "Evaluauting character " & lngChar & _            " of " & lngCharCount & " characters in the story range"

'Check if font used for this character already in list           On Error Resume Next           'Collection key prevents adding fonts already           'in the collection           colFontsUsed.Add rngChar.Font.Name, rngChar.Font.Name           On Error GoTo 0           rngChar.MoveStart wdCharacter, 1           rngChar.MoveEnd wdCharacter, 1           'Set rngChar = rngChar.Next '         Loop Until rngChar.End = rngStory.End       End If

'Evaluate shapes in headers and footers       Select Case rngStory.StoryType         Case 6, 7, 8, 9, 10, 11           'No shape will throw an error that we handle and skip           On Error GoTo Err_Handler           If rngStory.ShapeRange.Count > 0 Then             For Each oShp In rngStory.ShapeRange               If oShp.TextFrame.HasText Then                 lngChar = 0                 lngCharCount = oShp.TextFrame.TextRange.Characters.Count                 For Each rngChar In oShp.TextFrame.TextRange.Characters                   lngChar = lngChar + 1                   FontName = rngChar.Font.Name                   StatusBar = "Evaluauting character " & _                    lngChar & " of " & lngCharCount & _                    " characters in the story range"

On Error Resume Next                   colFontsUsed.Add rngChar.Font.Name, rngChar.Font.Name                   On Error GoTo 0                 Next rngChar               End If             Next oShp           End If         Case Else           'Do Nothing       End Select

SkipRange:

On Error GoTo 0       'Get next linked story (if any)

Set rngStory = rngStory.NextStoryRange     Loop Until rngStory Is Nothing   Next rngStory   'Sort the collection.

StatusBar = "Sorting Font List"

Set colFontsUsed = SortCollection(colFontsUsed)

StatusBar = ""

'Create font list document.

Set oDocList = Documents.Add   With oDocList.Range     .Text = "There are " & colFontsUsed.Count & _      " fonts used in the document, as follows:" & vbCr & vbCr     For lngIndex = 1 To colFontsUsed.Count       .InsertAfter colFontsUsed(lngIndex) & vbCr     Next lngIndex   End With   Set oDocList = Nothing   Exit Sub

Err_Handler:

Resume SkipRange End Sub
Public Function SortCollection(ByVal oCol As Collection) As Collection   Dim arrIndex() As Long   Dim lngCount As Long   Dim i As Long   Dim m As Long   Dim oColSorted As New Collection

lngCount = oCol.Count   If lngCount = 0 Then     Set SortCollection = New Collection     Exit Function   End If

'Allocate an index array.

ReDim arrIndex(0 To lngCount - 1) As Long   'Fill the index array.

For i = 0 To lngCount - 1     arrIndex(i) = i + 1   Next i

'Generate an ordered heap   For i = lngCount/2 - 1 To 0 Step -1     Heapify oCol, arrIndex, i, lngCount   Next i

'Sort the index array   For m = lngCount To 2 Step -1     Exchange arrIndex, 0, m - 1     Heapify oCol, arrIndex, 0, m - 1   Next   For i = 0 To lngCount - 1     oColSorted.Add oCol.Item(arrIndex(i))

Next ' fill output collection   Set SortCollection = oColSorted End Function
Private Sub Heapify(oCol As Collection, arrIndexPasssed() As Long, _  lngIndex As Long, lngCount As Long)

Dim lngMidCount As Long   Dim i As Long   lngMidCount = lngCount/2

Do While lngIndex < lngMidCount     i = 2 * lngIndex + 1     If i + 1 < lngCount Then       If oCol.Item(arrIndexPasssed(i)) < oCol.Item(arrIndexPasssed(i + 1)) _        Then i = i + 1     End If     If oCol.Item(arrIndexPasssed(lngIndex)) >= oCol.Item(arrIndexPasssed(i)) _      Then Exit Do     Exchange arrIndexPasssed, lngIndex, i     lngIndex = i   Loop End Sub
Private Sub Exchange(Index() As Long, i As Long, j As Long)

Dim Temp As Long   Temp = Index(i)

Index(i) = Index(j)

Index(j) = Temp End Sub

_Hinweis: _

Wenn Sie wissen möchten, wie die auf dieser Seite (oder auf einer anderen Seite der WordTips-Websites) beschriebenen Makros verwendet werden, habe ich eine spezielle Seite vorbereitet, die hilfreiche Informationen enthält.

WordTips ist Ihre Quelle für kostengünstige Microsoft Word-Schulungen.

(Microsoft Word ist die weltweit beliebteste Textverarbeitungssoftware.) Dieser Tipp (1522) gilt für Microsoft Word 97, 2000, 2002 und 2003. Sie finden eine Version dieses Tipps für die Multifunktionsleistenschnittstelle von Word (Word 2007) und später) hier: