List all "Styles Used"

[StevenM at dot]

It appears that if one searches the styles collection of a document, such as:

Dim oStyle As Style
Dim actDoc As Document
Set actDoc = ActiveDocument
For Each oStyle In actDoc.Styles
If oStyle.InUse Then

The result would be:
(1) all the user defined styles available to the document;
(2) the Default Paragraph Font & Normal; and
(3) all the other styles once used in the document.

The question then is how can one determine which styles actually are being
used within the document?

I came up with the following code:

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

And it appears to work for the main body of a document, but I can’t seem to
get it to work with headers (and I haven’t tried footers, or endnotes).

I wonder if someone would be willing to look at the following code. It adds
the word “Title” to a document’s header. Then it calls a (modified)
“IsStyleInRange” twice. The first time the msgbox returns: “True,” but the
second time “False,” why is that?

Sub TestIsStyleInRange()
Dim oRange As Range
Dim oStyle As Style
Dim headerRange As Range

Set oRange = ActiveDocument.Range(Start:=ActiveDocument.Range.Start,
End:=ActiveDocument.Range.End)
Set headerRange = oRange.Sections(1).Headers(wdHeaderFooterPrimary).Range
Set oStyle = headerRange.Style
With headerRange
.Delete
.InsertAfter "Title"
End With
Application.ScreenRefresh
Call IsStyleInRange(oStyle, headerRange)
Set headerRange = Nothing
Set headerRange = oRange.Sections(1).Headers(wdHeaderFooterPrimary).Range
Call IsStyleInRange(oStyle, headerRange)
End Sub

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
'The next bit is for debugging purposes only
If oStyle = "Header" And InStr(1, oRange, "Title") > 0 Then
MsgBox "The Style We're Looking for is: " & oStyle & vbCr _
& "The Style of the Range is: " & oRange.Style & vbCr _
& "Result is: " & IsStyleInRange
End If
End Function

Steven Craig Miller

[StevenM at dot]

I figured it out. I needed a the statement:
oRange.Collapse Direction:=wdCollapseStart
Before:
With oRange.Find

[Ken]

I had a similar need to count style usage and I ended up with the code
below. This scans all paragraphs including headers, footers,
footnotes, endnotes and text boxes.
You will notice that in headers and footers I scan by words as there
were problems scanning by paragraph (I forget why as I coded this a
couple of years ago).
The result is a table showing a count of usage against each style -
very useful in showing up "orphan" styles.
Although slower than your method that uses Find, even on large
documents it is fast enough in Word2003 but terribly slow in W2007.

For Each apara In ActiveDocument.Paragraphs
count_styles_used (apara.Style)
Next apara

For Each asection In ActiveDocument.Sections
' ********* Check footers ************************
For Each aheader In aSection.Headers
If aheader.Range.Text <> vbCr Then
For Each w In aheader.Range.Words
count_styles_used (w.Style)
Next w
End If
Next aheader
' ********* Check footers ******************
For Each afooter In aSection.Footers
If afooter.Range.Text <> vbCr Then
For Each w In afooter.Range.Words
count_styles_used (w.Style)
Next w
End If
Next afooter
Next asection

' ********* Check footnotes ***************
For Each aFootnote In ActiveDocument.Footnotes
If aFootnote.Range.Text <> vbCr Then ' not blank with only
return char
For Each apara In aFootnote.Range.Paragraphs
count_styles_used (apara.Style)
Next apara
End If
Next aFootnote

' ********* Check endnotes ***************
For Each aEndnote In ActiveDocument.Endnotes
If aEndnote.Range.Text <> vbCr Then ' not blank with only
return char
For Each apara In aEndnote.Range.Paragraphs
count_styles_used (apara.Style)
Next apara
End If
Next aEndnote

' *************** text boxes *********************
For Each shp In ActiveDocument.Shapes
With shp.TextFrame
If .HasText Then
.TextRange.Select
tpSw = True
For Each tP In .TextRange.Paragraphs
tP.Range.Select
count_styles_used (tP.Style)
Next tP
End If
End With
Next shp

Ken

[StevenM at dot]

To: Ken,

What I eventually came up with was:

Sub ListStylesInUse()
Dim oStyle As Style
Dim sStyle As String
Dim actDoc As Document
Dim newDoc As Document

Set actDoc = ActiveDocument
Set newDoc = Documents.Add

For Each oStyle In actDoc.Styles
If oStyle.InUse Then

If IsStyleInUseInDoc(oStyle, actDoc) Then
With oStyle
sStyle = sStyle & "Style: " & .NameLocal & vbCr
sStyle = sStyle & "Font: " & .Font.Name & vbCr
sStyle = sStyle & "Size: " & .Font.Size & vbCr & vbCr
End With
With newDoc.Range
.Text = sStyle
.Collapse wdCollapseEnd
.MoveEnd wdCharacter, 1
End With
End If
End If
Next oStyle
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
Do While Not (oRange.NextStoryRange Is Nothing)
Set oRange = oRange.NextStoryRange
If IsStyleInRange(oStyle, oRange) = True Then
bReturn = True
End If
Loop
Next oRange
IsStyleInUseInDoc = bReturn
End Function

Function IsStyleInRange(ByVal oStyle As Style, ByVal oRange As Range) As
Boolean

oRange.Collapse Direction:=wdCollapseStart

With oRange.Find
.ClearFormatting
.Style = oStyle
.Forward = True
.Format = True
.Text = ""
.Execute
End With

IsStyleInRange = oRange.Find.Found

[Ken]

Your elegant code prompted me to re-write my application. Building on
your code and including a count of the number of occurrences of each
style, I came up with the code below.

However, there is still a problem with headers and footers. If there
is only one paragraph in the header or footer then it is not counted.
But if there are two or more paragraphs then the correct number are
counted.

Sub ListStylesInUse()
Dim oStyle As Style
Dim sStyle As String
Dim actDoc As Document
Dim newDoc As Document

Dim useCount As Long

Set actDoc = ActiveDocument
Set newDoc = Documents.Add

For Each oStyle In actDoc.Styles
If oStyle.InUse Then

useCount = IsStyleInUseInDoc(oStyle, actDoc)
If useCount > 0 Then

With oStyle
sStyle = sStyle & "Style: " & .NameLocal & vbCr
sStyle = sStyle & "Font: " & .Font.Name & vbCr
sStyle = sStyle & "Size: " & .Font.Size & vbCr

sStyle = sStyle & "Occurrences: " & useCount &

vbCr & vbCr
End With
With newDoc.Range
.Text = sStyle
.Collapse wdCollapseEnd
.MoveEnd wdCharacter, 1
End With
End If
End If
Next oStyle
End Sub

Function IsStyleInUseInDoc(ByVal oStyle As Style, ByVal oDoc As

Document) As Long
Dim oRange As Range
Dim sRange As Range
Dim useCount As Long
useCount = 0

For Each oRange In oDoc.StoryRanges

Set sRange = oRange
useCount = useCount + IsStyleInRange(oStyle, oRange)

Do While Not (oRange.NextStoryRange Is Nothing)
Set oRange = oRange.NextStoryRange

useCount = useCount + IsStyleInRange(oStyle, oRange)
Loop
Next oRange
IsStyleInUseInDoc = useCount
End Function

Function IsStyleInRange(ByVal oStyle As Style, ByVal oRange As Range)

As Long
Dim foundSw As Boolean
Dim sCount As Long
sCount = 0
Do

With oRange.Find
.ClearFormatting
.Style = oStyle
.Forward = True
.Format = True

.Wrap = wdFindStop
.Execute
foundSw = .Found
End With
If foundSw Then sCount = sCount + 1
Loop Until Not foundSw
IsStyleInRange = sCount
End Function

Ken

[StevenM at dot]

To: Ken,

<< If there is only one paragraph in the header or footer then it is not
counted. But if there are two or more paragraphs then the correct number are
counted. >>

I found the same thing to be true, but I couldn't figure out the "why." I
stepped through the code and watched it not find the header that was clearly
there. So I came up the the following work around.

As you can see, all I did was take my old code and your new code and worked
them together (with a few small modifications).

If I have time later, perhaps I'll take another look at it and see if I can
find a cleaner solution. Or perhaps you will find it first.

Steven Craig Miller

