Re: Automation of a mail merge in access 2003

In trying to bullet-proof this code, I have discovered that the
OpenDataSource method is essential for Access 2002, but not for Access 2000.
As your code didn't call the OpenDataSource method, perhaps that was the
source of error 4605 when the school upgraded.

Well, here is my attempt to make the code blast-proof!

Good luck with your project!
Geoff


Option Compare Database
Option Explicit


' This declaration is not essential, but may be good to tidy the
' screen. In the general declarations section at the top of the
' module, declare the Windows API function SetForegroundWindow&.
' We can call this function to set the focus on the Microsoft
' Access window after the CreateObject function activates
' Microsoft Word (assumes Method 2 below is used to start Word):
Declare Function SetForegroundWindow& Lib "user32" _
(ByVal hwnd As Long)

' For displaying messages:
Private mMsg As gMsg
Private Type gMsg
Message As String
Buttons As VbMsgBoxStyle
Heading As String
RetVal As VbMsgBoxResult
End Type


Public Sub RunMailMerge()

Const MY_QUERY_NAME As String = "MyTempQuery"
Const MY_DATASOURCE As String = "Data.rtf"

Dim objDB As DAO.Database
Dim objQDF As DAO.QueryDef
Dim objRS As DAO.Recordset

Dim objWORD As Word.Application
Dim objWDMAL As Word.Document
Dim objMERGEDDOC As Word.Document

Dim strSQL As String
Dim strPath As String
Dim strMainPathName As String
Dim strDataPathName As String
Dim strFilnavn As String


On Error GoTo ErrorHandler

' ...Your code here to create strSQL and set strFilnavn...

' Get path to working directory:
strPath = Access.Application.CurrentProject.Path
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

' Initialise path\names:
strMainPathName = strPath & strFilnavn & ".dot"
strDataPathName = strPath & MY_DATASOURCE

' Ensure that the main document exists:
If Not FileExists(strMainPathName) Then
GoTo Exit_MainDocNotFound
End If

' Ensure that the data document is deleted:
If FileExists(strDataPathName) Then Kill strDataPathName

' Point to current database:
Set objDB = CurrentDb()

' Ensure that temporary query does not exist:
GoSub DeleteTemporaryQuery

' Recreate temporary query:
Set objQDF = objDB.CreateQueryDef(MY_QUERY_NAME, strSQL)
objDB.QueryDefs.Refresh
Access.Application.RefreshDatabaseWindow

' Create DAO recordset using query:
Set objRS = objQDF.OpenRecordset()

' Exit if query returns no records:
If objRS.BOF And objRS.EOF Then
GoTo Exit_NoRecordsToMerge
End If

' Output data from query:
DoCmd.OutputTo acOutputQuery, MY_QUERY_NAME, _
acFormatRTF, strDataPathName

' Exit if new data file does not exist:
If Not FileExists(strDataPathName) Then
GoTo Exit_NewDataDocNotFound
End If

' Open Microsoft Word using Method 1 or 2:

' Method 1
' This method maybe essential for Word 2003:
Set objWORD = New Word.Application

' Method 2
' You may prefer this method for versions of
' Word before Word 2003. This method may not
' work for Word 2003:
' On Error Resume Next
' Set objWORD = GetObject(, "Word.Application")
' If Err.Number <> 0 Then
' ' The CreateObject function makes Word active.
' ' If you don't like this,
' Set objWORD = CreateObject("Word.Application")
' End If
' On Error GoTo ErrorHandler



' It's faster to use the "With...End With" construct
' when calling out-of-process Automation servers,
' like Word.

' Set up Word:
With objWORD

' Make word visible now in case Word displays
' a dialog that suspends this code:
.Visible = True

' Maximize the Word window:
.WindowState = wdWindowStateMaximize

' Open main template in Word:
Set objWDMAL = .Documents.Add(strMainPathName)

End With

' Set up main document:
With objWDMAL

' Maximize the document window within Word:
.ActiveWindow.WindowState = wdWindowStateMaximize

' Set other options:
.ShowGrammaticalErrors = True
.ShowSpellingErrors = True

End With

' Set up mail merge for main document:
With objWDMAL.MailMerge

' Attach main document to RTF file
' (required for Access 2002):
.OpenDataSource strDataPathName

