atw: Re: Word Numbering Issues! Save my life, please!

  • From: "Steve Hudson" <cruddy@xxxxxxxxxxxxxxxx>
  • To: <austechwriter@xxxxxxxxxxxxx>
  • Date: Mon, 22 Sep 2003 21:52:35 +1000

I posted the macros here on their first release.

In a nutshell, Word's styles do not allow for the "Restart Numbering"
property. MS refuses to make it so. So we're basically screwed. Word Perfect
is fully compatible and does the job nicely. However, this doesn't help us
here right ;-)

If you have auto-update on, that restart property is manual formatting and
gets blown by the style redef from the auto thingy. Not good.

However, even WITH auto-updates off, your lists can still be in diabolical
trouble through naivette. Ce sera sera. So, rather than building enormously
complex tools to deal with every situation, I have released the code for a
set of macros I have been using for years in order to control my output so
that you can tailor them up for yourself.

At the end of the day, you have several options.

You can purchase my spellbooks and read up on lists. There are other,less
extensive sources as well.

You could pay me to create you beautiful raw style templates with your
desired numbering and a bunch of macros to enforce them. If you need urgent
help, +61 (0) 422233044.

The various sites have, for one reason or another, failed to post up my
macros despite their usage being not only in the thousands but also taught
at universities with my permission. <Shrugs> So, you can just twiddle with
these and get on with life in a basic fashion. Err, to answer that last
part - they are FREE. Customizing them is commercial, basic access is not


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

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 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 derivati
ves 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.


__ Global constants, best off in their own code mod ___

#If VBA6 Then

Public Enum hitListTemplateLoc
   hitListTemplatesInListGalleries = 1
   hitListTemplatesInDocument = 2
End Enum


Public Const hitListTemplatesInListGalleries  As Long = 1
Public Const hitListTemplatesInDocument As Long = 2

#End If

______________ End of Global constants ________________

__________ Object ListFix from ____________

Option Explicit

' $Version: 0.8.3
' $Author:  Steve Hudson,
' $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.


Private Const defOneStyle As Boolean = True 'Not fully implemented yet
Private Const defListTemplateHome As Long = 2 'See Constants


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
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)

'$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,


With Selection
   .InsertAfter "StyleName" & vbTab & "Gallery" & vbTab & "ListTemplate" &
vbTab & "Listlevel"
   .Style = wdStyleHeading4
   .Collapse wdCollapseEnd
   For ThisStyle = 1 To flStyleName.Count
      If LTHome = hitListTemplatesInDocument Then
         .InsertAfter flStyleName(ThisStyle) & vbTab &
flStyleGallery(ThisStyle) & vbTab & flListTemplate(ThisStyle) & vbTab &
         .InsertAfter flStyleName(ThisStyle) & vbTab &
GalleryNum2Name(flStyleGallery(ThisStyle)) & vbTab &
flListTemplate(ThisStyle) & vbTab & flListLevel(ThisStyle)
      End If
   .ConvertToTable wdSeparateByTabs
End With
Set flStyleName = Nothing
Set flStyleGallery = Nothing
Set flListTemplate = Nothing
Set flListLevel = Nothing
End Sub

Public Sub FixStyledLists()
'$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


Application.ScreenUpdating = False
Options.Pagination = False

'All I want is style names here

GetListStyleNames StyleNames, StyleGalleries, ListTemplates, ListLevels,
Set StyleGalleries = Nothing
Set ListTemplates = Nothing
Set ListLevels = Nothing

'Bar.Caption = "Fixing Styled lists"
'Bar.Iterations = ActiveDocument.Paragraphs.Count

'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
         '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 =

           'just in case there is some spurious list template attached
         'FRIGGIN KILL IT!!!


      End If
   End With
'   Bar.Update
Set StyleNames = Nothing
Set Para = Nothing
Application.ScreenUpdating = True
Options.Pagination = True
End Sub

Public Function IsRestart(aListFormat As ListFormat) As Boolean
'$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)
'$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
End If
End Sub

