Update Heading Styles Linked to List Gallery

[JingleBelle]

Frequently, I need to update the heading styles in many documents. Instead of opening each file, updating the styles, resaving, etc., I thought I could use Macropod’s recently posted code https://www.msofficeforums.com/word-...es-folder.html to update said styles.

It works beautifully except for Headings 1 through 9, which are linked to a list gallery (Outline Number Gallery). For these, the text of the heading updates as needed; however, the linked list level number does not. I am stumped but hopeful someone, here, will take a look and tell me how to correct the code. Following is my attempt to update just the Heading 1 style. I'm thinking if I can get this code to work correctly, I can use it moving forward to update Headings 2 through 9.

Sub UpdateFolderStyles()

Application.ScreenUpdating = False
Dim strDocNm As String, strFolder As String, strFile As String
Dim wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
strDocNm = ThisDocument.FullName
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    
    With wdDoc
      .Styles("Heading 1").Font.Name = "Arial"
      .Styles("Heading 1").Font.Size = 14
      
       With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(1)
        .NumberFormat = "%1."
        .TrailingCharacter = wdTrailingTab
        .NumberStyle = wdListNumberStyleArabic
        .NumberPosition = InchesToPoints(0)
        .Alignment = wdListLevelAlignLeft
        .TextPosition = InchesToPoints(0.33)
        .TabPosition = InchesToPoints(0.33)
        .ResetOnHigher = 0
        .StartAt = 1
        With .Font
            .Bold = True
            .Color = wdBlack
            .Size = 14
            .Name = "Arial Bold"
        End With
        .LinkedStyle = "Heading 1"
    End With
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

[macropod]

The code in the linked thread has nothing to do with updating Styles. There are various ways of doing that. One is to set the document's 'automatically update Styles' property, so that whatever Styles it uses will be auto-updated to match those of the document's template. Another is to use the Organizer. Both can be done in code.

For a stand-alone Style copier that uses the Organizer, see: https://www.msofficeforums.com/28497-post34.html

[JingleBelle]

Hey, Macropod,

Thank you for the suggestions and for the Style Copier utility. I'm looking forward to trying that out. Thanks also for taking the time to review and respond to my question. I appreciate that very much.

-JB

[JingleBelle]

The Style Copier utility is fantastic. I can easily update styles in several documents at once. Thank you for sharing!

-JB