Multi-Level List on the Fly

gmaxey · #1 03-03-2024, 01:01 PM

I've been tinkering with some code for creating a custom multi-level list with the list levels linked to a unique paragraph style. It seems to work okay but there is some weirdness going on behind the scenes. Sharing here for anyone interested:

Code:

Option Explicit
'Note - change names to suit.
Private Const m_strListStyleName As String = "My ML Numbered List"
Private Const m_strStyleLevelPrefixName As String = "LL_"
'Note - change the global indent value to suit.  Value is in points e.g., half inch is 36 points.
Private Const m_lngIndent As Long = 21

Sub Create_EditMultiLevelListStyle()
Dim oListStyle As Style
Dim oStyle As Style
Dim oLL As ListLevel
Dim lngPoints As Long, lngLevelIndex As Long
Dim bRedefine As Boolean, bUpdate As Boolean
  'I created this VBA procedure because I think the built-in multilevel lists (MML) in Word look absolutely stupid.  I realize that is
  'a broad brush statement for out of 6 plus billion souls out there, some may feel the look of the MLL list this procedure creates is even worse.
  'Here we are.
  'I don't normally comment code heavily but make an exception here as I want any potential user to understand the mechanics and what is going on.
  'Trust me, some weird things go on.  Those are commented as well in hopes some smart guy or gal out there will jump in with suggestions
  'for improvement, explainaitons or fixes.
  'The primary goals of this code are to:
    'a) Produce a MML that is linked to 9 different paragraphs styles (one for each list level)
    'b) Produce a MML that has a unique list member index for each list level
    'c) Produce a MML with "lesser" indents that the built-in MML provided with Word
  bRedefine = False '***
  bUpdate = True
  On Error Resume Next
  'Get (or since it won't exist initially, create) the named list style.
  Set oListStyle = ActiveDocument.Styles(m_strListStyleName)
  If Err.Number <> 0 Then
    'If the named list style didn't exists then we create it now.
    Set oListStyle = ActiveDocument.Styles.Add(m_strListStyleName, wdStyleTypeList)
    bRedefine = True '***
    bUpdate = False
  End If
  DoEvents
ReDefineAfterCreate:
  'Initialize the indent value
  lngPoints = 0
  On Error GoTo 0
  'Define the ListTemplate associated with the list style.
  With oListStyle.ListTemplate
    For lngLevelIndex = 1 To 9
      'Global actions for all nine list levels
      Set oLL = .ListLevels(lngLevelIndex)
      oLL.Alignment = wdListLevelAlignLeft
      'Note - the value of lngPoints is increased by the value you set with the constant m_lngIndent with each iteration of the this For ... Next loop
      oLL.NumberPosition = lngPoints
      oLL.TabPosition = lngPoints + m_lngIndent
      oLL.TrailingCharacter = wdTrailingTab
      oLL.ResetOnHigher = True
      'Link the list level to a unique paragraph style. Note - If that style doesn't exists, we create it with the error handler.
      On Error GoTo Err_Style
      Set oStyle = ActiveDocument.Styles(m_strStyleLevelPrefixName & lngLevelIndex)
      oLL.LinkedStyle = oStyle.NameLocal
      On Error GoTo 0
      Select Case lngLevelIndex
        Case 1
          'Note - for levels 1 - 3, I want my second line text to align under list member number/letter
          'To align under first character of list member text, append + m_lngIndent to .Text Position line.
          oLL.TextPosition = lngPoints '+ m_lngIndent
          oLL.NumberFormat = "%1."
          oLL.NumberStyle = wdListNumberStyleArabic
        Case 2
          oLL.TextPosition = lngPoints  '+ m_lngIndent
          oLL.NumberFormat = "%2."
          oLL.NumberStyle = wdListNumberStyleUppercaseLetter
        Case 3
          oLL.TextPosition = lngPoints '+ m_lngIndent
          oLL.NumberFormat = "%3)"
          oLL.NumberStyle = wdListNumberStyleArabic
        Case 4
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%4."
          oLL.NumberStyle = wdListNumberStyleLowercaseLetter
        Case 5
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%5."
          oLL.NumberStyle = wdListNumberStyleArabic
          oLL.Font.Underline = wdUnderlineSingle
        Case 6
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%6)"
          oLL.NumberStyle = wdListNumberStyleLowercaseLetter
        Case 7
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%7]"
          oLL.NumberStyle = wdListNumberStyleArabic
        Case 8
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%8."
          oLL.NumberStyle = wdListNumberStyleLowercaseLetter
          oLL.Font.Underline = wdUnderlineSingle
        Case 9
          oLL.TextPosition = lngPoints + m_lngIndent
      End Select
      lngPoints = lngPoints + m_lngIndent
    Next lngLevelIndex
  End With
  '*** Here is the wierdness.
  'For whatever reason, when this procedure first creates the list style and associated linked paragraphs, the resulting linked LL_1 style paragraph assumes a mysterious
  '.25 inch hanging indent.  The only way I have found to work around this issue is to repeat ListTemplate definition steps.
  If bRedefine Then
    bRedefine = False
    GoTo ReDefineAfterCreate
  End If
  If bUpdate Then
    MsgBox "Defined changes to list and associated linked paragraph styles are completed.", vbInformation + vbOKOnly, "REPORT"
  Else
    MsgBox "This list style and associated linked paragraph styles have been created." & vbCr + vbCr _
      & "To reflect changes in the List Styles gallery please save, close and reopen the template file.", vbInformation + vbOKOnly, "REPORT"
      'Does anyone know how to force the List Styles gallery to refresh with code?
    Selection.Paragraphs(1).Style = m_strStyleLevelPrefixName & "1"
  End If
  '***
