I don't know how close this will be to what you want, but the following is
code from a module in an Access database which executes a Word mail merge
based on an Access query and creates a .PDF file from the resulting Word
document. The file name for the .PDF document is entered manually, however,
not generated by the code. It does not save the file as a Word document
prior to printing to the .PDF file, but this could be added to the code very
simply, calling the SaveAs method of the Word document.
It uses the CutePDF Writer printer driver, available from
http://www.cutepdf.com but could easily be amended to use any other PDF
printer driver. CutePDF Writer automatically prompts for a name for the
file, so this doesn't need to be done in the code:
''''module starts''''
Option Compare Database
Option Explicit
Public Function WordMergePrintToPDF(strQuery As String, _
strDataDoc As String, _
strMergeFile As String, _
Optional blnSuppressBlankLines As Boolean = True)
' Merges data from query into Word document and creates PDF file
' from result, prompting user for file name.
' Accepts: Name of Access query providing data for merge - String.
' Path to Word data file created from query - String.
' Path to Word document to be used for merge - String.
' Optional setting to suppress or show blank lines
' if data missing ( Default = True ) - Boolean
On Error GoTo Err_Handler
Dim dbs As DAO.Database, rst As DAO.Recordset
Set dbs = CurrentDb
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim wApp As Object
Dim wDoc As Object
Dim blnWordNotOpen As Boolean
Dim strPrinter As String
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs(strQuery)
For Each prm In qdf.Parameters
prm = Eval(prm.Name)
Next prm
Set rst = qdf.OpenRecordset
' exit function if recordset is empty
If rst.BOF And rst.EOF Then
MsgBox "No data to merge.", vbInformation, "Mail Merge"
GoTo Exit_here
End If
Set wApp = GetWordApp()
' get current Word active printer
strPrinter = wApp.ActivePrinter
' set Word ActivePrinter to CutePDF Writer
wApp.ActivePrinter = "CutePDF Writer"
' close datasource document if open in Word
For Each wDoc In wApp.Documents
If wDoc.Path & "\" & wDoc.Name = strDataDoc Then
wDoc.Close wdDoNotSaveChanges
End If
Next wDoc
' delete current Word data file.
' ignore error if file doesn't exist
On Error Resume Next
Kill strDataDoc
On Error GoTo 0
' create new Word data file
DoCmd.TransferText acExportMerge, , strQuery, strDataDoc
' open word merge document
Set wDoc = wApp.Documents.Open(strMergeFile)
' execute merge
With wDoc.MailMerge
.OpenDataSource strDataDoc
.SuppressBlankLines = blnSuppressBlankLines
.Destination = wdSendToNewDocument
.Execute
End With
' print the document
wApp.ActiveDocument.PrintOut Background:=False
' restore Word active printer
wApp.ActivePrinter = strPrinter
' close Word documents
wApp.ActiveDocument.Close (wdDoNotSaveChanges)
wDoc.Close (wdDoNotSaveChanges)
' close Word if not open when this function called
If blnWordNotOpen Then
wApp.Quit
End If
Exit_here:
Set wApp = Nothing
Set rst = Nothing
Set dbs = Nothing
Exit Function
Err_Handler:
MsgBox Err.Description & " (" & Err.Number & ")", vbExclamation, "Error"
Resume Exit_here
End Function
Private Function GetWordApp() As Object
' if Word open return reference to it
' else establish reference to it
On Error Resume Next
Set GetWordApp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Set GetWordApp = CreateObject("Word.Application")
End If
End Function
''''module ends''''
Ken Sheridan
Stafford, England
