Macro to list all character styles in a document

ljd108 · #1 11-18-2014, 06:51 AM

Hi,

I currently have a macro that is able to produce a list of all paragraph styles in a word document (see below). I was wondering if it is possible to adapt this code/create a new code to produce a list of charater styles instead of paragraph styles?

Thanks

Code:

Code:

Sub CreateStyleList()
    Dim docThis As Document
    Dim styItem As Style
    Dim sBuiltIn(499) As String
    Dim iStyBICount As Integer
    Dim sUserDef(499) As String
    Dim iStyUDCount As Integer
    Dim sInUse(499) As String
    Dim iStyIUCount As Integer
    Dim iParCount As Integer
    Dim J As Integer, K As Integer
    Dim sParStyle As String
    Dim bInUse As Boolean
    
    ' Ref the active document
    Set docThis = ActiveDocument
    
    ' Collect all styles being used
    iStyIUCount = 0
    iParCount = docThis.Paragraphs.Count
    iParOut = 0
    For J = 1 To iParCount
        sParStyle = docThis.Paragraphs(J).Style
        For K = 1 To iStyIUCount
            If sParStyle = sInUse(K) Then Exit For
        Next K
        If K = iStyIUCount + 1 Then
            iStyIUCount = K
            sInUse(iStyIUCount) = sParStyle
        End If
    Next J
    
    iStyBICount = 0
    iStyUDCount = 0
    ' Check out styles that are "in use"
    For Each styItem In docThis.Styles
        'see if in those being used
        bInUse = False
        For J = 1 To iStyIUCount
            If styItem.NameLocal = sInUse(J) Then bInUse = True
        Next J
        'Add to those not in use
        If Not bInUse Then
            If styItem.BuiltIn Then
                iStyBICount = iStyBICount + 1
                sBuiltIn(iStyBICount) = styItem.NameLocal
            Else
                iStyUDCount = iStyUDCount + 1
                sUserDef(iStyUDCount) = styItem.NameLocal
            End If
        End If
    Next styItem
    
    'Now create the output document
    Documents.Add
    
    Selection.TypeText "Styles In Use"
    Selection.TypeParagraph
    For J = 1 To iStyIUCount
        Selection.TypeText sInUse(J)
        Selection.TypeParagraph
    Next J
    Selection.TypeParagraph
    Selection.TypeParagraph
    
    Selection.TypeText "Built-in Styles Not In Use"
    Selection.TypeParagraph
    For J = 1 To iStyIUCount
        Selection.TypeText sBuiltIn(J)
        Selection.TypeParagraph
    Next J
    Selection.TypeParagraph
    Selection.TypeParagraph
    
    Selection.TypeText "User-defined Styles Not In Use"
    Selection.TypeParagraph
    For J = 1 To iStyIUCount
        Selection.TypeText sUserDef(J)
        Selection.TypeParagraph
    Next J
    Selection.TypeParagraph
    Selection.TypeParagraph
End Sub

macropod · #2 11-18-2014, 03:57 PM

The following macro will produce a report of all Styles in the document, in a sorted table format.

Code:

