Automating a MailMerge

[MarkusArchus]

Is there a way to programmatically reproduce the functionality of MergeIt With Microsoft Word without having to manually go through the wizard. If use application.runcommand WordMailMerge, it starts the wizard but then I have to manually choose whether to link to an existing document or create a new one, and specify the file. I'd like to write a procedure where I can specify the path to the document and automate the whole process.

 

[Kotaro24]

I use this code module, which is modified from a MS KB article. Hands-free.

Option Compare Database
Option Explicit
'Version 1.1(1)
'From Access '97 KB Article Q159328
'REQUIRES: LibCommonFunctions, LibFileFunctions,
' Reference to Microsoft Word 8.0 Object Library (MSWord8.olb)
'
'These Functions are Included:
' MS_MailMerge(MSWordDocument, SourceTableName) Returns True if it worked
' CreateMS_WordDocWithMergeFields(MSWordDocument, SourceTableName) Returns True if it worked
' OpenWordDoc(MSWordDocument) Opens MS Word, displayed to Screen
'
'*********'*********'*********'*********'*********'*********'*********'**(79)**

'REQUIRES: Reference to Microsoft Word 8.0 Object Library (MSWord8.olb)
Public Function MS_MailMerge(ByVal iDocNameAndPath As String, ByVal iTableName As String) As Boolean
Dim dbMSMM As Database
Dim objWord As Word.Document

If Not Lookup(iDocNameAndPath) Then
MsgBox &quot;<&quot; & iDocNameAndPath & &quot;>&quot;, vbCritical + vbOKOnly, &quot;MS-Word Document does not exist!&quot;
Exit Function
End If

Set dbMSMM = Currentdb
Set objWord = GetObject(iDocNameAndPath, &quot;Word.Document&quot
' Make Word visible.
objWord.Application.Visible = True
' Set the mail merge data source as the Northwind database.
objWord.MailMerge.OpenDataSource _
Name:=dbMSMM.Name, _
LinkToSource:=True, _
Connection:=&quot;TABLE &quot; & iTableName, _
SQLStatement:=&quot;Select * from [&quot; & iTableName & &quot;]&quot;
'Execute the mail merge in the Mail Merge Document.
'objWord.MailMerge.Execute

objWord.MailMerge.Destination = wdSendToNewDocument
objWord.MailMerge.Execute

'The following line must follow the Execute statement because the
'PrintBackground property is available only when a document window is
'active. Without this line of code, the function will end before Word
'can print the merged document.
objWord.Application.Options.PrintBackground = False
objWord.Application.ActiveDocument.PrintOut
objWord.Application.Quit savechanges:=False

Set objWord = Nothing
Set dbMSMM = Nothing
MS_MailMerge = True
End Function


'
' SAMPLE CODE for CreateMS_WordDocWithMergeFields Function
'Private Sub cmdCreate_Click()
'Dim FileCreated As Boolean
'Dim LetterPath$
'
' LetterFileName$ = InputBox(&quot;Enter Name of New Letter:&quot;, &quot;Create a New Mail-merge Letter&quot
' If LetterFileName$ <> &quot;&quot; Then
' File$ = LetterFileName$
' LetterPath$ = StripFile(tLookup(&quot;LiveDataMDB&quot;, &quot;SystemSwitches&quot;, &quot;ID>0&quot)
' LetterFileName$ = LetterPath$ & LetterFileName$
'
' 'Requires Reference to 'Microsoft Word 8.0 Object Library'.
' FileCreated = CreateMS_WordDocWithMergeFields(LetterFileName$, &quot;Referrals&quot
' DoEvents
' 'cmdEdit_Click ' Letter created, now shell out to it
' End If
'End Sub
'
Public Function CreateMS_WordDocWithMergeFields(ByVal iDocNameAndPath As String, ByVal iTableName As String) As Boolean
Dim dbCMSWWMF As Database
Dim rst As Recordset
Dim tdf As TableDef
Dim fld As Field
'Dim File$
Dim HdrFieldsFile$ ' MS Word requires mailmerge fields in a .doc file
Dim I$
'Dim LetterPath$

'Requires Reference to 'Microsoft Word 8.0 Object Library'.
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document

Set dbCMSWWMF = Currentdb
If iDocNameAndPath <> &quot;&quot; Then
If Lookup(iDocNameAndPath) Then
MsgBox &quot;Sorry, MS-Word Document <&quot; & iDocNameAndPath & &quot;> already exists!&quot;, vbInformation + vbOKOnly, &quot;Can't create file&quot;
Else
Set wrdApp = CreateObject(&quot;Word.Application&quot
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Add
wrdDoc.Select ' Using this document...
If TableDefExists(iTableName) Then
I$ = &quot;&quot;
Set tdf = dbCMSWWMF.TableDefs(iTableName)
For Each fld In tdf.Fields
I$ = I$ & fld.Name & &quot;, &quot;
Next fld
Set tdf = Nothing
' I$ = SetMid(I$, &quot;&quot;, Len(I$) - 1, 2) ' Strip off trailing comma and space
I$ = I$ & &quot;DateToday&quot; ' In your SELECT, include &quot;Date() AS DateToday&quot;
HdrFieldsFile$ = StripFile(iDocNameAndPath) & &quot;FldNames.doc&quot; ' Filename of Mailmerge fields
If Lookup(HdrFieldsFile$) Then Kill HdrFieldsFile$ ' Better to recreate it each time
If Not Lookup(HdrFieldsFile$) Then
wrdDoc.MailMerge.CreateHeaderSource Name:=HdrFieldsFile$, _
Headerrecord:=I$
Else
wrdDoc.MailMerge.CreateHeaderSource Name:=HdrFieldsFile$
End If
wrdDoc.SaveAs iDocNameAndPath
wrdDoc.Close
wrdApp.Quit
CreateMS_WordDocWithMergeFields = True
Else
MsgBox &quot;Sorry, Table <&quot; & iTableName & &quot;> does not exist!&quot;
End If
End If
End If
Set dbCMSWWMF = Nothing
End Function

Public Function OpenWordDoc(ByVal iDocNameAndPath As String) As Boolean
Dim objWord As Word.Application
Dim objDoc As Word.Document

'Handle errors at each step
On Error Resume Next
'try to use the current instance of Word
Set objWord = GetObject(, &quot;Word.Application&quot
'if there is no current instance, create one
If Err <> 0 Then
Err.Clear
Set objWord = CreateObject(&quot;Word.Application&quot
If Err <> 0 Then
MsgBox &quot;Unable to create Word instance!&quot;, vbCritical
GoTo donehere
End If
End If

'Handle errors in error handler
On Error GoTo ErrorHandler
With objWord
.Visible = True
.WindowState = wdWindowStateMaximize
.Activate
Set objDoc = .Documents.Open(FileName:=iDocNameAndPath, ReadOnly:=True)
End With


donehere:
Set objWord = Nothing
Set objDoc = Nothing
Exit Function

ErrorHandler:
MsgBox &quot;Unexpected error: &quot; & Err.Number & &quot;. &quot; & Err.Description
Resume donehere
End Function

 

[MarkusArchus]

Thanks, that's exactly what I needed.