lbl_Exit:
  Exit Sub
Err_Style:
  Select Case Err.Number
    Case 5941
      'Create a unique paragraph style to serve as the linked paragraph for the indexed level.
      Set oStyle = ActiveDocument.Styles.Add(m_strStyleLevelPrefixName & lngLevelIndex, wdStyleTypeParagraph)
      oStyle.BaseStyle = "List Paragraph"
      Select Case lngLevelIndex
        Case 4 To 9
          'I specifically don't want additional white space after levels 4 through 9.  You can adjust this to suit your own taste.
          oStyle.NoSpaceBetweenParagraphsOfSameStyle = True
      End Select
    Case Else
      MsgBox Err.Number & " - " & Err.Description
  End Select
  Resume
End Sub
Sub DeleteStyleSet()
'Use this procedure to remove the list and associated linked paragraph styles.
'You should save and close the template, then reopen to reset the List Styles Gallery content.
Dim oStyle As Style
  For Each oStyle In ActiveDocument.Styles
    If Left(oStyle.NameLocal, "3") = m_strStyleLevelPrefixName Or oStyle.NameLocal = m_strListStyleName Then
      oStyle.Delete
    End If
  Next
End Sub

gmaxey · #2 05-05-2024, 06:20 AM

Here is a revision of the code that eliminates the need to loop through the setup processes a second time:

Code:

Option Explicit
'Note - change names to suit.
Private Const m_strListStyleName As String = "My ML Numbered List"
Private Const m_strStyleLevelPrefixName As String = "LL_"
'Note - change the global indent value to suit.  Value is in points e.g., half inch is 36 points.
Private Const m_lngIndent As Long = 21

Sub Create_EditMultiLevelListStyle()
Dim oListStyle As Style
Dim oStyle As Style
Dim oLL As ListLevel
Dim oLL1 As ListLevel

