?
????? ?????
???"ace join_to (e-mail address removed) (Tony Epton)"?? ??? ??????
Windows XP, Office 2003
Purpose of code is to copy a "template" word doc
Stuff lots of values in to form fields.
Tweak up the header & footer
This code works the first time through
but gives
"Error 462
The remote server machine does not exist or is unavailable"
at the first executable line in
Sub TrickyStuffInHeaderFooter
the second time through
Shutting down access and restarting allows the code to run once before
the problem reoccurs.
I strongly suspect I am not releasing an object somewhere.
I am really desparate for some help please - just spent the last 6
hours banging my head against the wall and the deadline is looming.
Many thanks in advance
Tony
Sub BuildWordDocument(lngEvalId As Long, lngDataEntrySiteId As Long,
boolVerbose As Boolean)
Dim strTemplateQuote As String
Dim xlapp As Word.Application
Dim strTemplate As String
Dim fld As Word.FormField
Dim doc As Word.Document
Dim chk As Word.CheckBox
Dim rsEval As Recordset
Dim rsDet As Recordset
Dim rsImage As Recordset
Dim rsSys As Recordset
Dim intCount As Integer
Dim varFunctionLocNo As Variant
Dim strSource As String
Dim boolRC As Boolean
Dim strImageRootDirectory As String
Dim strFld As String
Dim intOutputDocumentNaming As Integer
Dim varCSId As Variant
Dim strFileName As String
Dim strImageList As String
<some code snipped here - mainly to do with defining strSource>
strTemplate = FileStrip(strSource) & "\" & strFileName & "_" &
Format(Now(), "yymmdd_hhnn") & ".doc"
On Error GoTo CopyFileErr
FileCopy strSource, strTemplate
On Error GoTo 0
GoTo CopyFileNoErr
CopyFileErr:
MsgBox "Unable to copy template to " & strTemplate & vbCrLf &
"because " & Err.Description
On Error GoTo 0
rsEval.Close
Set rsEval = Nothing
Exit Sub
CopyFileNoErr:
strTemplateQuote = Chr(34) & strTemplate & Chr(34)
'
' get handle to word application
'
AceDisplayStatus True, "Starting up Word"
DoEvents
Set xlapp = CreateObject("word.application")
xlapp.Visible = True
'
' open the template word document (destination document)
'
xlapp.Documents.Open FileName:=strTemplateQuote,
ConfirmConversions:= _
False, ReadOnly:=False, AddToRecentFiles:=False,
PasswordDocument:="", _
PasswordTemplate:="", Revert:=False,
WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto
'
' get handle to document object
'
Set doc = xlapp.ActiveDocument
'
' Unprotect the document
'
If doc.ProtectionType <> wdNoProtection Then
doc.Unprotect
End If
'
' Poke table values in to all the form fields in the document
'
AceDisplayStatus True, "Header/Footer fields"
TrickyStuffInHeaderFooter doc, rsEval!DocumentNumber,
rsEval!IssueDate, rsEval!ReviewDate
'
' General Fields
'
AceDisplayStatus True, "Filling in General Fields"
DoEvents
DoGeneralFields doc, rsEval
'
' Do sections
'
DoSections doc, lngEvalId
AceDisplayStatus True, "Inserting Images"
'
' Space Plan Images
'
strImageList = InsertImagesIntoDocument(xlapp, "tblSpaceImage",
"SpaceImageTable", boolD, strImageRootDirectory, lngEvalId)
InsertPhotoNotes doc, strImageList, rsEval![SpacePhotoNotes],
"SpacePhotoNotes"
'
' Space Ventilation Images
'
strImageList = InsertImagesIntoDocument(xlapp,
"tblVentilationPlanImage", "VentilationImageTable", boolD,
strImageRootDirectory, lngEvalId)
InsertPhotoNotes doc, strImageList,
rsEval![BaseVentilationPhotoNotes], "BaseVentilationPhotoNotes"
'
' Rescue Plan Images
'
strImageList = InsertImagesIntoDocument(xlapp,
"tblRescuePlanImage", "RescueImageTable", boolD,
strImageRootDirectory, lngEvalId)
InsertPhotoNotes doc, strImageList, rsEval![RescuePlanPhotoNotes],
"RescuePlanPhotoNotes"
'
' Protect the document
'
If doc.ProtectionType = wdNoProtection Then
doc.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
End If
'
' Save & close the output document & shut down word
'
AceDisplayStatus True, "Saving the document"
DoEvents
xlapp.ActiveDocument.Save
doc.Close
'xlapp.ActiveWindow.Close
For i = 1 To 100
DoEvents
DoEvents
Next i
Set doc = Nothing
xlapp.Quit
Set xlapp = Nothing
For i = 1 To 100
DoEvents
DoEvents
Next i
AceDisplayStatus False, "Removing Status screen"
rsEval.Close
Set rsEval = Nothing
If boolVerbose Then
MsgBox "Word document has been saved to " & strTemplate
End If
end sub
Sub TrickyStuffInHeaderFooter(doc As Word.Document, varDocumentNumber
As Variant, varIssueDate As Variant, varReviewDate As Variant)
'
' Poke various values in to the header and footer of the document
' (bookmarks and merge fields do not work here so have to manipulate
in code)
'
With doc
'If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
' ActiveWindow.Panes(2).Close
'End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or
ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "hXXX-XXX-XXX-XXX"
.Replacement.Text = Nz(varDocumentNumber, " ")
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "fXXX-XXX-XXX-XXX"
.Replacement.Text = Nz(varDocumentNumber, " ")
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "idd/mm/yyyy"
If IsNull(varIssueDate) Then
.Replacement.Text = " "
Else
.Replacement.Text = Format(varIssueDate, "dd/mm/yyyy")
End If
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "rdd/mm/yyyy"
If IsNull(varReviewDate) Then
.Replacement.Text = " "
Else
.Replacement.Text = Format(varReviewDate, "dd/mm/yyyy")
End If
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End With
End Sub
)