Microsoft Office Forums - View Single Post - [Solved] Macro to list all character styles in a document

macropod · 11-18-2014, 07:58 PM

The .InUse property tends to do that, presumably because of some design quirk with how MS has defined them. The only way around the behaviour is to use Find to search for document content actually using a given Style. Checking the body of the document is trivial, checking headers, footers, textboxes, footnotes, endnotes, etc. requires a lot more processing. To that end, you could change:

Code:

          Select Case .InUse
            Case True:                     StrAttr = StrAttr & "Y"
            Case Else:                     StrAttr = StrAttr & "N"
          End Select

to:

Code:

      Select Case .InUse
        Case False:                     StrAttr = StrAttr & "N"
        Case Else:                      StrAttr = StrAttr & StyleInUse(ActiveDocument, Sty)
      End Select

and, after the existing sub, add:

Code:

Function StyleInUse(Doc As Document, Sty As Style) As String
Dim Sctn As Section, HdFt As HeaderFooter, Shp As Shape, FtNt As Footnote, E_Nt As Endnote, StrRslt As String, bRslt As Boolean
StrRslt = "N"
With Doc
  bRslt = FindStyle(.Range, Sty)
  If bRslt = True Then GoTo Result
  For Each Sctn In .Sections
    For Each HdFt In Sctn.Headers
      If FindStyle(HdFt.Range, Sty) = True Then GoTo Result
      For Each Shp In HdFt.Range.ShapeRange
        With Shp
          If Not .TextFrame Is Nothing Then
            bRslt = FindStyle(.TextFrame.TextRange, Sty)
            If bRslt = True Then GoTo Result
          End If
        End With
      Next
    Next
    For Each HdFt In Sctn.Footers
      bRslt = FindStyle(HdFt.Range, Sty)
      If bRslt = True Then GoTo Result
      For Each Shp In HdFt.Range.ShapeRange
        With Shp
          If Not .TextFrame Is Nothing Then
            bRslt = FindStyle(.TextFrame.TextRange, Sty)
            If bRslt = True Then GoTo Result
          End If
        End With
      Next
    Next
  Next
  For Each Shp In .Range.ShapeRange
    With Shp
      If Not .TextFrame Is Nothing Then
        bRslt = FindStyle(.TextFrame.TextRange, Sty)
        If bRslt = True Then GoTo Result
      End If
    End With
  Next
  For Each FtNt In Footnotes
    bRslt = FindStyle(FtNt.Range, Sty)
    If bRslt = True Then GoTo Result
  Next
  For Each E_Nt In Endnotes
    bRslt = FindStyle(E_Nt.Range, Sty)
    If bRslt = True Then GoTo Result
  Next
End With
Result:
If bRslt = True Then StyleInUse = "Y"
End Function
 
Function FindStyle(Rng As Range, Sty As Style) As Boolean
Dim bRslt As Boolean
bRslt = False
With Rng
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Style = Sty.NameLocal
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .Execute
  End With
  If .Find.Found Then FindStyle = True
End With
End Function