Sub CountStylesInDoc()

Dim oStyle As Style
Dim sStyle As String
Dim actDoc As Document
Dim newDoc As Document

Dim nCount As Long

Set actDoc = ActiveDocument
Set newDoc = Documents.Add

For Each oStyle In actDoc.Styles
If oStyle.InUse Then

If IsStyleInUseInDoc(oStyle, actDoc) Then
nCount = CountStylesInDoc(oStyle, actDoc)
If nCount = 0 Then nCount = 1

With oStyle
sStyle = sStyle & "Style: " & .NameLocal & vbCr
sStyle = sStyle & "Font: " & .Font.Name & vbCr
sStyle = sStyle & "Size: " & .Font.Size & vbCr

sStyle = sStyle & "Occurrences: " & nCount & vbCr & vbCr

End With
With newDoc.Range
.Text = sStyle
.Collapse wdCollapseEnd
.MoveEnd wdCharacter, 1
End With
End If
End If
Next oStyle
End Sub

Function CountStylesInDoc(ByVal oStyle As Style, ByVal oDoc As Document) As

Long
Dim oRange As Range

Dim nCount As Long
nCount = 0

For Each oRange In oDoc.StoryRanges

nCount = nCount + CountStylesInRange(oStyle, oRange)

Do While Not (oRange.NextStoryRange Is Nothing)
Set oRange = oRange.NextStoryRange

nCount = nCount + CountStylesInRange(oStyle, oRange)
Loop
Next oRange
CountStylesInDoc = nCount
End Function

Function CountStylesInRange(ByVal oStyle As Style, ByVal oRange As Range) As
Long
Dim bFound As Boolean
Dim nCount As Long
nCount = 0

Do
With oRange.Find
.ClearFormatting
.Style = oStyle
.Forward = True
.Format = True
.Wrap = wdFindStop
.Execute

bFound = .Found
End With
If bFound Then nCount = nCount + 1
Loop Until Not bFound
CountStylesInRange = nCount
End Function

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

Do While Not (oRange.NextStoryRange Is Nothing)
Set oRange = oRange.NextStoryRange

If IsStyleInRange(oStyle, oRange) = True Then
bReturn = True
End If

Loop
Next oRange
IsStyleInUseInDoc = bReturn
End Function

Function IsStyleInRange(ByVal oStyle As Style, ByVal oRange As Range) As

Boolean
oRange.Collapse Direction:=wdCollapseStart

With oRange.Find
.ClearFormatting
.Style = oStyle
.Forward = True
.Format = True

[StevenM at dot]

Ken,

Ignore my last message. I found the problem, I should have taken more time
and looked closer. It had to be something simple. When you modified my code,
it appears that you accidentally omitted the line:
oRange.Collapse Direction:=wdCollapseStart

The point of this line is to start the "Find" at the beginning of the range.
When this isn't done, it doesn't see the first paragraph in the header. I
also made a few minor modifications and came up with the following.

It also appears that with my modifications, the Style "Default Paragraph
Font" is a total of the counts of all styles.

Steven Craig Miller

Sub CountStyles()

Dim oStyle As Style
Dim sStyle As String
Dim actDoc As Document
Dim newDoc As Document

Dim nCount As Long

Set actDoc = ActiveDocument
Set newDoc = Documents.Add

For Each oStyle In actDoc.Styles
If oStyle.InUse Then

nCount = CountStylesInDoc(oStyle, actDoc)
If nCount > 0 Then

With oStyle
sStyle = sStyle & "Style: " & .NameLocal & vbCr
sStyle = sStyle & "Font: " & .Font.Name & vbCr
sStyle = sStyle & "Size: " & .Font.Size & vbCr

sStyle = sStyle & "Occurrences: " & nCount & vbCr & vbCr

End With
With newDoc.Range
.Text = sStyle
.Collapse wdCollapseEnd
.MoveEnd wdCharacter, 1
End With
End If
End If
Next oStyle
End Sub

Function CountStylesInDoc(ByVal oStyle As Style, ByVal oDoc As Document) As

Long
Dim oRange As Range

Dim nCount As Long
nCount = 0

For Each oRange In oDoc.StoryRanges