Dim lngPoints As Long, lngLevelIndex As Long
Dim bUpdate As Boolean
  'I created this VBA procedure because I think the built-in multilevel lists (MLL) in Word look absolutely stupid.  I realize that is
  'a broad brush statement for out of 6 plus billion souls out there, some may feel the look of the MLL list this procedure creates is even worse.
  'Here we are.
  'I don't normally comment code heavily but make an exception here as I want any potential user to understand the mechanics and what is going on.
  'Perhaps some smart guy or gal out there will jump in with suggestions for improvement, explainations or fixes.
  'The primary goals of this code are to:
    'a) Produce a MML that is linked to 9 different paragraphs styles (one for each list level)
    'b) Produce a MML that has a unique list member index for each list level
    'c) Produce a MML with "lesser" indents that the built-in MML provided with Word
  bUpdate = True
  On Error Resume Next
  'Get (or since it won't exist initially, create) the named list style.
  Set oListStyle = ActiveDocument.Styles(m_strListStyleName)
  If Err.Number <> 0 Then
    'If the named list style didn't exists then we create it now.
    Set oListStyle = ActiveDocument.Styles.Add(m_strListStyleName, wdStyleTypeList)
    bUpdate = False
  End If
  DoEvents
  'Initialize the indent value
  lngPoints = 0
  On Error GoTo 0
  'Define the ListTemplate associated with the list style.
  With oListStyle.ListTemplate
    For lngLevelIndex = 1 To 9
      'Global actions for all nine list levels
      Set oLL = .ListLevels(lngLevelIndex)
      oLL.Alignment = wdListLevelAlignLeft
      'Initialized text position. The hanging indent.
      oLL.TextPosition = 0
      'Note - the value of lngPoints is increased by the value you set with the constant m_lngIndent with each iteration of the this For ... Next loop
      oLL.NumberPosition = lngPoints
      oLL.TabPosition = lngPoints + m_lngIndent
      oLL.TrailingCharacter = wdTrailingTab
      oLL.ResetOnHigher = True
      'Link the list level to a unique paragraph style. Note - If that style doesn't exists, we create it with the error handler.
      On Error GoTo Err_Style
      Set oStyle = ActiveDocument.Styles(m_strStyleLevelPrefixName & lngLevelIndex)
      oLL.LinkedStyle = oStyle.NameLocal
      On Error GoTo 0
      Select Case lngLevelIndex
        Case 1
          'Note - for levels 1 - 3, I want my second line text to align under list member number/letter
          'To align under first character of list member text, append + m_lngIndent to .Text Position line.
          oLL.TextPosition = lngPoints '+ m_lngIndent
          Set oLL1 = oLL
          oLL.NumberFormat = "%1."
          oLL.NumberStyle = wdListNumberStyleArabic
        Case 2
          oLL.TextPosition = lngPoints  '+ m_lngIndent
          oLL.NumberFormat = "%2."
          oLL.NumberStyle = wdListNumberStyleUppercaseLetter
        Case 3
          oLL.TextPosition = lngPoints '+ m_lngIndent
          oLL.NumberFormat = "%3)"
          oLL.NumberStyle = wdListNumberStyleArabic
        Case 4
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%4."
          oLL.NumberStyle = wdListNumberStyleLowercaseLetter
        Case 5
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%5."
          oLL.NumberStyle = wdListNumberStyleArabic
          oLL.Font.Underline = wdUnderlineSingle
        Case 6
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%6)"
          oLL.NumberStyle = wdListNumberStyleLowercaseLetter
        Case 7
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%7]"
          oLL.NumberStyle = wdListNumberStyleArabic
        Case 8
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%8."
          oLL.NumberStyle = wdListNumberStyleLowercaseLetter
          oLL.Font.Underline = wdUnderlineSingle
        Case 9
          oLL.TextPosition = lngPoints + m_lngIndent
      End Select
      lngPoints = lngPoints + m_lngIndent
    Next lngLevelIndex
  End With
  If bUpdate Then
    MsgBox "Defined changes to list and associated linked paragraph styles are completed.", vbInformation + vbOKOnly, "REPORT"
  Else
    MsgBox "This list style and associated linked paragraph styles have been created." & vbCr + vbCr _
      & "To reflect changes in the List Styles gallery please save, close and reopen the template file.", vbInformation + vbOKOnly, "REPORT"
      'Does anyone know how to force the List Styles gallery to refresh with code?
    Selection.Paragraphs(1).Style = m_strStyleLevelPrefixName & "1"
  End If
  '***
