Sorry it has taken me so long to get back to you. I've been out of town and
did not have the relevant code at hand - I've since changed that. <smile>
This code is contained in a module in the template.
Anyway, here's what I do. I have a separate document which contains a table
which has the letterhead information in it. The following code runs as the
template is opened. I don't put it in a header or footer, but you can. I do
however, stick the current date in the header so you can see how I do
that....
Sub AutoNew()
Dim appWord As Word.Application
Dim strLetter As String
Dim strTestFile As String
Dim strDocsPath As String
Dim strTemplatePath As String
Dim strFileName As String
Dim strDate As String
On Error GoTo EH
Application.ScreenUpdating = False
Set appWord = GetObject(, "Word.Application")
strFileName = "LetterHeadTable.doc"
strDocsPath = DocsDir
strTemplatePath = "O:\" 'TemplateDir
strLetter = strTemplatePath & strFileName
appWord.Documents.Open strLetter
ActiveDocument.Tables(1).Range.Select
Selection.Copy
ActiveDocument.Close saveChanges:=wdDoNotSaveChanges
Selection.GoTo What:=wdGoToBookmark, Name:="letterhead"
Selection.Paste
FormatLetterheadTable 'procedure which hides the borders
' Automatically insert the current date on the document as a static object.
Selection.GoTo What:=wdGoToBookmark, Name:="Date"
Selection.Find.ClearFormatting
Selection.InsertDateTime DateTimeFormat:="MMMM d, yyyy", InsertAsField:=
_
False, DateLanguage:=wdEnglishUS, CalendarType:=wdCalendarWestern, _
InsertAsFullWidth:=False
frmSelectInsideAddress.Show ' userform which displays a combo box with user
names_
'so the letterhead can be personalized with autotext entries
containing phone / email / etc.
'Automatically insert the current date into the second page header
strDate = Format(Date, "MMMM d, yyyy")
ActiveDocument.Sections(2).Headers(wdHeaderFooterPrimary).Range.InsertBefore
strDate
Unload frmSelectInsideAddress
'Handle Errors Gracefully
EH_Exit:
Exit Sub
EH:
If Err = 429 Then
'Word is not running; open Word with CreateObject
Set appWord = CreateObject("Word.Application")
Resume Next
ElseIf Err = 5151 Then
MsgBox "The template you requested is no longer available. If you
believe this" _
& vbCrLf & " to be an error, contact the Help Desk", , "Document
Name or Path No Longer" _
& " Available."
Resume EH_Exit
Else
MsgBox Err.Number & ": " & Err.Description
Resume EH_Exit
End If
Application.ScreenRefresh
End Sub
Public Function DocsDir() As String
On Error GoTo ErrorHandler
Set appWord = GetObject(, "Word.Application")
DocsDir = appWord.System.PrivateProfileString("", _
"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell
Folders", _
"Personal") & "\"
ErrorHandlerExit:
Exit Function
ErrorHandler:
If Err = 429 Then
'Word is not running; open Word with CreateObject
Set appWord = CreateObject("Word.Application")
Resume Next
Else
MsgBox Err.Number & ": " & Err.Description
Resume ErrorHandlerExit
End If
End Function
--
Dawn Crosier
Microsoft MVP
"Education Lasts a Lifetime"
This message was posted to a newsgroup, Please post replies and questions
to the group so that others can learn as well.
Dawn you are right about previous documents I only want to change new ones.
Please advise further about how to do your idea with a table acting as
source to the footer.
I have provided further details to Taz above also
After the last personnel change I had to edit 500 plus footers, not my idea
of fun!!
