Modifying a macro for batch updating document headers

Rzv · #1 06-08-2022, 10:43 AM

I have a macro made by @macropod and I want to modify it so that it only places the header on the first page and it recursively scans for files (goes into sub-folders)
I also have a problem with it saying a document is corrupted if it has the letters ș,ț etc. but that may not be fixable, I don't know, maybe renaming the documents is the only way.

I might add that I somewhat understand the code but not nearly enough to modify it or even understand it fully... any help is appreciated.

This is the original code

Code:

Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim wdDocTgt As Document, wdDocSrc As Document
Dim Sctn As Section, HdFt As HeaderFooter
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set wdDocSrc = ActiveDocument
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
    If strFolder & "\" & strFile <> wdDocSrc.FullName Then
        Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, _
        AddToRecentFiles:=False, Visible:=False)
        With wdDocTgt
            For Each Sctn In .Sections
                'For Headers
                For Each HdFt In Sctn.Headers
                    With HdFt
                        If .Exists Then
                            If Sctn.Index = 1 Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Headers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            ElseIf .LinkToPrevious = False Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Headers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            End If
                        End If
                    End With
                Next
                'For footers
                For Each HdFt In Sctn.Footers
                    With HdFt
                        If .Exists Then
                            If Sctn.Index = 1 Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Footers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            ElseIf .LinkToPrevious = False Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Footers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            End If
                        End If
                    End With
                Next
            Next
            .Close SaveChanges:=True
        End With
    End If
    strFile = Dir()
Wend
Set wdDocSrc = Nothing: Set wdDocTgt = 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 · #2 06-08-2022, 03:04 PM

Quote:

Originally Posted by Rzv

I have a macro made by @macropod and I want to modify it so that it only places the header on the first page and it recursively scans for files (goes into sub-folders)

For that, you need code like:

Code:

Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String, wdDocSrc As Document, wdDocTgt As Document

Sub Main()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder
If TopLevelFolder = "" Then Exit Sub
StrFolds = vbCr & TopLevelFolder
If FSO Is Nothing Then
  Set FSO = CreateObject("Scripting.FileSystemObject")
End If
Set wdDocSrc = ActiveDocument
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
  Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub
 
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
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

Sub UpdateDocuments(oFolder As String)
Dim strInFolder As String, strFile As String
strInFolder = oFolder
strFile = Dir(strInFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDocTgt = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDocTgt
    With .Sections.First
      .PageSetup.DifferentFirstPageHeaderFooter = True
      .Headers(wdHeaderFooterFirstPage).Range.FormattedText = _
        wdDocSrc.Sections.First.Headers(wdHeaderFooterFirstPage).Range.FormattedText
      .Range.Characters.Last = vbNullString
    End With
    'Save and close the document
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
End Sub

Note that your source document will also need to have a 'different first page' setup.

Quote:

Originally Posted by Rzv

I also have a problem with it saying a document is corrupted if it has the letters ș,ț etc. but that may not be fixable, I don't know, maybe renaming the documents is the only way.

There is nothing in the code that is capable of causing that.

Rzv · #3 06-08-2022, 11:53 PM

The code works perfectly until it hits runtime error 5138
Hitting debug then points me to

Code:

.PageSetup.DifferentFirstPageHeaderFooter = True

Still, this is much better than doing things manually and if there is no fix I will just find a way to discover which document is the problem and just do it manually.
Thank you.
Edit:
I found the problem there are some weird documents with impossible margins, and I found a way to mass rename and remove the special chars from the filenames, the code is working as intended, thank you for your help!

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Updating Headers & Footers from Database	Yuvahari	Word VBA	5	01-31-2022 10:12 PM
Batch Replacing Headers using Macros	JakeG9	Word VBA	0	07-13-2021 10:54 AM
Bulk/Batch update Word documents Headers and footers	troyw	Word VBA	8	05-05-2021 07:17 PM
Batch applying a macro to remove Header and Footer using Batch Auto Addin	Edszx	Word VBA	2	05-27-2019 11:16 PM
Updating headers in multiple files	cellophane	Word	3	01-17-2013 06:36 AM