Skapa ett dokument Font List

February 18

Word kan du använda de teckensnitt som är installerade på systemet som du använder. Teckensnitt är installerade i Windows, så att de är tillgängliga inte bara till Word, utan till alla program som är installerade på ditt system.

När du skapar ett dokument på ditt system, är det lätt att veta vad typsnitt används-listan över teckensnitt är begränsat till de som är tillgängliga på systemet. Om du tar emot ett dokument från en annan person, kan dock den andra personens systemet har olika teckensnitt installerade än du gör. Det innebär att deras Word-dokument kan formateras med teckensnitt som du inte ens har på ditt system.

Om du vill skapa en lista med teckensnitt som används i ett dokument (i motsats till en lista över tillgängliga teckensnitt på ett system), har du ett par alternativ. Först av allt, kan du öppna Word-dokumentet i en textredigerare och titta runt i de delar av dokumentet som du normalt inte ser i Word. Nära slutet av filen bör du se en lista över teckensnitt som används i dokumentet. Om du gör detta, bör du dock vara mycket noga med att inte göra några ändringar i Word-dokumentet medan den är öppen i din textredigerare. Om du gör det kan lätt göra dokumentet inte längre kan användas i Word.

Ett ord baserad lösning är att helt enkelt titta igenom varje tecken i ett dokument och kolla vad typsnitt används för att formatera tecken. Ett tecken-för-tecken tillvägagångssätt är nödvändigt eftersom varje tecken kan formateras med ett annat teckensnitt, och VBA kan du inte komma åt en typsnitt samling i förhållande till själva dokumentet-det verkar som ingen sådan samling bibehålls. Således är det säkraste (och långsammast) metoden att helt enkelt gå igenom varje tecken och skapa din egen lista. Följande VBA-makro utför uppgiften:

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 Såsom Range
Dim strFontList As String

FontCount = 0
X = ActiveDocument.Characters.Count
Y = 0
"För-Next slinga genom varje tecken
För varje rngChar I ActiveDocument.Characters
Y = Y + 1
FontName = rngChar.Font.Name
StatusBar = Y & ":" & X
"Kontrollera om typsnitt som används för denna röding redan i listan
FoundFont = False
För J = 1 Till FontCount
Om FontList (J) = FontName Då FoundFont = Sant
Nästa J
Om Inte FoundFont Därefter
FontCount = FontCount + 1
FontList (FontCount) = FontName
End If
Nästa rngChar

"Sortera listan
StatusBar = "Sortera Font List"
För J = 1 Till FontCount - 1
L = J
För K = J + 1 Till FontCount
Om FontList (L)> FontList (K) Då L = K
Nästa K
Om J <> L Sedan
FontName = FontList (J)
FontList (J) = FontList (L)
FontList (L) = FontName
End If
Nästa J

StatusBar = ""
"Sätta i nya dokument
Documents.Add
Selection.TypeText Text: = "Det finns" & _
FontCount & "typsnitt som används i dokumentet, enligt följande:"
Selection.TypeParagraph
Selection.TypeParagraph
För J = 1 Till FontCount
Selection.TypeText Text: = FontList (J)
Selection.TypeParagraph
Nästa J
End Sub

Självklart ju längre dokumentet, desto längre tid tar makrot till slut. (Jag sprang makrot på en 1100 sidor långt dokument och det tog ungefär 46 minuter. På en fem-sidigt dokument det tog mindre än en minut.) När du är klar, skapar makrot ett nytt dokument som innehåller en sorterad lista över de teckensnitt som används.

Ovanstående makrot bara steg genom huvuddokumentet. Det är möjligt att det finns andra, olika teckensnitt som används i andra element i dokumentet. Om du vill ha dem med i listan, då måste du använda en variant av makro som tar dessa andra faktorer i beaktande. Följande makro (ListFontsInDoc2) är mycket längre, och noteringen ingår även tre andra makron som kallas inifrån i macro.

Public Sub ListFontsInDoc2 ()
Dim rngStory Som Word.Range
Dim rngChar Såsom Range
Dim oShp Såsom Word.Shape
Dim FontName As String
Dim lngIndex As Long
Dim lngChar As Long
Dim lngCharCount As Long
Dim colFontsUsed Som Ny samling
Dim oDocList Som Word.Document

