G'day (e-mail address removed) (Rich VanDyk),
Here's a bunch of code I use - the RestartListsAfterHeadings will
probably do the job for you, if it plays silly on you there are some
diagnostic tools below as well. Enjoy:
Note that one line needs to be hand edited back to being one line as
commented inline.
Private Const OneStyle as Boolean = True
Public Sub RestartListsAfterHeadings()
Dim Para As Paragraph, L As Long, m As Long
Dim ltLast As Boolean
Application.ScreenUpdating = False
Application.Visible = False
Options.Pagination = False
ltLast = False
With ActiveDocument
For Each Para In .Paragraphs
With Para
If InStr(1, .Style, "Heading") Then
ltLast = False
Else
With .Range.ListFormat
L = .ListType
If L = wdListListNumOnly Or _
L = wdListSimpleNumbering Or _
L = wdListOutlineNumbering Then
If ltLast = False Then
m = .ListLevelNumber
.ApplyListTemplate .ListTemplate, True
.ListLevelNumber = m
Else
m = .ListLevelNumber
.ApplyListTemplate .ListTemplate, False
.ListLevelNumber = m
ltLast = True
End If
End If
End With
End If
End With
Next
Application.Visible = True
Application.ScreenUpdating = True
Options.Pagination = True
.Repaginate
End With
End Sub
Sub FixStyledLists()
Dim p As Paragraph
Dim flStyleName As New Collection
Dim flStyleGallery As New Collection
Dim flListTemplate As New Collection
Dim flListLevel As New Collection
Dim s As String
Dim ListId As Long
Dim Res As Boolean
Dim L As Long
Application.Visible=False
Application.ScreenUpdating = False
Options.Pagination = False
GetListStyleNames flStyleName, flStyleGallery, flListTemplate,_
flListLevel
With ActiveDocument
For Each p In .Paragraphs
.UndoClear
ListId = ListStyle(Format(p.Style), flStyleName)
With p.Range.ListFormat
If ListId > 0 Then ' apply the gallery
Res = False
'check for a need to restart
If flStyleGallery(ListId) <> wdBulletGallery And _
.ListValue = 1 Then Res = True
L = .ListLevelNumber
'THE NEXT BIT IS ALL ONE LINE
.ApplyListTemplate
ListGalleries(flStyleGallery(ListId)).ListTemplates(flListTemplate(ListId)),
Res, wdListApplyToWholeList
' 2 HERE
If (flStyleGallery(ListId) = _
wdOutlineNumberGallery) And (Not OneStyle) Then_
.ListLevelNumber = flListLevel(ListId)
Else ' otherwise remove any list status it may have
.RemoveNumbers
End If
End With
Next
Application.Visible=True
Application.ScreenUpdating = True
Options.Pagination = True
.Repaginate
Application.StatusBar = "Lists fixed: " &
Format(.ListTemplates.Count) & " List Templates remain."
End With
End Sub
Private Function ListStyle(flTestStyle As String, flStyleNames As
Collection) As Long
Dim k As Long
ListStyle = 0
For k = 1 To flStyleNames.Count
If flTestStyle = flStyleNames(k) Then
ListStyle = k
Exit For
End If
Next
End Function
Private Sub GetListStyleNames(aName As Collection, aGallery As
Collection, aListTemplate As Collection, aListLevel As Collection)
Dim k As Long
For k = 1 To 3
GetStylesInGallery k, aName, aGallery, aListTemplate,
aListLevel
Next
End Sub
Private Sub GetStylesInGallery(BNGallery As WdListGalleryType, aName
As Collection, aGallery As Collection, aListTemplate As Collection,
aListLevel As Collection)
Dim t As Long, L As Long, s As String
With ListGalleries(BNGallery)
For t = 1 To .ListTemplates.Count
With .ListTemplates(t)
For L = 1 To .ListLevels.Count
s = .ListLevels(L).LinkedStyle
If s > "" Then
aName.Add s
aGallery.Add BNGallery
aListTemplate.Add t
aListLevel.Add L
End If
Next
End With
Next
End With
End Sub
Public Sub ReportListStyles()
' 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 k As Long
GetListStyleNames flStyleName, flStyleGallery, flListTemplate, _
flListLevel
Documents.Add
With Selection
.InsertAfter "StyleName" & vbTab & "Gallery" & vbTab & _
"ListTemplate" & vbTab & "Listlevel"
.Style = wdStyleHeading4
.InsertParagraphAfter
.Collapse wdCollapseEnd
For k = 1 To flStyleName.Count
.InsertAfter flStyleName(k) & vbTab & _
GalleryNum2Name(flStyleGallery(k)) & vbTab & _
flListTemplate(k) & vbTab & flListLevel(k)
.InsertParagraphAfter
Next
ActiveDocument.Content.Select
.ConvertToTable wdSeparateByTabs
End With
End Sub
Private Function GalleryNum2Name(GalleryNumber As WdListGalleryType)
As String
Select Case GalleryNumber
Case wdBulletGallery
GalleryNum2Name = "Bullet"
Case wdNumberGallery
GalleryNum2Name = "Number"
Case wdOutlineNumberGallery
GalleryNum2Name = "Outline"
End Select
End Function
Public Sub ShowUsedListTemplates()
Dim k As Long
On Error Resume Next
With ActiveDocument
For k = 1 To .ListTemplates.Count
With .ListTemplates(k)
If .Name = "" Then .Name = Format(k)
End With
Next
For k = 1 To .ListParagraphs.Count
With .ListParagraphs(k)
.Range.InsertBefore "[" & _
.Range.ListFormat.ListTemplate.Name & "]"
End With
Next
End With
End Sub
Steve Hudson - Word Heretic
Want a hyperlinked index? S/W R&D? See WordHeretic.com
steve from wordheretic.com (Email replies require payment)
Rich VanDyk reckoned:
