#1
|
|||
|
|||
Macro to list all character styles in a document
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 |
#2
|
||||
|
||||
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 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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
Perfect, thank you very much
That is exactly what I was looking for. Thank you very much for your help.
|
#4
|
|||
|
|||
Maybe not so perfect..
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 |
#5
|
||||
|
||||
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 Code:
Select Case .InUse Case False: StrAttr = StrAttr & "N" Case Else: StrAttr = StrAttr & StyleInUse(ActiveDocument, Sty) End Select 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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#6
|
|||
|
|||
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 |
#7
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#8
|
|||
|
|||
@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. |
#9
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
|
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 |