footer - ajit

[Ajit Munj]

I have created 450 files approx. in two months without inserting any footer.
Without opening each file and inserting footer separately is a tedious work.
How can I put a footer to each file with full path & file name at one go?
ajit

 

[Helmut Weber]

Hi Ajit,

I have created 450 files approx. in two months without inserting any footer.

What filenames? What location?
Is there any kind of system in the file names or the folders?
Can you access all files programmatically,
e.g. by aplication.filesearch ?

Without opening each file and inserting footer separately is a tedious work.
How can I put a footer to each file with full path & file name at one go?

Not at all,
but Word can do all in the background, if the documents
are rather simple and equally structured.

If the are small, too, if your machine is fast
and above all the storage device, than Word would need
hardly more than let's say 2 - 4 second for each file.
I fact, I need here on a local drive for
10 small and simple document 1,5 seconds.

Example:

Sub Test()
Dim t As Single
Dim l As Long
Dim oDcm As Document
Dim rTmp As Range
t = Timer
Application.Visible = False
With Application.FileSearch
.NewSearch
.LookIn = "c:\testy\"
.FileName = "*.doc"
.Execute
For l = 1 To .FoundFiles.Count
Set oDcm = Documents.Open(.FoundFiles(l))
Set rTmp = oDcm.Sections(1).Footers(wdHeaderFooterPrimary).Range
rTmp.InsertAfter oDcm.FullName
oDcm.Save
oDcm.Close
Next
End With
Application.Visible = True
MsgBox Timer - t
End Sub

You might use a field instead of oDcm.FullName,
but that wasn't the questions.


Greetings from Bavaria, Germany

Helmut Weber, MVP
"red.sys" & chr(64) & "t-online.de"
Word XP, Win 98
http://word.mvps.org/

 

[Chuck]

This is a variation on Helmut's suggestion.

The sub below opens all the files in a folder and its subfolders and inserts
a Filename field (with path) at the beginning of every footer in every
section. It uses a (non-visible) Word application object rather than opening
the files in the current Word session to try to avoid crashing the current
Word session on account of too many operations in one session (I've run
across this problem processing more than 150 files at a time, although that
was when I was doing a lot more operations on each file than simply inserting
fields in footers). It might also give you some ideas for further
experimentation.

The function FileLocked is from the mvps.org site -- it skips any files that
may be open/in use. You can modify it to create a log file of unprocessed
files if you want.

Disclaimer - use at your own risk, and definitely not on live files. Use on
a copy of the live folder(s) then when you're happy with the results, you can
overwrite the live folder(s) with the copy. Other eyes may see flaws in the
code and hopefully correct them...

Sub InsertFootersInAllFiles()

Dim oWord As Object
Dim i As Long
Dim pos As Long
Dim rng As Range
Dim ftr As HeaderFooter
Dim doc As Document
Dim sect As Section
Dim fld As Field

On Error GoTo errorhandler

Set oWord = CreateObject("Word.Application")

With oWord.Application.FileSearch
.FileName = "*.doc"
.LookIn = "c:\temp"
.SearchSubFolders = True
.Execute

For i = 1 To .FoundFiles.Count
'ignore hidden files
pos = InStr(1, CStr(.FoundFiles(i)), "~")
If pos > 0 Then
'do nothing - hidden file
Else
If Not FileLocked(.FoundFiles(i)) Then
Set doc = oWord.Documents.Open(.FoundFiles(i))
With doc
For Each sect In .Sections
For Each ftr In sect.Footers
For Each fld In ftr.Range.Fields
If fld.Type = wdFieldFileName Then
'delete existing field may not be
'properly formatted
fld.Delete
End If
Next fld

Set rng = ftr.Range
'set insertion point at
'beginning of footer
rng.Collapse wdCollapseStart

doc.Fields.Add _
Range:=rng, _
Type:=wdFieldFileName, _
Text:=" \p ", _
PreserveFormatting:=True