nCount = nCount + CountStylesInRange(oStyle, oRange)

Do While Not (oRange.NextStoryRange Is Nothing)
Set oRange = oRange.NextStoryRange

nCount = nCount + CountStylesInRange(oStyle, oRange)
Loop
Next oRange
CountStylesInDoc = nCount
End Function

Function CountStylesInRange(ByVal oStyle As Style, ByVal oRange As Range) As
Long

Dim nCount As Long
nCount = 0

oRange.Collapse Direction:=wdCollapseStart
With oRange.Find

Do

.ClearFormatting
.Style = oStyle
.Forward = True
.Format = True
.Wrap = wdFindStop
.Execute

If .Found Then nCount = nCount + 1
Loop Until Not .Found
End With

[Ken]

Steven

The code has some problems. If there is a table of contents or text
boxes (and probably some other things) then CountStylesInRange goes
into an endless loop. I added a test to exit the loop if Find has
reached the end of the StoryRange. This turned out to be harder than I
thought and although the code shown below works it is slow because of
the oRange.Select statement. There has to be a better way.

Stopping execution of an endless loop with Ctrl/Break caused VBA
problems that could only be fixed by re-booting XP. Excel macros are
also affected even when Word is closed. This problem does not seem to
happen with Vista.

To remove the need to use Ctrl/Break when testing I changed the
variable nCount to Integer so that an endless loop would eventually
overflow the variable and stop execution. This takes about 1 minute to
overflow with Word 2000 but 7 minutes with wretched Word 2007.

Also, I have written a version of the subroutine CountStyles that
displays the results in a message box rather than in a file. It would
be better to use a custom dialog box for this so that formatting can
be controlled

Sub CountStyles()
Dim oStyle As Style
Dim sStyle As String
Dim actDoc As Document

Dim nCount As Long
Dim st As String
Dim stNo As Integer
Set actDoc = ActiveDocument
st = ""
stNo = 0

For Each oStyle In actDoc.Styles
If oStyle.InUse Then
nCount = CountStylesInDoc(oStyle, actDoc)
If nCount > 0 Then

stNo = stNo + 1
If stNo > 12 Then
st = st & vbCr & "More..." & vbCr
MsgBox st
st = ""
stNo = 0
End If
With oStyle
st = st & .NameLocal & ": " & .Font.Name & _
" " & .Font.Size & " pt " & nCount & "
Occurrences" & vbCr

End With
End If
End If
Next oStyle

MsgBox st
End Sub
,,
,,
,,

Function CountStylesInRange(ByVal oStyle As Style, ByVal oRange As
Range) As Long

Dim nCount As Integer
Dim tRange As Range
Dim foundSW As Boolean
oRange.Select
Set tRange = Selection.Range
tRange.Collapse direction:=wdCollapseEnd
nCount = 0
oRange.Collapse direction:=wdCollapseStart

With oRange.Find
Do
.ClearFormatting
.Style = oStyle
.Forward = True
.Format = True
.Wrap = wdFindStop
.Execute

foundSW = .Found
If foundSW Then
oRange.Select

nCount = nCount + 1

oRange.Collapse direction:=wdCollapseEnd
If oRange.InRange(tRange) Then foundSW = False
End If
Loop Until Not foundSW

End With
CountStylesInRange = nCount
End Function

Ken

[StevenM at dot]

Ken,

Instead of:

oRange.Select
Set tRange = Selection.Range

You can use:

Set tRange = oRange.Duplicate

Another idea is to save the values of the start/end of a range as a long
number.

For example, you might add:

Dim nEnd as Long
Dim nStart as Long

And then save the value of the end of the range, such as:

nEnd = oRange.End

Then:
Do
With oRange.Find
...
nStart = oRange.Start
If (nStart + 1) = nEnd Then
Exit Do
End If
Loop Until Not bFound

Towards that end, see the function below.

Would like to move this discussion to e-mail? (Either way is fine with me.)
Would you be willing to send me that Word Document you are running your
tests upon? My e-mail is: stevencraigmiller(at)comcast(dot)net.

Steven Craig Miller

Function CountStylesInRange(ByVal oStyle As Style, ByVal oRange As Range) As
Long

