|
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
|
|