' Exit if Main document and Datasource not
' able to perform merge:
If .State <> wdMainAndDataSource Then
GoTo Exit_DataSourceNotAttached
End If

' Set up Datasource:
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With

' Set mailmerge options:
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.MainDocumentType = wdFormLetters

' Check mailmerge state before executing merge:
If .State = wdMainAndDataSource Then
.Execute False
Else
GoTo Exit_CannotExecuteMerge
End If

End With

' Set reference to new merged document:
Set objMERGEDDOC = objWORD.ActiveDocument

' Set options for merged document:
With objMERGEDDOC

.ActiveWindow.WindowState = wdWindowStateMaximize
.Activate
.ShowGrammaticalErrors = True
.ShowSpellingErrors = True

End With

' Close main document:
objWDMAL.Close wdDoNotSaveChanges

' Activate Access
' (The CreateObject function will have activated Word
' if Method 2 above was used to start Word).
' The next code line calls the Windows API function
' declared at the top of this module:
SetForegroundWindow& Access.Application.hWndAccessApp

' Show final message:
mMsg.Message = "Mail merge finished."
mMsg.Buttons = vbOKOnly + vbExclamation
mMsg.Heading = "Program Finished" & Space(30)
ShowMessage

' The user may have closed Word by now,
' so ignore (objWord) server errors:
On Error Resume Next

' Show Word:
' Use Visible = False/True to make Word wake up!
' Otherwise, Word remains "frozen" on my system.
objWORD.Visible = False
objWORD.Visible = True
objWORD.Activate

Bye:

' The user may have got here from the ErrorHandler,
' so ensure we finish:
On Error Resume Next

' Delete temporary query:
GoSub DeleteTemporaryQuery

' Delete data document:
If FileExists(strDataPathName) Then Kill strDataPathName

Set objMERGEDDOC = Nothing
Set objWDMAL = Nothing
Set objWORD = Nothing

Set objRS = Nothing
Set objQDF = Nothing
Set objDB = Nothing

Exit Sub

DeleteTemporaryQuery:

For Each objQDF In objDB.QueryDefs
If objQDF.Name = MY_QUERY_NAME Then
objDB.QueryDefs.Delete MY_QUERY_NAME
objDB.QueryDefs.Refresh
Access.Application.RefreshDatabaseWindow
Exit For
End If
Next

Return

Exit_MainDocNotFound:

mMsg.Message = strMainPathName & vbNewLine & vbNewLine _
& "The above main mail merge document was not found." _
& "Mail merge cancelled."
mMsg.Buttons = vbOKOnly + vbExclamation
mMsg.Heading = "Program Terminated"
ShowMessage
GoTo Bye

Exit_NoRecordsToMerge:

mMsg.Message = "There are no records to merge " _
& "at the present time."
mMsg.Buttons = vbOKOnly + vbInformation
mMsg.Heading = "Program Finished"
ShowMessage
GoTo Bye

Exit_NewDataDocNotFound:

mMsg.Message = strDataPathName & vbNewLine & vbNewLine _
& "The above data file was not found."
mMsg.Buttons = vbOKOnly + vbExclamation
mMsg.Heading = "Program Terminated"
ShowMessage
GoTo Bye

Exit_DataSourceNotAttached:

mMsg.Message = "Data source not attached. " _
& "Mail merge cancelled."
mMsg.Buttons = vbExclamation + vbOKOnly
mMsg.Heading = "Program Terminated"
ShowMessage
GoTo Bye

Exit_CannotExecuteMerge:

mMsg.Message = "Cannot execute mail merge."
mMsg.Buttons = vbOKOnly + vbExclamation
mMsg.Heading = "Program Terminated"
ShowMessage
GoTo Bye

ErrorHandler:

mMsg.Message = "Error Number: " & Err.Number _
& vbNewLine & vbNewLine _
& Err.Description
mMsg.Buttons = vbExclamation + vbOKOnly
mMsg.Heading = "Error"
ShowMessage
GoTo Bye

End Sub

Private Function FileExists(PathName As String) As Boolean

FileExists = (Len(Dir(PathName)) > 0)

End Function

Private Sub ShowMessage()

mMsg.RetVal = MsgBox(mMsg.Message, mMsg.Buttons, mMsg.Heading)

End Sub



.