Sub ReportAllStyles()
Dim Sty As Style, StrAttr As String, Rng As Range
StrAttr = "Style Name" & vbTab & "Type" & vbTab & "Built In" & vbTab & "In Use"
With ActiveDocument
  For Each Sty In .Styles
    With Sty
      StrAttr = StrAttr & vbCr & .NameLocal & vbTab
      Select Case .Type
        Case wdStyleTypeCharacter:     StrAttr = StrAttr & "Character" & vbTab
        Case wdStyleTypeLinked:        StrAttr = StrAttr & "Linked" & vbTab
        Case wdStyleTypeList:          StrAttr = StrAttr & "List" & vbTab
        Case wdStyleTypeParagraph:     StrAttr = StrAttr & "Paragraph" & vbTab
        Case wdStyleTypeParagraphOnly: StrAttr = StrAttr & "ParagraphOnly" & vbTab
        Case wdStyleTypeTable:         StrAttr = StrAttr & "Table" & vbTab
      End Select
      Select Case .BuiltIn
        Case True:                     StrAttr = StrAttr & "Y" & vbTab
        Case Else:                     StrAttr = StrAttr & "N" & vbTab
      End Select
      Select Case .InUse
        Case True:                     StrAttr = StrAttr & "Y"
        Case Else:                     StrAttr = StrAttr & "N"
      End Select
    End With
  Next
  Set Rng = .Characters.Last
  With Rng
    .InsertAfter vbCr
    .Collapse wdCollapseEnd
    .Text = StrAttr
    .ConvertToTable Separator:=vbTab, NumColumns:=4, AutoFit:=True, _
      AutoFitBehavior:=wdAutoFitContent, DefaultTableBehavior:=wdWord9TableBehavior
    With .Tables(1)
      With .Rows(1)
        .HeadingFormat = True
        .Range.Font.Bold = True
      End With
      .Borders.Enable = False
      .Rows.Alignment = wdAlignRowCenter
      .Sort ExcludeHeader:=True, CaseSensitive:=False, LanguageID:=wdLanguageNone, _
        FieldNumber:="Column 2", SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
        FieldNumber2:="Column 3", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:=wdSortOrderAscending, _
        FieldNumber3:="Column 4", SortFieldType3:=wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending
    End With
  End With
End With
End Sub

To reduce the report to just Character Styles, you could use:

Code:

Sub ReportCharacterStyles()
Dim Sty As Style, StrAttr As String, Rng As Range
StrAttr = "Style Name" & vbTab & "Type" & vbTab & "Built In" & vbTab & "In Use"
With ActiveDocument
  For Each Sty In .Styles
    With Sty
      Select Case .Type
        Case wdStyleTypeCharacter
          StrAttr = StrAttr & vbCr & .NameLocal & vbTab
          StrAttr = StrAttr & "Character" & vbTab
          Select Case .BuiltIn
            Case True:                     StrAttr = StrAttr & "Y" & vbTab
            Case Else:                     StrAttr = StrAttr & "N" & vbTab
          End Select
          Select Case .InUse
            Case True:                     StrAttr = StrAttr & "Y"
            Case Else:                     StrAttr = StrAttr & "N"
          End Select
      End Select
    End With
  Next
  Set Rng = .Characters.Last
  With Rng
    .InsertAfter vbCr
    .Collapse wdCollapseEnd
    .Text = StrAttr
    .ConvertToTable Separator:=vbTab, NumColumns:=4, AutoFit:=True, _
      AutoFitBehavior:=wdAutoFitContent, DefaultTableBehavior:=wdWord9TableBehavior
    With .Tables(1)
      With .Rows(1)
        .HeadingFormat = True
        .Range.Font.Bold = True
      End With
      .Borders.Enable = False
      .Rows.Alignment = wdAlignRowCenter
      .Sort ExcludeHeader:=True, CaseSensitive:=False, LanguageID:=wdLanguageNone, _
        FieldNumber:="Column 2", SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
        FieldNumber2:="Column 3", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:=wdSortOrderAscending, _
        FieldNumber3:="Column 4", SortFieldType3:=wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending
    End With
  End With
End With
End Sub

ljd108 · #3 11-18-2014, 06:49 PM

That is exactly what I was looking for. Thank you very much for your help.

ljd108 · #4 11-18-2014, 07:10 PM

Hi, I have just looked through the report in more detail and it seems to come up with more styles in use than are actually in use in the word document. I have tried running this on a blank document with only a small amount of text and still have the same issue.

It seems to be coming up with all the style options available rather than what the text within the word document is actually using?

Thanks

Tito · #5 08-27-2024, 01:26 AM

@macropod
Hi Paul,
I highly appreciate you shared ReportAllStyles(). Love it - Thank you!
I tried several ways to also get the shortcut keys i have assigned to my own styles into the list. Without success.
(Unfortunately i am not a coder).
Would this even be possible? Thank you in advance.
Best,
Thorsten

macropod · #6 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

gmaxey · #7 11-19-2014, 07:33 AM

Paul,

I took some liberties with your code to produce a list of only the styles actually in use in the document. It was interesting to discover that starting with a new blank document with no text the list does not return just "Normal" and "Default Paragraph Font" as I would have expected.

It returns:
Default Paragraph Font
No List
Footer
Header
Normal
Table Normal

Apparently "Header" and "Footer" is returned because the code accesses those ranges. No List and Table Normal are apparently contained in the final paragraph mark.

Nice job by the way!

Code:

Option Explicit
Sub ReportAllStyles()
Dim oStyle As Style, strAttr As String, oRng As Range
Dim oTbl As Word.Table
  strAttr = "Style Name" & vbTab & "Type" & vbTab & "Built In" ' & vbTab & "In Use"
  With ActiveDocument
    For Each oStyle In .Styles
     With oStyle
       If .InUse Then
         'Is it really "In Use" i.e., applied to text in the document?
         If StyleInUse(ActiveDocument, oStyle) = "Y" Then
           strAttr = strAttr & vbCr & .NameLocal & vbTab
           Select Case .Type
             Case wdStyleTypeCharacter:     strAttr = strAttr & "Character" & vbTab
             Case wdStyleTypeLinked:        strAttr = strAttr & "Linked" & vbTab
             Case wdStyleTypeList:          strAttr = strAttr & "List" & vbTab
             Case wdStyleTypeParagraph:     strAttr = strAttr & "Paragraph" & vbTab
             Case wdStyleTypeParagraphOnly: strAttr = strAttr & "ParagraphOnly" & vbTab
             Case wdStyleTypeTable:         strAttr = strAttr & "Table" & vbTab
           End Select
           Select Case .BuiltIn
             Case True:                     strAttr = strAttr & "Y"
             Case Else:                     strAttr = strAttr & "N"
           End Select
        End If
     End If
     End With
    Next
    Set oRng = .Characters.Last
    With oRng
      .InsertAfter vbCr
      .Collapse wdCollapseEnd
      .Text = strAttr
      Set oTbl = .ConvertToTable(Separator:=vbTab, NumColumns:=3, DefaultTableBehavior:=wdWord9TableBehavior)
      With oTbl
        With .Rows(1)
          .HeadingFormat = True
          .Range.Font.Bold = True
        End With
        .Borders.Enable = False
        .Rows.Alignment = wdAlignRowCenter
        .Sort ExcludeHeader:=True, CaseSensitive:=False, LanguageID:=wdLanguageNone, _
              FieldNumber:="Column 2", SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
              FieldNumber2:="Column 3", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:=wdSortOrderAscending
      End With
    End With
  End With
End Sub
Sub ReportCharacterStyles()
Dim oStyle As Style, strAttr As String, oRng As Range
strAttr = "Style Name" & vbTab & "Type" & vbTab & "Built In" ' & vbTab & "In Use"
Dim oTbl As Word.Table
  With ActiveDocument
    For Each oStyle In .Styles
      With oStyle
        If .InUse Then
          'Is it really "In Use" i.e., applied to text in the document?
          If StyleInUse(ActiveDocument, oStyle) = "Y" Then
            Select Case .Type
              Case wdStyleTypeCharacter
                strAttr = strAttr & vbCr & .NameLocal & vbTab
                strAttr = strAttr & "Character" & vbTab
              Select Case .BuiltIn
                Case True:                     strAttr = strAttr & "Y"
                Case Else:                     strAttr = strAttr & "N"
              End Select
            End Select
          End If
        End If
      End With
    Next
    Set oRng = .Characters.Last
    With oRng
      .InsertAfter vbCr
      .Collapse wdCollapseEnd
      .Text = strAttr
      Set oTbl = .ConvertToTable(Separator:=vbTab, NumColumns:=3, DefaultTableBehavior:=wdWord9TableBehavior)
      With oTbl
        With .Rows(1)
          .HeadingFormat = True
          .Range.Font.Bold = True
        End With
        .Borders.Enable = False
        .Rows.Alignment = wdAlignRowCenter
        .Sort ExcludeHeader:=True, CaseSensitive:=False, LanguageID:=wdLanguageNone, _
          FieldNumber:="Column 2", SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
          FieldNumber2:="Column 3", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:=wdSortOrderAscending
      End With
    End With
  End With
End Sub
Function StyleInUse(Doc As Document, oStyle As Style) As String
Dim rngStory As Word.Range
Dim strResult As String
Dim lngValidator As Long
Dim oShp As Shape
Dim bResult As Boolean
  'Fix the skipped blank Header/Footer problem
  lngValidator = ActiveDocument.Sections(1).Headers(1).Range.StoryType
 
  'Iterate through all story types in the current document
  For Each rngStory In ActiveDocument.StoryRanges
    'Iterate through all linked stories
    Do
      bResult = FindStyle(rngStory, oStyle)
      If bResult Then GoTo Result
      On Error Resume Next
      Select Case rngStory.StoryType
        Case 6, 7, 8, 9, 10, 11
          If rngStory.ShapeRange.Count > 0 Then
            For Each oShp In rngStory.ShapeRange
              If oShp.TextFrame.HasText Then
                bResult = FindStyle(oShp.TextFrame.TextRange, oStyle)
                If bResult Then GoTo Result
              End If
            Next
          End If
        Case Else
          'Do Nothing
      End Select
      On Error GoTo 0
      'Get next linked story (if any)
      Set rngStory = rngStory.NextStoryRange
    Loop Until rngStory Is Nothing
  Next
Result:
  If bResult = True Then
    StyleInUse = "Y"
  Else
    StyleInUse = "N"
  End If
 
End Function
 
Function FindStyle(oRng As Range, oStyle As Style) As Boolean
Dim bRslt As Boolean
bRslt = False
Selection.Find.ClearFormatting
  With oRng.Find
    .Text = ""
    .Style = oStyle
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    If .Execute Then FindStyle = True
  End With
End Function

macropod · #8 11-19-2014, 03:05 PM

Hi Greg,

I deliberately avoided using StoryRanges because the header, footer, & shaperange StoryRanges don't work reliably with Find/Replace - Find/Replace on a StoryRange with multiple members only ever seems to look at the first member.

spillerbd · #9 10-06-2022, 07:10 AM

@macropod . Could this and some of the more useful global type macros be pinned in the VBA Forum?
It took me a number of searches to finally re-find this one.

macropod · #10 10-06-2022, 01:56 PM

It could, but I'm not inclined to because:
a) it's something relatively few people need; and
b) having too many 'Sticky' threads would detract from user's ability to use a given forum. In this regard, I note we already have 6 'Sticky' threads at the top of the Word forum and 4 'Sticky' threads at the top of the VBA forum.

Guessed · #11 08-27-2024, 02:52 PM

Thorsten

Do you know that you can print all the custom key assignments as an easy way to see them all?

File > Print then click the Settings dropdown where it says 'Print all pages' to select 'Key Assignments'

Tito · #12 08-28-2024, 01:20 AM

Andrew,
that is a nice one indeed

. Didn't know this feature. Thank you.
Helps a lot and still i am curious if someone comes up with a twist to have it in sub ReportAllStyles().

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Font list character display	whabtewo	Word	1	03-09-2014 08:12 PM
MAcro to List all the Font & its size in a word document	shaukat74	Word VBA	1	01-29-2013 09:34 PM
Restricting paragraph styles without restricting character styles	Red Pill	Word	5	05-25-2012 01:06 PM
Quick Styles Set saved but it doesnt appear at the styles list!	Pedro77	Word	3	10-15-2011 05:17 AM
The list of styles appears in different way in different document?????	Jamal NUMAN	Word	4	04-28-2011 05:40 AM