lbl_Exit:
  Exit Sub
Err_Style:
  Select Case Err.Number
    Case 5941
      'Create a unique paragraph style to serve as the linked paragraph for the indexed level.
      Set oStyle = ActiveDocument.Styles.Add(m_strStyleLevelPrefixName & lngLevelIndex, wdStyleTypeParagraph)
      oStyle.BaseStyle = "List Paragraph"
      Select Case lngLevelIndex
        Case 4 To 9
          'I specifically don't want additional white space after levels 4 through 9.  You can adjust this to suit your own taste.
          oStyle.NoSpaceBetweenParagraphsOfSameStyle = True
      End Select
    Case Else
      MsgBox Err.Number & " - " & Err.Description
  End Select
  Resume
End Sub
Sub DeleteStyleSet()
'Use this procedure to remove the list and associated linked paragraph styles.
'You should save and close the template, then reopen to reset the List Styles Gallery content.
Dim oStyle As Style
  For Each oStyle In ActiveDocument.Styles
    If Left(oStyle.NameLocal, "3") = m_strStyleLevelPrefixName Or oStyle.NameLocal = m_strListStyleName Then
      oStyle.Delete
    End If
  Next
End Sub

Guessed · #3 05-06-2024, 04:43 AM

Hi Greg

I've had a look at your code and will throw in a bit of biased keyboard warrior opinion to add to the mix. I do have several macros like this that I've been using in templates for a very long time and can highly recommend them because lists have a well justified reputation for fragility. A macro like yours instantly fixes the style series should the list develop a problem.

I am not a fan of adding new custom styles when there is already 250+ built-in style names which you can't get rid of especially when two series exist pretty much for this exact list type. For instance, I would prefer to use the 'List Multi' or 'List' series for a list like the one you are configuring. Using the built-in style name is cleaner (IMO), and you don't need extra code to check it exists. Although those built-in names only go up to 5, you could either add some custom ones for 6-9 or just not associate those lowest levels with a style (like I do). The chance of needing a list out to 6+ levels is pretty low so I normally leave the linked style blank for those ones. You can still apply the extra list levels by outline demote (Alt-Shift-Right Arrow) so having a paragraph style for it as well doesn't serve much usefulness.

You asked about modifying the List Gallery - if you want to do that, you can avoid the clumsiness of the List style competely and cut out nearly all of the preamble...

Code:

Dim oLT As ListTemplate  
  Set oLT = ListGalleries(wdOutlineNumberGallery).ListTemplates(1)
  With oLT

[[Relevant only if you ignore my above rant on custom styles]] It might be easy to trip people by giving them a chance to edit the list prefix constant (without telling them it had to be three characters). Your cleanup macro is looking for a three character prefix only. Perhaps rewrite that line to allow for any matching prefix

Code:

If oStyle.NameLocal Like m_strStyleLevelPrefixName & "*" Or oStyle.NameLocal = m_strListStyleName Then

And here is a little bit of code in case you wanted to audit what list templates are already in your document.

Code:

Sub CompileAllListTemplates()
  Dim aLT As ListTemplate, i As Integer
  For Each aLT In ListGalleries(wdOutlineNumberGallery).ListTemplates
    Debug.Print aLT.Name, aLT.ListLevels(1).LinkedStyle
  Next aLT
  Debug.Print "=-=-=-=-=-=-=--"
  For Each aLT In ActiveDocument.ListTemplates
    If aLT.OutlineNumbered Then
      'i = i + 1
      'If aLT.Name = "" Then aLT.Name = "ListTemp" & i
      Debug.Print aLT.Name, aLT.ListLevels(1).LinkedStyle
    End If
  Next aLT
  ''rename a list template
'  ActiveDocument.ListTemplates("ListTemp19").Name = "Callout"
'  ActiveDocument.ListTemplates("ListBullet").Name = "List Bullet"
End Sub

gmaxey · #4 05-06-2024, 10:50 AM

