G'day "ChrisC" <
[email protected]>,
Hmmmm - they've been posted a few times yet I cant google em. Here it
is again. Enjoy.
REPOST
___________________________________________________________-
The Long Awaited Heretical List Fixes
=====================================
This needs lot of work!!!!
Here be a long mess of code. If you haven't learnt about VBA, see the
so named tab on the index of this site for easy tutorials to get you
started. However, this is the equivalent to the deep end of the Word
pool so tread water lightly - somewhat like this metaphor.
It is not perfect, but it is an excellent start. Some of the uses are
not so intuitive, for example, before you do ANY operation that
inviolably screws up list numbering - just convert to text and convert
back. Outline numbered lists can be dealt with via an extension of the
provided code which I am sure someone will be good enough to provide
at some future date but which looks at the number of tabs or indent
settings and sets the list level accordingly.
You should always run the report on your styles first, and ensure they
are set correctly in your templates. Once this is done, you can run
riot with updating styles with a find n replace and using restart
lists after headings to fix up restart points.
The key thing to note is that it is a lot easier to customize some
existing VBA to solve these problems than it is to provide a generic
tool to generically solve all the problems. Don't worry about all
permutations, just worry about the stuff that's in front of you, make
this code fit it and solve your headaches.
OneStyle was to be the key to whether you used a single style for your
outline list levels, or multiple. If just one style, then this should
be true and things should sorta work as I planned.
Bar is commented out - it is in heretic.dot and is just a simple
progress bar that's badly implemented by the above. I really should
check for display alerts to allow simple signalling of whether to can
the UI.
I use this as a class object, but there is little stopping you from
using it as a code module if you want to clutter your interface all
the time. Just insert my extracts at the end in after the code in the
same object, I removed all references to them for you already (I
hope!). If you would prefer me to tailor this up for you as a
commercial service, you can contact me at the email address below.
There's an awful lot of code here, with an awful lot of time put into
this - that's years kids. If you extend it any direction I would love
to hear from you. I keep the copyright on it, but have given
permission for Word MVPs to distribute it from their website. You may
not include this code, or derivatives of it, in any commercial
software without my permission. If you wish to distribute modified
copies for free to over 500 people, you will also need to contact me
for permission.
(e-mail address removed)
__ Global constants, best off in their own code mod ___
#If VBA6 Then
Public Enum hitListTemplateLoc
hitListTemplatesInListGalleries = 1
hitListTemplatesInDocument = 2
End Enum
#Else
Public Const hitListTemplatesInListGalleries As Long = 1
Public Const hitListTemplatesInDocument As Long = 2
#End If
______________ End of Global constants ________________
__________ Object ListFix from Stylist.dot ____________
Option Explicit
' $Version: 0.8.3
' $Author: Steve Hudson,
www.wordheretic.com
' $Short: Fixes and utils for auto-lists
' 2do: convert hard -> auto needs scope
' check tabbing on indented styles
' break into activedocument and listgallery listemplate
treatments
' cross convert multi-styled lists to single-styled
' do a user-defined list template variable. to carry stuff
in.
'$Customize:
Private Const defOneStyle As Boolean = True 'Not fully implemented yet
Private Const defListTemplateHome As Long = 2 'See Constants
'$Leave:
Private MyListStyles() As String
Private OneStyle As Boolean
Private LTHome As hitListTemplateLoc
'Private Bar As ProgressBar
Property Get ListTemplateHome() As hitListTemplateLoc
ListTemplateHome = LTHome
End Property
Property Let ListTemplateHome(Whereabouts As hitListTemplateLoc)
LTHome = Whereabouts
End Property
Property Get OneStylePerOutlineList() As Boolean
OneStylePerOutlineList = OneStyle
End Property
Property Let OneStylePerOutlineList(aFlag As Boolean)
OneStyle = aFlag
End Property
Private Sub Class_Initialize()
OneStyle = defOneStyle
LTHome = defListTemplateHome
'Set Bar = GetNewProgressBar
'$Customize:
ReDim MyListStyles(4) As String
MyListStyles(1) = "Body Text"
MyListStyles(2) = "List Bullet"
MyListStyles(3) = "List Number"
MyListStyles(4) = "List Number Outline"
End Sub
Public Sub ReportListStyles(Optional Scope As Document)
'$Author
www.wordheretic.com
'$Short Run this procedure first to make sure the styles in use for
lists
' are what they are supposed to be
Dim flStyleName As New Collection
Dim flStyleGallery As New Collection
Dim flListTemplate As New Collection
Dim flListLevel As New Collection
Dim ThisStyle As Long
GetListStyleNames flStyleName, flStyleGallery, flListTemplate,
flListLevel, Scope
Documents.Add
With Selection
.InsertAfter "StyleName" & vbTab & "Gallery" & vbTab &
"ListTemplate" & vbTab & "Listlevel"
.Style = wdStyleHeading4
.InsertParagraphAfter
.Collapse wdCollapseEnd
For ThisStyle = 1 To flStyleName.Count
If LTHome = hitListTemplatesInDocument Then
.InsertAfter flStyleName(ThisStyle) & vbTab &
flStyleGallery(ThisStyle) & vbTab & flListTemplate(ThisStyle) & vbTab
& flListLevel(ThisStyle)
Else
.InsertAfter flStyleName(ThisStyle) & vbTab &
GalleryNum2Name(flStyleGallery(ThisStyle)) & vbTab &
flListTemplate(ThisStyle) & vbTab & flListLevel(ThisStyle)
End If
.InsertParagraphAfter
Next
ActiveDocument.Content.Select
.ConvertToTable wdSeparateByTabs
End With
Set flStyleName = Nothing
Set flStyleGallery = Nothing
Set flListTemplate = Nothing
Set flListLevel = Nothing
End Sub
Public Sub FixStyledLists()
'$Author:
www.wordheretic.com
'$Short: Run the style list reporter before running this to
' ensure all your styles are set up correctly
' Blows away restarts so needs a pre-check
' or just use RestartListsAfterHeadings
Dim Para As Paragraph
Dim ListLevel As Long
Dim StyleNames As New Collection
Dim StyleGalleries As New Collection
Dim ListTemplates As New Collection
Dim ListLevels As New Collection
Dim Style As Variant
Dim pholder_Selection As Range
Dim RestartNumbering As Boolean
'Numerous problems.
'List style may not have a LT with the stylename in the linked list
'Does a list style have a LT attached
'Is a style with a listtemplate a list style?
Set pholder_Selection = Selection.Range
StyleNameCleanup
Application.ScreenUpdating = False
Options.Pagination = False
'All I want is style names here
GetListStyleNames StyleNames, StyleGalleries, ListTemplates,
ListLevels, ActiveDocument
Set StyleGalleries = Nothing
Set ListTemplates = Nothing
Set ListLevels = Nothing
'Bar.Caption = "Fixing Styled lists"
'Bar.Iterations = ActiveDocument.Paragraphs.Count
'Bar.Show
'reapply list style definitions
For Each Para In ActiveDocument.Paragraphs
With Para
If InCollection(Para.Style, StyleNames) Then 'its a list
Restart = IsRestart(.Range.ListFormat)
ListLevel = .Range.ListFormat.ListLevelNumber
'Heres the real 'magic'
'Just reapply the style. It has the correct list template
stuff and re-applying
'it just forces Word to re-accept the correct list template!
.Style = ActiveDocument.Styles(Para.Style)
.Range.ListFormat.ListLevelNumber = ListLevel
If Restart Then .Range.ListFormat.CanContinuePreviousList =
wdResetList
Else
'just in case there is some spurious list template attached
'FRIGGIN KILL IT!!!
.Range.ListFormat.RemoveNumbers
End If
End With
' Bar.Update
Next
'Bar.Hide
Set StyleNames = Nothing
Set Para = Nothing
Application.ScreenUpdating = True
Options.Pagination = True
pholder_Selection.Select
ViewSelection
End Sub
Public Function IsRestart(aListFormat As ListFormat) As Boolean
'$Author:
www.wordheretic.com
'$Short: Why bother ignoring indented listlevels if you can fix their
' restarting as well
With aListFormat
IsRestart = (.ListValue = 1) _
And (.ListType = wdListSimpleNumbering _
Or .ListType = wdListOutlineNumbering _
Or .ListType = wdListMixedNumbering)
End With
End Function
Public Sub FixRestarts(Optional Scope As Range)
'$Author:
www.wordheretic.com
'$Short: This fixes lists that restart with some crazy number
' but the rest of the list is fine.
Dim ListPara As Paragraph
If Scope Is Nothing Then Set Scope = ActiveDocument.Content
If Scope.ListParagraphs.Count > 1 Then
For Each ListPara In Scope.ListParagraphs
With ListPara.Range.ListFormat
If .ListValue = 1 Then
ListPara.Style = Scope.Parent.Styles(ListPara.Style)
.ApplyListTemplate .ListTemplate, False
End If
End With
Next
End If
End Sub
Private Sub GetListStyleNames(aName As Collection, aGallery As
Collection, _
aListTemplate As Collection, aListLevel As Collection, Optional
Scope As Document)
'$Author
www.wordheretic.com
'$Short Reports on the list templates available. Depending on what
the global property
' LTHome is set to, the object responds with document based
lists or gallery based
' lists.
Select Case LTHome
Case hitListTemplatesInListGalleries
Dim ListGallery As Long
For ListGallery = 1 To 3 'bullets, numbers, outlines
GetListStylesInListGallery ListGallery, aName, aGallery,
aListTemplate, aListLevel
Next
Case hitListTemplatesInDocument
Dim LT As Long
Dim LL As Long
Dim StyleName As String
If Scope Is Nothing Then Set Scope = ActiveDocument
With Scope
If .ListTemplates.Count > 0 Then
For LT = 1 To .ListTemplates.Count
With .ListTemplates(LT)
For LL = 1 To .ListLevels.Count
StyleName = .ListLevels(LL).LinkedStyle
If Len(StyleName) > 0 Then
aName.Add StyleName
aGallery.Add Scope.Name
aListTemplate.Add LT
aListLevel.Add LL
End If
Next
End With 'LT
Next
End If 'no list templates
End With 'ACTDOC
End Select
End Sub
Private Sub GetListStylesInListGallery(BNGallery As WdListGalleryType,
aName As Collection, aGallery As Collection, aListTemplate As
Collection, aListLevel As Collection)
'$Author
www.wordheretic.com
'$Short Tells what styles can be found in the lists hanging off the
list gallery
' for those folk that excusively use the Word facade for
setting up lists.
Dim LT As Long
Dim LL As Long
Dim LinkedStyle As String
With ListGalleries(BNGallery)
For LT = 1 To .ListTemplates.Count
With .ListTemplates(LT)
For LL = 1 To .ListLevels.Count
LinkedStyle = .ListLevels(LL).LinkedStyle
If Len(LinkedStyle) > 0 Then 'there is a linked style
aName.Add LinkedStyle
aGallery.Add BNGallery
aListTemplate.Add LT
aListLevel.Add LL
End If
Next
End With
Next
End With
End Sub
Private Function GalleryNum2Name(GalleryNumber As WdListGalleryType)
As String
'$Author
www.wordheretic.com
'$Short Stuff like this would have been my definition of user
friendly thanks MS
Select Case GalleryNumber
Case wdBulletGallery
GalleryNum2Name = "Bullet"
Case wdNumberGallery
GalleryNum2Name = "Number"
Case wdOutlineNumberGallery
GalleryNum2Name = "Outline"
End Select
End Function
Public Sub RestartListsAfterHeadings()
'$Author
www.wordheretic.com
'$Short This is it, the real McCoy. 99% of the time in the real world
this
' sucker solves all list-related problems. It can cause a
fracturing
' that then requires the complimentary FixRestarts to overcome.
Dim Para As Paragraph
Dim theListType As Long
Dim theListLevel As Long
Dim Names As New Collection
Dim RestartNext() As Boolean
Dim k As Long
Dim Index As Long
GetNumberedListStyleNames Names
Set Galleries = Nothing
Set ListTemplates = Nothing
Set ListLevels = Nothing
ReDim RestartNext(Names.Count) 'This holds our restart flags for each
list style
Application.ScreenUpdating = False
Options.Pagination = False
With ActiveDocument
' Bar.Caption = "Restarting lists after headings"
' Bar.Iterations = .Paragraphs.Count
' Bar.Show
For Each Para In .Paragraphs
With Para
If .OutlineLevel < wdOutlineLevelBodyText Then 'heading, so
reset restart flags
For k = 1 To UBound(RestartNext)
RestartNext(k) = True
Next
Else 'body text level
Index = CollectionIndex(.Style, Names)
If Index > 0 And RestartNext(Index) Then 'restart
With .Range.ListFormat
If .ListTemplate Is Nothing Then Para.Style =
ActiveDocument.Styles(Para.Style)
theListLevel = .ListLevelNumber
.ApplyListTemplate .ListTemplate, False,
wdListApplyToWholeList
.ListLevelNumber = theListLevel
RestartNext(Index) = False
End With
End If 'restart
End If 'heading level
End With 'para
' Bar.Update
Next Para
' Bar.Hide
Application.ScreenUpdating = True
Options.Pagination = True
.Repaginate
End With
Set Names = Nothing
'ErrHandler:
'If Err.Number > 0 Then ' we have an error
' If Err.Number = 5 Then
' FixStyledLists
' Resume
' End If
'End If
End Sub
Public Sub ConvertHardCoded2Styles()
'$Author
www.wordheretic.com
'$Short Doesn't attempt to address outline numbered lists
' but is still a treat to say the least. Turns hardcoded
numbers
' such as those produced by the convertnumberstotext method
back into
' OOOOOO - styled lists! You nominate the list names of course
to keep it simple
' Easily extandable to many available options.
Const NumberStyle As String = "List Number"
Const BulletStyle As String = "List Bullet"
Dim CharPos As Long
Dim Para As Paragraph
Dim BulletChars As String
Dim FirstChar As String * 1
BulletChars = "." & "*" & "-" & Chr$(176) & ChrW$(61623) &
ChrW$(61607) & ChrW$(61608) & ChrW$(61609) & ChrW$(61610) &
ChrW$(61528) & ChrW$(61529) & ChrW$(61556) & ChrW$(61557) &
ChrW$(61558) & ChrW$(61559) & ChrW$(61562) & ChrW$(8224) & ChrW$(8225)
& ChrW$(9679)
With ActiveDocument
' Bar.Caption = "Converting hard-coded numbers to styles"
' Bar.Iterations = .Paragraphs.Count
' Bar.Show
For Each Para In .Paragraphs
With Para
FirstChar = Left$(.Range.Text, 1)
If StrConv(FirstChar, vbUnicode) = Format(Val(FirstChar))
Then 'number!
.Style = NumberStyle
StripStartOfPara Para
ElseIf InStr(1, BulletChars, FirstChar) Then
.Style = BulletStyle
StripStartOfPara Para
End If
End With
' Bar.Update
Next Para
End With
'Bar.Hide
End Sub
Private Sub StripStartOfPara(aPara As Paragraph)
'$Author
www.wordheretic.com
'$Short Strips white space from a para start
' This is how I ignore outline numbered lists
' when converting hardcoded to auto
Dim FirstChar As String
Dim Safety As Long
Dim KeepGoing As Boolean
KeepGoing = True
With aPara.Range
While Not iSAlpha(.Characters(1)) And KeepGoing
Safety = .Characters.Count
.Characters(1).Delete
KeepGoing = (Safety <> .Characters.Count)
Wend
End With
Set StringHandler = Nothing
End Sub
Public Sub ConvertAuto2HardCoded()
'$Author
www.wordheretic.com
'$Short Just for completeness
ActiveDocument.ConvertNumbersToText
End Sub
Public Sub ResetListGalleries()
'$Author
www.wordheretic.com
'$Short Resets all list gallery positions. Useful for when
' lists are really screwed up.
Dim aListGallery As Long
For aListGallery = 1 To 3
ResetListGallery aListGallery
Next aListGallery
End Sub
Private Sub ResetListGallery(BNGallery As WdListGalleryType)
'$Author
www.wordheretic.com
'$Short Resets all of a list gallery's positions
Dim aListTemplate As Long
Dim aListLevel As ListLevel
With ListGalleries(BNGallery)
For aListTemplate = 1 To .ListTemplates.Count
.Reset aListTemplate
For Each aListLevel In .ListTemplates(aListTemplate).ListLevels
aListLevel.LinkedStyle = ""
Next
Next
End With
End Sub
Public Sub RestartListNumbering(Optional aRange As Variant)
'$Author
www.wordheretic.com
'$Short Resets a list's numbering EVERY time, unlike Word's facade
If aRange Is Nothing Then Set aRange = Selection.Range
aRange.Collapse
On Error Resume Next
With aRange.ListFormat
.ApplyListTemplate .ListTemplate, False
End With
End Sub
Public Sub ShowUsedListTemplates()
'$Author
www.wordheretic.com
'$Short Run this on a COPY of your document to see how
' badly mangled the lists are
Dim Index As Long
On Error Resume Next
With ActiveDocument
If .ListTemplates.Count > 0 Then
For Index = 1 To .ListTemplates.Count
With .ListTemplates(Index)
If Len(.Name) = 0 Then .Name = Format(Index)
End With
Next
' Bar.Caption = "Adding list debug information"
' Bar.Iterations = .ListParagraphs.Count
' Bar.Show
For Index = 1 To .ListParagraphs.Count
With .ListParagraphs(Index).Range
.InsertBefore "[" & .ListFormat.ListTemplate.Name & "]"
End With
' Bar.Update
Next Index
' Bar.Hide
End If ' no list templates
End With
End Sub
Public Sub CoalesceListStyles()
'$Author
www.wordheretic.com
'$Short Turns List Number 1, List Number 2, List Number 3...,
' into an outline numbered List Number style using just List
Number
' Does this using all the hard-coded list styles below
Dim ListStyle As Long
Dim Para As Paragraph
Dim StyleLevel As Long
'Bar.Caption = "Coalescing list styles"
'Bar.Iterations = ActiveDocument.Paragraphs.Count
'Bar.Show
For Each Para In ActiveDocument.Paragraphs
For ListStyle = 1 To UBound(MyListStyles)
If InStr(1, Para.Style, MyListStyles(ListStyle), vbTextCompare)
And _
Len(Para.Style) = Len(MyListStyles(ListStyle)) + 2 Then 'we
have a convert
StyleLevel = Val(Right$(Para.Style, 1))
Para.Style = MyListStyles(ListStyle)
While StyleLevel > 1
StyleLevel = StyleLevel - 1
Para.Indent
Wend
Exit For
End If
Next ListStyle
' Bar.Update
Next Para
'Bar.Hide
End Sub
Public Sub StripSeqFieldsInListStyles(Optional Scope As Range)
Dim iField As Long
Dim iStyle As Long
Dim FieldStyle As String
If Scope Is Nothing Then Scope = ActiveDocument.Content
With Scope
For iField = .Fields.Count To 1 Step -1
If .Fields(iField).Type = wdFieldSequence Then 'check for a
forbidden style
FieldStyle = .Fields(iField).Result.Style
For iStyle = 1 To UBound(MyListStyles)
If MyListStyles(iStyle) = FieldStyle Then
.Fields(iField).Delete
Exit For
End If
Next
End If
Next
End With
Set Scope = Nothing
End Sub
Public Function CopyDocListTemplatesInUse(InDoc As Document, OutDoc As
Document)
'$Teaser Read indoc for all styles in list templates
' if style not present in doc dont copy it
End Function
Private Sub Class_Terminate()
'Set Bar = Nothing
End Sub
___________________ End object ________________________
___________ Start Style Gallery Extract _______________
Public Sub StyleNameCleanup()
'$Author
www.wordheretic.com
'$Short removes the suffixes that stylenames can acquire
Dim aStyle As Style
Dim StartOfSuffix As Long
Dim OldName As String
Dim NewName As String
Dim Finder As Range
Const Gen As String = "Generic"
On Error Resume Next
aDoc.Styles.Add Gen, wdStyleTypeParagraph
On Error GoTo 0
For Each aStyle In aDoc.Styles
With aStyle
StartOfSuffix = InStr(1, .NameLocal, ",")
If StartOfSuffix > 0 Then
OldName = .NameLocal
NewName = Left$(.NameLocal, StartOfSuffix - 1)
'find and replace stylenames
Set Finder = ActiveDocument.StoryRanges(wdMainTextStory)
With Finder.Find
.Style = OldName
.Replacement.Style = Gen
.Execute Replace:=wdReplaceAll
End With
.NameLocal = NewName
With Finder.Find
.Style = Gen
.Replacement.Style = NewName
.Execute Replace:=wdReplaceAll
End With
End If
End With
Next
Set aStyle = Nothing
End Sub
________________ End Style Gallery Extract _________________________
_________________ Start Collector Extract __________________________
Public Function CollectionIndex(ByVal Needle As String, ByVal Haystack
As Collection) As Long
'$Author
www.wordheretic.com
'$Short Not all collections allow you to access the index by name.
If Haystack Is Nothing Then Exit Function
If Haystack.Count = 0 Then Exit Function
Dim Straw As Long
For Straw = 1 To Haystack.Count
If Needle = Haystack(Straw) Then
CollectionIndex = Straw
Exit For
End If
Next
End Function
Public Function InCollection(Needle As String, Haystack As Collection)
As Boolean
'$Author
www.wordheretic.com
'$Short Well, do we have a Needle in our Haystack or not?
'$2do replace this with CollectionIndex
Dim Straw As Variant
If Not (Haystack Is Nothing) Then
If Haystack.Count > 0 Then
For Each Straw In Haystack
If Straw = Needle Then
InCollection = True
Exit For
End If
Next
End If
End If
Set Straw = Nothing
End Function
__________________ End Collector Extract ___________________________
_______________ Misc Extracts _________________
Public Function IsAlpha(SomeText As String, Optional OtherLegalChars
As String = " ") As Boolean
'Allows only the alphanumeric and other defined legal characters
'Defaults to also allowing spaces.
Dim Index As Integer
Dim s As String * 1
For Index = 1 To Len(SomeText)
IsAlpha = False
s = Mid$(SomeText, Index, 1)
IsAlpha = IsCharAlphaNumeric(s)
If Not IsAlpha Then IsAlpha = (InStr(1, OtherLegalChars, s) > 0)
If Not IsAlpha Then Exit For
Next
Private Declare Function IsCharAlphaNumericA Lib "USER32" _
(ByVal aCharacter As Byte) As Long
Public Function IsCharAlphaNumeric(aCharacter As String) As Boolean
IsCharAlphaNumeric = CBool(IsCharAlphaNumericA(Asc(aCharacter)))
End Function
_______________ Misc Extracts _________________
Steve Hudson
Word Heretic, Sydney, Australia
ChrisC said:
Where - how can I get a copy of the 'free list fix macros.
Particularly RestartListsAfterHeadings'. Many thanks for
your reply and help. Renumbering does not work when the
file is closed then reopened - test & tested this - I like
the idea of your macro - I really don't want to waste too
much time on this...
Steve Hudson
Word Heretic, Sydney, Australia
Tricky stuff with Word or words for you.
Email (e-mail address removed)
Products
http://www.geocities.com/word_heretic/products.html
Replies offlist may require payment.