Next ftr
Next sect

doc.Close wdSaveChanges
End With
End If
End If
Next i
End With

oWord.Application.Quit
Set oWord = Nothing

Exit Sub

errorhandler:

MsgBox "error encountered - quitting"

oWord.Application.Quit
Set oWord = Nothing

End Sub

Function FileLocked(strFileName As String) As Boolean

On Error Resume Next

' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Lock Read As #1
Close #1

' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
FileLocked = True
Err.Clear
'MsgBox "Another user has " & strFileName & " open. " & _
"Please choose another file.", _
vbExclamation + vbOKOnly, _
"File already open"
End If

End Function

<<<<<<<<<<

 

[Ajit Munj]

Thanks Chuck! I have created both .doc and .xls files in C:\My Document. Will
this program work for both of these file types? Where and how to create this
program and how to execute it? -- Ajit

 

[Chuck]

The sub I posted previously will only work on Word documents (with a .doc
extension).

It should be placed in a module in a template, either normal.dot or -- much
better -- in a template in your Startup folder so that it's available in
Tools>Macro>Macros...

The code can be modified to work with Excel workbooks as well. Below is a
separate sub that goes through all the .xls files in a folder and its
subfolders. You can save it in the same Word template as the other sub.
The attached sub uses the FileLocked function -- if you've already got the
FileLocked function in your Word template you don't need it a second time.

Note the three lines that deal with the Excel worksheet footers (each
worksheet has one footer).

..worksheets(x).PageSetup.LeftFooter = "&F"
'.worksheets(x).PageSetup.CenterFooter = "&F"
'.worksheets(x).PageSetup.RightFooter = "&F"

You can place the file name in the left, centre or right footer using the
code "&F" - you can use those lines to add other text to your footers as well.

Again, the same disclaimer applies: use at your own risk, and definitely
not on live files. Use on a copy of the live folder(s) then when you're happy
with the results, you can overwrite the live folder(s) with the copy. Other
eyes may see flaws in the code and hopefully correct them...

Sub InsertFootersInAllExcelWorksheets()

Dim oExcel As Object
Dim i As Long
Dim x As Long
Dim pos As Long
Dim rng As Range
Dim oWorksheet As Object
Dim oWorkbook As Object

On Error GoTo errorhandler

Set oExcel = CreateObject("Excel.Application")

With oExcel.Application.FileSearch
.NewSearch
.FileType = msoFileTypeExcelWorkbooks
.FileName = "*.xls"
.LookIn = "c:\temp"
.SearchSubFolders = True
.Execute

For i = 1 To .FoundFiles.Count
'ignore hidden files
pos = InStr(1, CStr(.FoundFiles(i)), "~")
If pos > 0 Then
'do nothing - hidden file
Else
If Not FileLocked(.FoundFiles(i)) Then
Set oWorkbook = oExcel.Workbooks.Open(.FoundFiles(i))
With oWorkbook
For x = 1 To .worksheets.Count
.worksheets(x).PageSetup.LeftFooter = "&F"
'.worksheets(x).PageSetup.CenterFooter = "&F"
'.worksheets(x).PageSetup.RightFooter = "&F"
Next x

oWorkbook.Save
oWorkbook.Close
End With
End If
End If
Next i
End With

oExcel.Application.Quit
Set oExcel = Nothing

MsgBox "Done fixing Excel footers"

Exit Sub

errorhandler:

MsgBox Err.Number & " " & Err.Description
MsgBox "error encountered - quitting"

oExcel.Application.Quit
Set oExcel = Nothing

End Sub

Function FileLocked(strFileName As String) As Boolean

On Error Resume Next

' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Lock Read As #1
Close #1

' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
FileLocked = True
Err.Clear
'MsgBox "Another user has " & strFileName & " open. " & _
"Please choose another file.", _
vbExclamation + vbOKOnly, _
"File already open"
End If

End Function