[AccessD] Word Automation Question
Jim Dettman
jimdettman at verizon.net
Fri May 11 11:46:46 CDT 2018
I have some very old code for pushing data into bookmarks from the Access
side.
I know JC took that and added to it for something he was doing.
Shouldn't take much though to bring it up to date. Was straight forward
enough.
The main function is below. I'll send you the DB in a minute.
Jim.
Function AutomateWord(ByVal varMergeName As Variant, ByVal strProcessFlag As
String, Optional ByVal fDestroyObject As Variant) As Integer
' Purpose:
' Based on the data stored in tblAuto, tblAutoFields, and
tblAutoParams,
' this function use Automation to control Word,
' It inserts data into a document (varWordDoc) and prints the
document.
' This is completely driven by the tblAuto, tblAutoFields, and
tblAutoParams tables.
' (This function was originally written to use DDE.)
' In:
' varWordDoc = name of Word document
' fOneRec = use first record only, even if multiple records in query
' fDestroyObject = set object variable to Nothing when done
' Out:
' Return value: True if successful; False if failure
' History:
' Created 11/10/94 pel; Last Modified 04/20/97 pel
' Updated 03/10/98 Jrd - Added tblAutoParams and new arguments.
' Updated 05/29/98 JRD - Forced word to not background print.
' If background printing on, timing issues
resulted.
On Error GoTo AutomateWordErr
Dim db As Database
Dim rstHeader As Recordset
Dim rstFields As Recordset
Dim rstParams As Recordset
Dim rstData As Recordset
Dim varWordDocName As Variant
Dim varQueryName As Variant
Dim prmName As Parameter
Dim qdfData As QueryDef
Dim varDocAndPath As Variant
Dim varPreprocessFunction As Variant
Dim varQueryParameter As Variant
Dim varSendFields As Variant
Dim varDocPrint As Variant
Dim varDocMacroPrint As Variant
Dim varCopies As Variant
Dim varReturn As Variant
Dim intI As Integer
Dim intJ As Integer
Dim fOneRec As Integer
' 32-bit version follows
Dim avarFields As Variant
' 16-bit version follows
'Dim avarFields() As Variant
' Next two lines needed for 16-bit version only
'Dim intFieldsRecCnt As Integer
'Dim intFieldsFldLim As Integer
Dim intFieldsRecLim As Integer
Const strProc = "AutomateWord"
Const pelMaxFields = 25
Const pelQuote = """"
Const pelFldWWBookmark = 0
Const pelFldAccessField = 1
Const pelFldWWFont = 2
Const pelFldWWPoints = 3
Const pelFldWWBold = 4
Const pelFldWWItalics = 5
Const pelFldWWUnderline = 6
Const pelWordMacroRun = 1
Const pelWordFileCloseNoSave = 2
' Set process options
Select Case strProcessFlag
Case "P"
' If preview mode.
fOneRec = True
varDocPrint = False
Case "T"
' Test print
fOneRec = True
varDocPrint = True
Case Else
' Assume normal print
fOneRec = False
varDocPrint = True
End Select
' optional parameters only work in 32-bit land
If IsMissing(fDestroyObject) Then fDestroyObject = True
AutomateWord = False
Set db = CurrentDb()
Set rstHeader = db.OpenRecordset("select * from tblAutoHeader where
[MergeName] = " & pelQuote & varMergeName & pelQuote, dbOpenSnapshot,
dbForwardOnly)
If rstHeader.RecordCount < 1 Then
MsgBox "Can't continue because tblAutoHeader record not found.",
vbCritical + vbOKOnly, strProc
GoTo AutomateWordDone
End If
' Grab information from header record
varWordDocName = rstHeader!WWDocument
varQueryName = rstHeader!QueryName
varPreprocessFunction = rstHeader!PreProcessFunction
varSendFields = rstHeader!SendFields
varDocMacroPrint = rstHeader!DocMacroPrint
varCopies = rstHeader!DocCopies
rstHeader.Close
' Perform pre-process function if required
If Not IsNull(varPreprocessFunction) Then
varReturn = Eval(varPreprocessFunction)
If Not varReturn Then
MsgBox "Cannot continue because preprocess failed.", vbCritical
+ vbOKOnly, strProc
GoTo AutomateWordDone
End If
End If
' Grab field information
Set rstFields = db.OpenRecordset("Select WWBookmark, AccessField,
WWFont, WWPoints, WWBold, WWItalics, WWUnderline From tblAutoFields Where
[MergeName] = " & pelQuote & varMergeName & pelQuote, dbOpenSnapshot)
If rstFields.RecordCount < 1 Then
MsgBox "Error: no tblAutoFields records were found.", vbCritical +
vbOKOnly, strProc
GoTo AutomateWordDone
End If
' The following only works in 32-bit Access
' Use GetRows method to fill avarFields array
' with the records from tblAutoFields
avarFields = rstFields.GetRows(pelMaxFields)
intFieldsRecLim = UBound(avarFields, 2) + 1
' But in 16-bit world, we'll have to move through
' the field records one at a time
' *** beginning of 16-bit code ***
'rstFields.MoveLast
'intFieldsRecLim = rstFields.RecordCount
'intFieldsFldLim = rstFields.Fields.Count
'ReDim avarFields(0 To intFieldsFldLim, 0 To intFieldsRecLim)
'intFieldsRecCnt = 0
'rstFields.MoveFirst
'Do While Not rstFields.EOF
' For intI = 0 To intFieldsFldLim - 1
' avarFields(intI, intFieldsRecCnt) = rstFields.Fields(intI)
' Next intI
' intFieldsRecCnt = intFieldsRecCnt + 1
' rstFields.MoveNext
'Loop
' *** end of 16-bit code ***
rstFields.Close
'32-bit only
If intFieldsRecLim = pelMaxFields Then
MsgBox "Warning: maximum number of fields reached.", vbInformation +
vbOKOnly, strProc
End If
' Begin Automation conversation with Word
' Don't need to intialize mobjWord if it already points to Word
If mobjWord Is Nothing Then
On Error Resume Next
Set mobjWord = GetObject(, "Word.Basic")
If Err <> 0 Then
Err = 0
Set mobjWord = CreateObject("Word.Basic")
End If
If Err <> 0 Then
MsgBox "Error: Word Automation object could not be created.",
vbCritical + vbOKOnly, strProc
GoTo AutomateWordDone
End If
On Error GoTo AutomateWordErr
End If
' Make sure background printing is turned off.
mobjWord.ToolsOptionsPrint , , , , , , , , , 0
' Open querydef and set parameters if necessary.
Set qdfData = db.QueryDefs(varQueryName)
Set rstParams = db.OpenRecordset("Select * From tblAutoParams Where
[MergeName] = " & pelQuote & varMergeName & pelQuote, dbOpenSnapshot)
For intI = 0 To qdfData.PARAMETERS.Count - 1
Set prmName = qdfData.PARAMETERS(intI)
rstParams.FindFirst "MergeName = '" & varMergeName & "' AND
ParamName = '" & prmName.Name & "'"
If rstParams.NoMatch Then
MsgBox "Can't continue because value for parameter '" &
prmName.Name & "' is not in tblAutoParams.", vbCritical + vbOKOnly, strProc
GoTo AutomateWordDone
Else
prmName.Value = Eval(rstParams![ParamValue])
End If
Next intI
rstParams.Close
Set rstParams = Nothing
' Create data recordset
Set rstData = qdfData.OpenRecordset(dbOpenSnapshot, dbForwardOnly)
If rstData.RecordCount < 1 Then
MsgBox "Can't continue because no records returned by '" &
varQueryName & "' query.", vbCritical + vbOKOnly, strProc
GoTo AutomateWordDone
End If
' Docment is located in current database directory.
varDocAndPath = GetDBDir() & varWordDocName
' Create a new document for each data record.
Do While Not rstData.EOF
mobjWord.FileOpen varDocAndPath
' Send data, if any, over to document and format it
If varSendFields Then
' Move through tblAutoFields row by row
' and send over data to document
For intJ = 0 To intFieldsRecLim - 1
' Jump to bookmark
mobjWord.EditGoto avarFields(pelFldWWBookmark, intJ)
'mobjWord.Selection.Goto What:=wdGoToBookmark,
Name:=avarFields(pelFldWWBookmark, intJ)
' Format the font per field specification
mobjWord.FormatFont avarFields(pelFldWWPoints, intJ),
IIf(avarFields(pelFldWWUnderline, intJ), 1, 0), , , , , , , , , , , , , ,
avarFields(pelFldWWFont, intJ), IIf(avarFields(pelFldWWBold, intJ), 1, 0),
IIf(avarFields(pelFldWWItalics, intJ), 1, 0)
' Insert the data at the bookmark
mobjWord.INSERT
pelNullToZLS(rstData(avarFields(pelFldAccessField, intJ)))
Next intJ
End If ' varSendFields
Debug.Print "Loaded and formatted data for " & rstData.[Name]
' Print the document, if required
' Otherwise shift focus to document for user edit
If varDocPrint Then
' Print the document if required
' Use a Print Macro if one has been specified
DoEvents
If IsNull(varDocMacroPrint) Then
mobjWord.FilePrint , , , , , , , pelNullToZLS(varCopies)
Else
mobjWord.ToolsMacro varDocMacroPrint, pelWordMacroRun
End If
Debug.Print "Printed document"
End If
DoEvents
DoEvents
If varDocPrint Then
mobjWord.FileClose pelWordFileCloseNoSave
Debug.Print "Executed File Close"
DoEvents
DoEvents
End If
' If requested as one record only,
' it's time to bail out!
If fOneRec Then
Exit Do
Else
rstData.MoveNext
End If
Loop
rstData.Close
Set rstData = Nothing
If fOneRec And Not varDocPrint Then
' Now shift focus to Word
mobjWord.AppShow
AppActivate "Microsoft Word - " & varWordDocName
Else
AppActivate "Microsoft Access"
End If
AutomateWord = True
AutomateWordDone:
On Error Resume Next
If fDestroyObject Then Set mobjWord = Nothing
If Not rstHeader Is Nothing Then rstHeader.Close
If Not rstFields Is Nothing Then rstFields.Close
If Not rstData Is Nothing Then rstData.Close
If Not rstParams Is Nothing Then rstData.Close
On Error GoTo 0
Exit Function
AutomateWordErr:
DoCmd.Hourglass False
Select Case Err
Case Else
MsgBox "Error#" & Err & ": " & Error, vbCritical + vbOKOnly,
"AutomateWord"
End Select
Resume AutomateWordDone
End Function
-----Original Message-----
From: AccessD [mailto:accessd-bounces at databaseadvisors.com] On Behalf Of
Rocky Smolin
Sent: Friday, May 11, 2018 11:59 AM
To: 'Access Developers discussion and problem solving'; 'Off Topic'
Subject: [AccessD] Word Automation Question
<<snip>>
More information about the AccessD
mailing list