Andrew,

Thanks for your review, comments and the additional code.

I see your point about adding custom styles and the advantage of using one of the built-in "sets" for this purposed. However, like you point out, there are only 5 styles in the sets. I also agree that more than 5 levels is probably rare, but I also like to have "control" over the paragraph formatting of any of the nine levels individually and the only way to do that that I know of is to link a unique style to each level.

So, I've revised the code to use a built-in style set for the first 5 levels and custom styles for 6-9.

Here is my revised code:

Code:

Option Explicit
'Note - change names to suit.
Private Const m_strListStyleName As String = "My ML Numbered List"
Private Const m_strStyleLevelPrefixName As String = "CustLL"
'Note - change the global indent value to suit.  Value is in points e.g., half inch is 36 points.
Private Const m_lngIndent As Long = 21

Sub Create_EditMultiLevelListStyle()
Dim oListStyle As Style
Dim oStyle As Style
Dim oLL As ListLevel
Dim oLL1 As ListLevel

Dim lngPoints As Long, lngLevelIndex As Long
Dim bUpdate As Boolean
  'I created this VBA procedure because I think the built-in multilevel lists (MLL) in Word look absolutely stupid.  I realize that is
  'a broad brush statement for out of 6 plus billion souls out there, some may feel the look of the MLL list this procedure creates is even worse.
  'Here we are.
  'I don't normally comment code heavily but make an exception here as I want any potential user to understand the mechanics and what is going on.
  'Perhaps some smart guy or gal out there will jump in with suggestions for improvement, explainations or fixes.
  'The primary goals of this code are to:
    'a) Produce a MML that is linked to 9 different paragraphs styles (one for each list level)
    'b) Produce a MML that has a unique list member index for each list level
    'c) Produce a MML with "lesser" indents that the built-in MML provided with Word
  bUpdate = True
  On Error Resume Next
  'Get (or since it won't exist initially, create) the named list style.
  'I like to use a "Named" list style, because I will then know what it is when I see it in the gallery.
  Set oListStyle = ActiveDocument.Styles(m_strListStyleName)
  If Err.Number <> 0 Then
    'If the named list style didn't exists then we create it now.
    Set oListStyle = ActiveDocument.Styles.Add(m_strListStyleName, wdStyleTypeList)
    bUpdate = False
  End If
  DoEvents
  'Initialize the indent value. The indent value determines how far from the left margin the index number appears.
  lngPoints = 0
  On Error GoTo 0
  'Define the ListTemplate associated with the list style.
  With oListStyle.ListTemplate
    For lngLevelIndex = 1 To 9
      'Global actions for all nine list levels
      Set oLL = .ListLevels(lngLevelIndex)
      oLL.Alignment = wdListLevelAlignLeft
      'Initialized text position. The hanging indent.
      oLL.TextPosition = 0
      'Note - the value of lngPoints is increased by the value you set with the constant m_lngIndent with each iteration of the this For ... Next loop
      oLL.NumberPosition = lngPoints
      oLL.TabPosition = lngPoints + m_lngIndent
      oLL.TrailingCharacter = wdTrailingTab
      oLL.ResetOnHigher = True
      'Link the list level to a unique paragraph style. Note - If that style doesn't exists, we create it with the error handler.
      Select Case lngLevelIndex
        Case 1
          Set oStyle = ActiveDocument.Styles("List Number")
          oLL.LinkedStyle = oStyle.NameLocal
        Case 2 To 5
          Set oStyle = ActiveDocument.Styles("List Number " & lngLevelIndex)
          oLL.LinkedStyle = oStyle.NameLocal
        Case Else
          On Error GoTo Err_Style
          Set oStyle = ActiveDocument.Styles(m_strStyleLevelPrefixName & lngLevelIndex)
          oLL.LinkedStyle = oStyle.NameLocal
          On Error GoTo 0
      End Select
      Select Case lngLevelIndex
        Case 1
          'Note - for levels 1 - 3, I want my second line text to align under list member number/letter
          'To align under first character of list member text, append + m_lngIndent to .Text Position line.
          oLL.TextPosition = lngPoints '+ m_lngIndent
          Set oLL1 = oLL
          oLL.NumberFormat = "%1."
          oLL.NumberStyle = wdListNumberStyleArabic
        Case 2
          oLL.TextPosition = lngPoints  '+ m_lngIndent
          oLL.NumberFormat = "%2."
          oLL.NumberStyle = wdListNumberStyleUppercaseLetter
        Case 3
          oLL.TextPosition = lngPoints '+ m_lngIndent
          oLL.NumberFormat = "%3)"
          oLL.NumberStyle = wdListNumberStyleArabic
        Case 4
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%4."
          oLL.NumberStyle = wdListNumberStyleLowercaseLetter
        Case 5
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%5."
          oLL.NumberStyle = wdListNumberStyleArabic
          oLL.Font.Underline = wdUnderlineSingle
        Case 6
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%6)"
          oLL.NumberStyle = wdListNumberStyleLowercaseLetter
        Case 7
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%7]"
          oLL.NumberStyle = wdListNumberStyleArabic
        Case 8
          oLL.TextPosition = lngPoints + m_lngIndent
          oLL.NumberFormat = "%8."
          oLL.NumberStyle = wdListNumberStyleLowercaseLetter
          oLL.Font.Underline = wdUnderlineSingle
        Case 9
          oLL.TextPosition = lngPoints + m_lngIndent
      End Select
      lngPoints = lngPoints + m_lngIndent
    Next lngLevelIndex
  End With
  If bUpdate Then
    MsgBox "Defined changes to list and associated linked paragraph styles are completed.", vbInformation + vbOKOnly, "REPORT"
  Else
    MsgBox "This list style and associated linked paragraph styles have been created." & vbCr + vbCr _
      & "To reflect changes in the List Styles gallery please save, close and reopen the template file.", vbInformation + vbOKOnly, "REPORT"
      'Does anyone know how to force the List Styles gallery to refresh with code?
    Selection.Paragraphs(1).Style = "List Number"
  End If
  '***
