[Tazzy via OfficeKB.com]

Hi all,

I wonder if anyone can help me with this one. I have about 150+ Word
documents that need to have the footers amended so that all documents present
a corporate image. Is there any way of doing this without having to open
each document and go through them manually?

Hope someone knows the answer!

Tazzy

--
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...neral/200701/1

[Graham Mayor]

Certainly all the documents will have to be opened to do this - but you may
be able to do what you want using a batch process macro. This would rely on
all the footers being the same and you would need to know whether some or
all the documents had multiple sections perhaps with different footers or
had password protection (such as forms).

The basic code structure is as follows. The macro opens each document in a
selected folder, opens the footer of that document and replaces whatever is
there with an autotext field - here calling the autotext "Logo". Create
your revised footer and save it all as an autotext entry called "Logo" and
run the macro. This will only work with simple documents so do test it on a
small sample of *Copies*!!!

If your documents are more complex you will have to add extra code to deal
with whatever the macro may find on opening them.

In the future documents may be modified simply by recreating the autotext
entry.

Sub AddFooterToDocs()
On Error GoTo err_FolderContents
Dim FirstLoop As Boolean
Dim DocList As String
Dim DocDir As String

With Dialogs(wdDialogCopyFile)
If .Display 0 Then
DocDir = .Directory
Else
MsgBox "Cancelled by User"
Exit Sub
End If
End With

If Documents.Count 0 Then
Documents.Close SaveChanges:=wdPromptToSaveChanges
End If

Application.ScreenUpdating = False

FirstLoop = True

If Left(DocDir, 1) = Chr(34) Then
DocDir = Mid(DocDir, 2, Len(DocDir) - 2)
End If

DocList = Dir$(DocDir & "*.doc")
Do While DocList ""
Documents.Open DocList
'Insert an autotext entry in the footer
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.WholeStory
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty,
Text:= _
"AUTOTEXT Logo ", PreserveFormatting:=True
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
ActiveDocument.Close SaveChanges:=wdSaveChanges
DocList = Dir$()
FirstLoop = False
Loop
Application.ScreenUpdating = True
Exit Sub
err_FolderContents:
MsgBox Err.Description
Exit Sub
End Sub




Tazzy via OfficeKB.com wrote:
Hi all,

I wonder if anyone can help me with this one. I have about 150+ Word
documents that need to have the footers amended so that all documents
present a corporate image. Is there any way of doing this without
having to open each document and go through them manually?

Hope someone knows the answer!

Tazzy

[Tazzy via OfficeKB.com]

Thanks for that Graham, I will be trying that out later during the day

Graham Mayor wrote:
Certainly all the documents will have to be opened to do this - but you may
be able to do what you want using a batch process macro. This would rely on
all the footers being the same and you would need to know whether some or
all the documents had multiple sections perhaps with different footers or
had password protection (such as forms).

The basic code structure is as follows. The macro opens each document in a
selected folder, opens the footer of that document and replaces whatever is
there with an autotext field - here calling the autotext "Logo". Create
your revised footer and save it all as an autotext entry called "Logo" and
run the macro. This will only work with simple documents so do test it on a
small sample of *Copies*!!!

If your documents are more complex you will have to add extra code to deal
with whatever the macro may find on opening them.

In the future documents may be modified simply by recreating the autotext
entry.

Sub AddFooterToDocs()
On Error GoTo err_FolderContents
Dim FirstLoop As Boolean
Dim DocList As String
Dim DocDir As String

With Dialogs(wdDialogCopyFile)
If .Display 0 Then
DocDir = .Directory
Else
MsgBox "Cancelled by User"
Exit Sub
End If
End With

If Documents.Count 0 Then
Documents.Close SaveChanges:=wdPromptToSaveChanges
End If

Application.ScreenUpdating = False

FirstLoop = True

If Left(DocDir, 1) = Chr(34) Then
DocDir = Mid(DocDir, 2, Len(DocDir) - 2)
End If

DocList = Dir$(DocDir & "*.doc")
Do While DocList ""
Documents.Open DocList
'Insert an autotext entry in the footer
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.WholeStory
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty,
Text:= _
"AUTOTEXT Logo ", PreserveFormatting:=True
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
ActiveDocument.Close SaveChanges:=wdSaveChanges
DocList = Dir$()
FirstLoop = False
Loop
Application.ScreenUpdating = True
Exit Sub
err_FolderContents:
MsgBox Err.Description
Exit Sub
End Sub

Hi all,

[quoted text clipped - 6 lines]

Tazzy

--
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...neral/200701/1