För varje rngStory I ActiveDocument.StoryRanges
lngChar = 0
lngCharCount = rngStory.Characters.Count
Göra
"Utvärdera varje tecken
Ställ rngChar = rngStory.Characters (1)
Om rngStory.End> 1 Sedan
Göra
lngChar = lngChar + 1
FontName = rngChar.Font.Name
StatusBar = "Evaluauting tecknet" & lngChar & _
"Av" & lngCharCount & "tecken i berättelsen range"
"Kontrollera om typsnitt som används för denna karaktär redan i listan
On Error Resume Next
"Collection nyckel förhindrar lägga typsnitt redan
'I samlingen
colFontsUsed.Add rngChar.Font.Name, rngChar.Font.Name
On Error GoTo 0
rngChar.MoveStart wdCharacter, 1
rngChar.MoveEnd wdCharacter, 1
"Ställ rngChar = rngChar.Next '
Loop Until rngChar.End = rngStory.End
End If

"Utvärdera former i sidhuvud och sidfot
Välj ärende rngStory.StoryType
Fall 6, 7, 8, 9, 10, 11
"Ingen form kommer att kasta ett fel som vi hanterar och hoppa
On Error GoTo Err_Handler
Om rngStory.ShapeRange.Count> 0 Then
För varje oShp I rngStory.ShapeRange
Om oShp.TextFrame.HasText Sedan
lngChar = 0
lngCharCount = oShp.TextFrame.TextRange.Characters.Count
För varje rngChar I oShp.TextFrame.TextRange.Characters
lngChar = lngChar + 1
FontName = rngChar.Font.Name
StatusBar = "Evaluauting tecknet" & _
lngChar & "av" & lngCharCount & _
"karaktärer i berättelsen intervallet"
On Error Resume Next
colFontsUsed.Add rngChar.Font.Name, rngChar.Font.Name
On Error GoTo 0
Nästa rngChar
End If
Nästa oShp
End If
Case Else
"Gör ingenting
End Select

SkipRange:
On Error GoTo 0
"Get nästa länkade story (om någon)
Ställ rngStory = rngStory.NextStoryRange
Loop Until rngStory är ingenting
Nästa rngStory
"Sortera samlingen.
StatusBar = "Sortera Font List"
Ställ colFontsUsed = SortCollection (colFontsUsed)
StatusBar = ""
"Skapa fontlista dokument.
Ställ oDocList = Documents.Add
Med oDocList.Range
.Text = "Det finns" & colFontsUsed.Count & _
"Typsnitt som används i dokumentet, enligt följande:" & vbCr & vbCr
För lngIndex = 1 Till colFontsUsed.Count
.InsertAfter ColFontsUsed (lngIndex) & vbCr
Nästa lngIndex
End Med
Ställ oDocList = Ingenting
Exit Sub

Err_Handler:
Resume SkipRange
End Sub

Offentlig Funktion SortCollection (ByVal oCol Som Collection) Som Kollektion
Dim arrIndex () As Long
Dim lngCount As Long
Dim jag As Long
Dim m As Long
Dim oColSorted Som Ny samling

lngCount = oCol.Count
Om lngCount = 0 Då
Ställ SortCollection = Ny samling
Avsluta Funktion
End If

'Tilldela en indexmatris.
ReDim arrIndex (0 Till lngCount - 1) As Long
"Fyll indexmatrisen.
För i = 0 Till lngCount - 1
arrIndex (i) = i + 1
Nästa jag

"Generera en ordnad heap
För i = lngCount / 2 - 1 till 0 Step -1
Heapify oCol, arrIndex, jag, lngCount
Nästa jag

"Sortera index array
För m = lngCount Till 2 Steg -1
Utbyte arrIndex, 0, m - 1
Heapify oCol, arrIndex, 0, m - 1
Nästa
För i = 0 Till lngCount - 1
oColSorted.Add oCol.Item (arrIndex (i))
Nästa 'fyller utgång samling
Ställ SortCollection = oColSorted
End Function

Private Sub Heapify (oCol Som Collection, arrIndexPasssed () As Long, _
lngIndex As Long, lngCount As Long)
Dim lngMidCount As Long
Dim jag As Long
lngMidCount = lngCount / 2

Gör Medan lngIndex <lngMidCount
i = 2 * lngIndex + 1
Om i + 1 = oCol.Item (arrIndexPasssed (i)) _
Då Exit Do
Exchange arrIndexPasssed, lngIndex, jag
lngIndex = i
Loop
End Sub

Private Sub Exchange (Index () As Long, jag As Long, j As Long)
Dim Temp As Long
Temp = Index (i)
Index (i) = index (j)
Index (j) = Temp
End Sub

WordTips är din källa för kostnadseffektiv Microsoft Word utbildning. (Microsoft Word är det mest populära ordbehandlingsprogram i världen.) Detta tips (1522) gäller för Microsoft Word 97, 2000, 2002, och 2003. Du kan hitta en version av detta tips för menyfliksområdet i Word (Word 2007 och senare) här: Skapa ett dokument Font List.