lbl_Exit:
  Exit Sub
Err_Style:
  Select Case Err.Number
    Case 5941
      'Create a unique paragraph style to serve as the linked paragraph for the indexed level.
      Set oStyle = ActiveDocument.Styles.Add(m_strStyleLevelPrefixName & lngLevelIndex, wdStyleTypeParagraph)
      oStyle.BaseStyle = "List Paragraph"
      Select Case lngLevelIndex
        Case 4 To 9
          'I specifically don't want additional white space after levels 4 through 9.  You can adjust this to suit your own taste.
          oStyle.NoSpaceBetweenParagraphsOfSameStyle = True
      End Select
    Case Else
      MsgBox Err.Number & " - " & Err.Description
  End Select
  Resume
End Sub
Sub DeleteStyleSet()
'Use this procedure to remove the list and associated linked paragraph styles.
'You should save and close the template, then reopen to reset the List Styles Gallery content.
Dim oStyle As Style
  For Each oStyle In ActiveDocument.Styles
    If oStyle.NameLocal Like m_strStyleLevelPrefixName & "*" Or oStyle.NameLocal = m_strListStyleName Then
      oStyle.Delete
    End If
  Next
End Sub

Charles Kenyon · #5 05-15-2024, 08:42 PM

Thank you both for the work on this.
I have not examined them both, but I believe this is different from the code you posted on VBAExpress.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Multi-level list Weirdness	jthomas666	Word	13	09-16-2019 12:40 PM
Applied Styles to Headings in Multi-Level List; now ALL second level headings are 1.XX	NNL	Word	1	08-09-2017 02:52 PM
Multi-level list hell	Shevaun	Word	5	06-19-2017 07:43 PM
How 2: Different Styles in Multi-Level List	BrianWren	Word	1	10-21-2013 08:50 AM
Headings + Multi-level list	falieson	Word	1	06-18-2010 12:01 AM