Erstellen einer Dokumentschriftliste (Microsoft Word)
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: