Styles in Use (listing the type of style)

Dear Experts:

below macro lists all the styles in use of the current document. The macro runs just fine. There is one thing I would like to add to this macro.

The type of style is just listed either as
Type 1, Type 2, Type 3, or Type 4. I would like the list to show 'Paragraph Style' instead of just Type 1, 'Character Style' instead of just Type 2 etc.  I could extend the macro and do a search and replace operation to achieve this.

But I am pretty sure there is some more professional way.  I attached a sample file with the code embedded for your convenience.

Help is much appreciated. Thank you very much in advance.

Regards, Andreas  List-Styles-In-Use.doc
Sub StylesInUse()

'Type 1 = Paragraph Style
'Type 2 = Character Style
'Type 3 = Table Style
'Type 4 = List Style


    Dim oStyle As Style
    Dim sStyle As String
    Dim actDoc As Document
    Dim newDoc As Document
    Dim sect As Section
    Dim rng As Range
    


If MsgBox("This macro lists all used styles of the current document in a new one!" & vbCrLf & vbCrLf & _
        "... Would you like to continue?", vbQuestion + vbYesNo, "Listing Styles in use") = vbNo Then
        Exit Sub
        End If
        
    
    If ActiveDocument.Content.Text = vbCr Then 'check contents of doc for more than a paragraph mark
    MsgBox "This is a blank document. Macro will exit!", vbCritical, "Blank Document"
    Exit Sub
    End If
    
    
    
    'Display wating message in status bar
    StatusBar = "Listing of Styles in use! Please wait! This may take some time." & _
    "Hit Ctrl-Break to interrupt."

    


    Set actDoc = ActiveDocument
    sName = actDoc.FullName
    Set newDoc = Documents.Add
    
 
 On Error Resume Next

    For Each oStyle In actDoc.Styles
        If oStyle.InUse And IsStyleInUseInDoc(oStyle, actDoc) Then
        
            With oStyle
                sStyle = sStyle & "Style: " & .NameLocal & vbCr
                sStyle = sStyle & "Font: " & .Font.Name & vbCr
                sStyle = sStyle & "Description: " & .Description & vbCr
                sStyle = sStyle & "Size: " & .Font.Size & vbCr
                sStyle = sStyle & "Type: " & .Type & vbCr & vbCr
            End With
            With newDoc.Range
                .Text = sStyle
                .Collapse wdCollapseEnd
                .MoveEnd wdCharacter, 1
            End With
        End If
    Next oStyle
    
    newDoc.Range.InsertBefore "List of styles used in Document: " & sName & vbCr
    newDoc.Range.Paragraphs(1).SpaceAfter = 18
    newDoc.Range.Paragraphs(1).Range.Font.Bold = True
    
    
    
    
        With newDoc
    
        'Insert info in header - change date format as you wish
        .PageSetup.TopMargin = CentimetersToPoints(4)
        .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
            "List of Styles in Use: " & sName & vbCr & _
            "Created by: " & Application.UserName & vbCr & _
            "Creation date: " & Format(Date, "MMMM d, yyyy")
            With newDoc.Range.Sections(1).Headers(wdHeaderFooterPrimary).Range.ParagraphFormat.Borders(wdBorderBottom)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
            End With
            newDoc.Range.Sections(1).Headers(wdHeaderFooterPrimary).Range.ParagraphFormat.Borders.DistanceFromBottom = 3
        End With



        'Insert info in footer
            Set sect = ActiveDocument.Sections(1)
            Set rng = sect.Footers(wdHeaderFooterPrimary).Range
            
            
                'rng.Collapse wdCollapseStart
                rng.Collapse wdCollapseEnd
                rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="NUMPAGES \* Arabic "
                rng.Collapse wdCollapseStart
                rng.Text = " of "
                rng.Collapse wdCollapseStart
                rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="PAGE \* Arabic"
                rng.Collapse wdCollapseStart
                rng.Text = vbTab & vbTab
                rng.Collapse wdCollapseStart
                rng.Text = "List of Styles"
                    With rng.ParagraphFormat.Borders(wdBorderTop)
                        .LineStyle = wdLineStyleSingle
                        .LineWidth = wdLineWidth050pt
                        .Color = wdColorAutomatic
                    End With

    
       
 End Sub
  


Function IsStyleInUseInDoc(ByVal oStyle As Style, ByVal oDoc As Document) As Boolean
    Dim oRange As Range
    Dim bReturn As Boolean


    bReturn = False
    For Each oRange In oDoc.StoryRanges
        If IsStyleInRange(oStyle, oRange) = True Then
            bReturn = True
        End If
    Next oRange
    IsStyleInUseInDoc = bReturn
End Function


Function IsStyleInRange(ByVal oStyle As Style, ByVal oRange As Range) As Boolean
    With oRange.Find
        .ClearFormatting
        .Style = oStyle
        .Forward = True
        .Format = True
        .Text = ""
        .Execute
    End With
    If oRange.Find.Found = True Then
        IsStyleInRange = True
    Else
        IsStyleInRange = False
    End If
End Function

Open in new window

Andreas HermleTeam leaderAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

dlc110161Commented:
I made just a few changes to the code to include the description of the type. I added a Select Case that translated the information hopefully the way you would like it in your new document.

Hope it helps.
Dawn Bleuel
Word MVP
Sub StylesInUse()

'Type 1 = Paragraph Style
'Type 2 = Character Style
'Type 3 = Table Style
'Type 4 = List Style


    Dim oStyle As Style
    Dim sStyle As String
    Dim actDoc As Document
    Dim newDoc As Document
    Dim sect As Section
    Dim rng As Range
    


If MsgBox("This macro lists all used styles of the current document in a new one!" & vbCrLf & vbCrLf & _
        "... Would you like to continue?", vbQuestion + vbYesNo, "Listing Styles in use") = vbNo Then
        Exit Sub
        End If
        
    
    If ActiveDocument.Content.Text = vbCr Then 'check contents of doc for more than a paragraph mark
    MsgBox "This is a blank document. Macro will exit!", vbCritical, "Blank Document"
    Exit Sub
    End If
    
    
    
    'Display wating message in status bar
    StatusBar = "Listing of Styles in use! Please wait! This may take some time." & _
    "Hit Ctrl-Break to interrupt."

    


    Set actDoc = ActiveDocument
    sName = actDoc.FullName
    Set newDoc = Documents.Add
    
 
 On Error Resume Next

    For Each oStyle In actDoc.Styles
        If oStyle.InUse And IsStyleInUseInDoc(oStyle, actDoc) Then
        
            With oStyle
                sStyle = sStyle & "Style: " & .NameLocal & vbCr
                sStyle = sStyle & "Font: " & .Font.Name & vbCr
                sStyle = sStyle & "Description: " & .Description & vbCr
                sStyle = sStyle & "Size: " & .Font.Size & vbCr
                sStyle = sStyle & "Type: " & .Type
                Select Case .Type
                    Case 1
                        sStyle = sStyle & " = Paragraph" & vbCr & vbCr
                    Case 2
                        sStyle = sStyle & " = Character" & vbCr & vbCr
                    Case 3
                        sStyle = sStyle & " = Table" & vbCr & vbCr
                    Case 4
                        sStyle = sStyle & " = List" & vbCr & vbCr
                End Select
            End With
            With newDoc.Range
                .Text = sStyle
                .Collapse wdCollapseEnd
                .MoveEnd wdCharacter, 1
            End With
        End If
    Next oStyle
    
    newDoc.Range.InsertBefore "List of styles used in Document: " & sName & vbCr
    newDoc.Range.Paragraphs(1).SpaceAfter = 18
    newDoc.Range.Paragraphs(1).Range.Font.Bold = True
    
    
    
    
        With newDoc
    
        'Insert info in header - change date format as you wish
        .PageSetup.TopMargin = CentimetersToPoints(4)
        .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
            "List of Styles in Use: " & sName & vbCr & _
            "Created by: " & Application.UserName & vbCr & _
            "Creation date: " & Format(Date, "MMMM d, yyyy")
            With newDoc.Range.Sections(1).Headers(wdHeaderFooterPrimary).Range.ParagraphFormat.Borders(wdBorderBottom)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
            End With
            newDoc.Range.Sections(1).Headers(wdHeaderFooterPrimary).Range.ParagraphFormat.Borders.DistanceFromBottom = 3
        End With



        'Insert info in footer
            Set sect = ActiveDocument.Sections(1)
            Set rng = sect.Footers(wdHeaderFooterPrimary).Range
            
            
                'rng.Collapse wdCollapseStart
                rng.Collapse wdCollapseEnd
                rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="NUMPAGES \* Arabic "
                rng.Collapse wdCollapseStart
                rng.Text = " of "
                rng.Collapse wdCollapseStart
                rng.Fields.Add rng, Type:=wdFieldEmpty, Text:="PAGE \* Arabic"
                rng.Collapse wdCollapseStart
                rng.Text = vbTab & vbTab
                rng.Collapse wdCollapseStart
                rng.Text = "List of Styles"
                    With rng.ParagraphFormat.Borders(wdBorderTop)
                        .LineStyle = wdLineStyleSingle
                        .LineWidth = wdLineWidth050pt
                        .Color = wdColorAutomatic
                    End With

    
       
 End Sub
Function IsStyleInUseInDoc(ByVal oStyle As Style, ByVal oDoc As Document) As Boolean
    Dim oRange As Range
    Dim bReturn As Boolean


    bReturn = False
    For Each oRange In oDoc.StoryRanges
        If IsStyleInRange(oStyle, oRange) = True Then
            bReturn = True
        End If
    Next oRange
    IsStyleInUseInDoc = bReturn
End Function
Function IsStyleInRange(ByVal oStyle As Style, ByVal oRange As Range) As Boolean
    With oRange.Find
        .ClearFormatting
        .Style = oStyle
        .Forward = True
        .Format = True
        .Text = ""
        .Execute
    End With
    If oRange.Find.Found = True Then
        IsStyleInRange = True
    Else
        IsStyleInRange = False
    End If
End Function

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Andreas HermleTeam leaderAuthor Commented:
Hi Dawn,

great job. Exactly what I wanted. Thank you very much for your great support

Regards, Andreas
dlc110161Commented:
Excellent! I'm glad to have helped you!

Dawn Bleuel
Word MVP
JohnRobinAllenRetired professor of FrenchCommented:
Brief additional comment:
     The routine is very useful. Thanks very much for posting it.

One brief additional comment:
     I always have "Option Explicit" at the top of my code as a spell checker in case I misspell a variable or a subroutine. However, Option Explict prevents the code as presented above from running unless one adds
     Dim sName As String
at the top of the code (or else one deletes "Options Explicit").

I'm most grateful this code was posted. Thanks again!

John Robin Allen in Priddis, Alberta
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Word

From novice to tech pro — start learning today.