Try the following macro. It assumes you're working with doc, docx & docm files. If not, change the 'doc' in the '*.doc' reference to whatever file type you're working with.
Option Explicit
Public oFolder As Object 'the folder object
Public i As Long, j As Long
Public DocTgt As Document
Sub Main()
' Minimise screen flickering
Application.ScreenUpdating = False
Dim StrFolder As String
' Browse for the starting folder
StrFolder = GetTopFolder
If StrFolder = "" Then Exit Sub
' Initialize the counters
i = 0: j = 0
Set DocTgt = ActiveDocument
' Search the top-level folder
Call GetFolder(StrFolder & "\")
' Return control of status bar to Word
Application.StatusBar = ""
' Restore screen updating
Application.ScreenUpdating = True
MsgBox i & " of " & j & " files processed.", vbOKOnly
End Sub
Function GetTopFolder() As String
GetTopFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetTopFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Sub GetFolder(StrFolder As String)
Dim strFile As String
strFile = Dir(StrFolder & "*.doc")
' Process the files in the folder
While strFile <> ""
' Update the status bar is just to let us know where we are
Application.StatusBar = StrFolder & strFile
Call UpdateFile(StrFolder & strFile)
strFile = Dir()
Wend
End Sub
Sub UpdateFile(strDoc As String)
Dim Doc As Document
' Open the document
Set Doc = Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto, Visible:=False)
With Doc
If .ProtectionType = wdNoProtection Then
With .Range.Sections
With .First.Footers(wdHeaderFooterPrimary).Range
.InsertBefore Doc.Name & vbCr
While .Characters.Last.Previous = vbCr
.Characters.Last.Previous = vbNullString
Wend
End With
.Add Start:=wdSectionBreakNextPage
End With
DocTgt.Characters.Last.FormattedText = .Range.FormattedText
' Update the file counter for processed files
i = i + 1
End If
' Update the main file counter
j = j + 1
.Close SaveChanges:=False
End With
' Let Word do its housekeeping
DoEvents
Set Doc = Nothing
End Sub
With this code, each merged file's name will be added to its footer.
Cheers
Paul Edstein
[MS MVP - Word]