Dim nCount As Long
Dim bFound As Boolean
Dim nEnd As Long
Dim nStart As Long

nCount = 0
nEnd = oRange.End
oRange.Collapse Direction:=wdCollapseStart
Do
With oRange.Find

.ClearFormatting
.Style = oStyle
.Forward = True
.Format = True
.Wrap = wdFindStop
.Execute

bFound = .Found
End With
If bFound Then

nCount = nCount + 1

' I'm unsure if the following line is needed.
' Namely: oRange.MoveEnd wdCharacter, 1
' Or what effect it might have.
' You might try it with and without.
oRange.MoveEnd wdCharacter, 1
oRange.Collapse Direction:=wdCollapseEnd
nStart = oRange.Start
End If
If (nStart + 1) = nEnd Then
Exit Do
End If
Loop Until Not bFound

[Ken]

Steven

Your suggested changes overcame the need to select text. However, the
code still runs very very slowly on large documents. It turns out that
Word repaginates every time around the outer loop. Therefore, I have
re-written the code to that below. This new code runs very fast on a
130 page test document.

The results are not exactly the same. Your code counts a style for
header and footer if there is no text in the header or footer whereas
my code does not. On the other hand, my code counts the style in blank
table cells whereas yours ignores blank cells. Also, my code detected
the style FollowedHyperlink.

Dim styleNo As Integer
Dim StyleName()
Dim StyleCount()
Dim StyleText()

Sub ShowStyleCounts()
Dim oRange As Range
Dim oPara As Paragraph
styleNo = -1
ReDim StyleName(1)
ReDim StyleCount(1)
ReDim StyleText(1)
For Each oRange In ActiveDocument.StoryRanges
For Each oPara In oRange.Paragraphs
AccumulateStyleCount (oPara.Style)
Next oPara
Next oRange
DisplayStyleCounts
End Sub

Sub AccumulateStyleCount(tStyle As Style)
Dim i As Integer
For i = 0 To styleNo
If StyleName(i) = tStyle Then
StyleCount(i) = StyleCount(i) + 1
Exit Sub
End If
Next i
styleNo = styleNo + 1
ReDim Preserve StyleName(styleNo)
StyleName(styleNo) = tStyle
ReDim Preserve StyleText(styleNo)
StyleText(styleNo) = " " & tStyle.Font.Name & " " &
tStyle.Font.Size & " pt"
ReDim Preserve StyleCount(styleNo)
StyleCount(styleNo) = 1
End Sub

Sub DisplayStyleCounts()
Dim st As String
Dim i As Integer
Dim n As Integer
st = ""
n = 0
For i = 0 To styleNo
If StyleCount(i) > 0 Then
n = n + 1
If n > 20 Then

st = st & vbCr & "More..." & vbCr
MsgBox st
st = ""

n = 0
End If
st = st & StyleCount(i) & ": " & StyleName(i) & StyleText(i) &
vbCr
End If
Next i
MsgBox st
End Sub

Ken

[StevenM at dot]

To: Ken,

I'm impressed! Of course, your solution only finds paragraph styles and not
character styles, but perhaps that wasn't an issue you needed to address.

Steven Craig Miller

[prhm...@gmail.com]

I know this is over 4 years old, but does anyone have any code for finding character styles and paragraph styles in a single macro?

Paul Hanson
prhm...@hotmail.com

On Sunday, June 1, 2008 6:56:01 AM UTC-5, StevenM wrote:
> To: Ken,
>
> I&#39;m impressed! Of course, your solution only finds paragraph styles and not
> character styles, but perhaps that wasn&#39;t an issue you needed to address.
>
> Steven Craig Miller

[Stefan Blom]

See if you find
http://gregmaxey.mvps.org/word_tip_pages/style_report_addin.html helpful.

Stefan Blom
Microsoft Word MVP

[Jennifer Klyse]

Hi all. Talk about re-visiting an old thread! Is there an updated version of this code that will work in Word 365, by chance?

--
This e-mail message is intended only for the use of the recipient(s) named
above and may contain information that is privileged or confidential. If
you received this transmission in error, please notify the sender by reply
e-mail and delete the message and any attachments. If you are not an
intended recipient, you may not review, copy or distribute this message.