Private Sub GetListStyleNames(aName As Collection, aGallery As Collection, _
  aListTemplate As Collection, aListLevel As Collection, Optional Scope As

'$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

   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
               End With 'LT
         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)

'$Short  Tells what styles can be found in the lists hanging off the list
'        for those folk that excusively use the Word facade for setting up

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
      End With
End With
End Sub

Private Function GalleryNum2Name(GalleryNumber As WdListGalleryType) As

'$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()

'$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

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

         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 =
                  theListLevel = .ListLevelNumber
                  .ApplyListTemplate .ListTemplate, False,
                  .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
End With
Set Names = Nothing
'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()

'$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
            .Style = NumberStyle
            StripStartOfPara Para
         ElseIf InStr(1, BulletChars, FirstChar) Then
            .Style = BulletStyle
            StripStartOfPara Para
         End If
      End With
'      Bar.Update
   Next Para
End With
End Sub

Private Sub StripStartOfPara(aPara As Paragraph)

'$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
      KeepGoing = (Safety <> .Characters.Count)
End With
Set StringHandler = Nothing
End Sub

Public Sub ConvertAuto2HardCoded()

'$Short  Just for completeness


End Sub

Public Sub ResetListGalleries()
'$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)
'$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 = ""
End With
End Sub

Public Sub RestartListNumbering(Optional aRange As Variant)
'$Short  Resets a list's numbering EVERY time, unlike Word's facade

If aRange Is Nothing Then Set aRange = Selection.Range
On Error Resume Next
With aRange.ListFormat
   .ApplyListTemplate .ListTemplate, False
End With
End Sub

Public Sub ShowUsedListTemplates()
'$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

'      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()

'$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
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
         StyleLevel = Val(Right$(Para.Style, 1))
         Para.Style = MyListStyles(ListStyle)
         While StyleLevel > 1
            StyleLevel = StyleLevel - 1
         Exit For
      End If
   Next ListStyle
'   Bar.Update
Next Para
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
         FieldStyle = .Fields(iField).Result.Style
         For iStyle = 1 To UBound(MyListStyles)
            If MyListStyles(iStyle) = FieldStyle Then
               Exit For
            End If
      End If
End With
Set Scope = Nothing
End Sub

Public Function CopyDocListTemplatesInUse(InDoc As Document, OutDoc As

'$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()

'$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
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

'$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
End Function

Public Function InCollection(Needle As String, Haystack As Collection) As

'$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

   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

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
Tricky stuff with Word or words for you.
Email:      steve@xxxxxxxxxxxxxxx
Spellbooks: 728 pages of dump left and dropping...

-----Original Message-----
From: austechwriter-bounce@xxxxxxxxxxxxx
[mailto:austechwriter-bounce@xxxxxxxxxxxxx]On Behalf Of Kobus Myburgh
Sent: Monday, 22 September 2003 6:07 PM
To: austechwriter@xxxxxxxxxxxxx
Subject: atw: Word Numbering Issues! Save my life, please!


My boss gave me the task to figure out why the numbering in our
templates are not working properly, especially the restart numbering.
When you restart the numbering, save and close the document, re-open it,
the restarted numbering doesn't work as it is supposed to - causing the
whole document to be totally messed up.

After spending literally HOURS with Word in spying through our macros,
unable to find anything wrong with them, I turned to the Internet for
help, and found you.

In the article I found [1] via Google, you mentioned that you have a
macro to address this problem. How much does it cost? Where can I get
it? What do you need from me? Please contact me a.s.a.p. as I am
desperate for a solution. Do I have to send you our template for you to
build it in? Or what do we do?

To post a message to austechwriter, send the message to 

To subscribe to austechwriter, send a message to 
austechwriter-request@xxxxxxxxxxxxx with "subscribe" in the Subject field.

To unsubscribe, send a message to austechwriter-request@xxxxxxxxxxxxx with 
"unsubscribe" in the Subject field.

To search the austechwriter archives, go to

To contact the list administrator, send a message to 

Other related posts: