Word, cменить все header 1 на 3 в массе файлов

[Mangoster]

Добрый день,

возникла задача сменить все заголовки в word 2003,
header 1
header 2
>
на header 3

в сотне файлов самого разного вида и форматирования.

На данный момент приходится старым методом - открывая порционно и меняя все практически вручную.

Можно ли это автоматизировать?

[mc-black]

Да, можно:

Код: Выделить всё

Option Explicit

Sub EnumDocuments()
    Dim fd As FileDialog, vrtSelectedItem As Variant, sFolder As String, s As String
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    fd.AllowMultiSelect = False
    
    If fd.Show = -1 Then
        Application.ScreenUpdating = False
        For Each vrtSelectedItem In fd.SelectedItems
            sFolder = vrtSelectedItem
            If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
            Call RecureiveSearch(sFolder)
        Next vrtSelectedItem
        Application.ScreenUpdating = True
    End If
End Sub

Private Sub RecureiveSearch(MyPath As String)
    Dim MyName As String, PS As String, DirList() As String
    Dim i As Long, n As Long, dct As Document
    
    PS = Application.PathSeparator
    ReDim DirList(0 To 0) As String
    
    MyName = Dir(MyPath, vbDirectory)
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            n = GetAttr(MyPath & MyName)
            If (n And vbDirectory) = vbDirectory Then
                ReDim Preserve DirList(0 To UBound(DirList) + 1) As String
                DirList(UBound(DirList)) = MyPath & MyName & PS
            Else
                If MyName Like "*.doc" Then
                    Set dct = Documents.Open(MyPath & MyName)
                    
                    Call EnumDocumentsProc(dct)
                    
                    dct.Save
                    dct.Close
                    Set dct = Nothing
                End If
            End If
        End If
        MyName = Dir
    Loop
    If UBound(DirList) > 0 Then
        For i = 1 To UBound(DirList)
            RecureiveSearch DirList(i)
        Next i
    End If
End Sub

Private Sub EnumDocumentsProc(dct As Document)
    With Selection.Find
        .Text = ""
        .ClearFormatting
        .Style = dct.Styles("Заголовок 1")
        With .Replacement
            .Text = ""
            .ClearFormatting
            .Style = dct.Styles("Заголовок 3")
        End With
        .Wrap = wdFindContinue
        .Format = True
        .Execute Replace:=wdReplaceAll
    End With
End Sub

Смысл - открывается окно выбора папки с документами *.doc и любым количеством вложенных подпапок также с документами *.doc, выбираете нужную папку с подпапками, откидыватесь на спинку кресла и наслаждаетесь... =)