M
mljames
I'm working on a project where I am trying to merge documents i
response to a button click on an Access form.
I'm copied some code fragments below to show you what I have in plac
right now.
Code
-------------------
Public Function InitializeWord() As Boolean
On Error Resume Next
Dim objTemp As Word.Application
Set gobjWordApp = GetObject(, "Word.Application")
If Err <> 0 Then 'Word was not running, so we'll want to close it when we're done.
Err.Clear
Set objTemp = CreateObject("Word.Application") 'necessary workaround for automation bug see mskb Q188546
Set gobjWordApp = CreateObject("Word.Application")
objTemp.Quit
Set objTemp = Nothing
gfWordWasRunning = False
Else
gfWordWasRunning = True
End If
InitializeWord = True
End Function
-------------------
Code
-------------------
Public Function QueueDocs(frm As Form) As Boolean
Dim objWordDoc As cWordDoc
Dim varDoc
Dim rstDoc As DAO.Recordset
Dim strMsg As String
Set rstDoc = frm.RecordsetClone
With rstDoc
.MoveFirst
Set mcolWordDoc = New Collection
Do Until .EOF
If !SelectedYN Then
If ValidateQuery(Nz(!DocQuery, "None"), !DocName, !DocCriteriaName) Then
' ValidateQuery checks to make sure that data exists before allowing the merge to continue.
Set objWordDoc = New cWordDoc
objWordDoc.DocName = !DocName
objWordDoc.DocPath = gstrRootDir & !DocPath
objWordDoc.DocQuery = Nz(!DocQuery, "None")
objWordDoc.DocFunction = Nz(!DocFunction, "")
objWordDoc.DocCriteria = Nz(!DocCriteriaName, "")
mcolWordDoc.Add objWordDoc
End If
End If
.MoveNext
Loop
End With
rstDoc.Close
QueueDocs = True
End Function
-------------------
Code
-------------------
Public Function SendToMerge(mcolWordDoc, bEdit As Boolean) As Boolean
'loop through collection sending one doc at a time to printer
On Error GoTo SendToMergeErr
Dim varDoc
Dim strMsg As String
Dim varStatus
Dim strSQLMerge As String
Dim strSource As String
Dim n As Long
For Each varDoc In mcolWordDoc
If bEdit Then
strMsg = "Previewing " & CStr(varDoc.DocName)
Else
strMsg = "Printing " & CStr(varDoc.DocName)
End If
varStatus = SysCmd(acSysCmdSetStatus, strMsg)
strSource = "DSN=" & gstrcDSNname
Select Case varDoc.DocCriteria
' sets up the strSQLMerge string. i can't include it here for proprietary reasons.
End Select
'Open existing Word Document
With gobjWordApp
.Documents.Open filename:=varDoc.DocPath
Dim templateDoc As Word.Document
Set templateDoc = .ActiveDocument
If Len(varDoc.DocFunction) <> 0 Then
Run varDoc.DocFunction, gobjWordApp, Nz(Screen.ActiveForm!cbo1.Column(1), ""), _
Nz(Screen.ActiveForm!txtID1, "-1"), Nz(Screen.ActiveForm!txtID2, "-1")
End If
With .ActiveDocument.MailMerge
.OpenDataSource Name:=CurrentDb.Name, ConfirmConversions:=False, _
ReadOnly:=True, linkToSource:=True, Connection:=strSource, _
SQLStatement:=strSQLMerge ', SubType:=wdMergeSubTypeWord2000
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.Execute
End With
If Not bEdit Then
'following line needed per kb article #Q159328
.Application.Options.PrintBackground = False
.Application.ActiveDocument.PrintOut
.ActiveDocument.Close wdDoNotSaveChanges
.ActiveDocument.Close wdDoNotSaveChanges 'required twice because of merging to new doc.
Else
templateDoc.Close wdDoNotSaveChanges
' .Visible = True
End If
End With
IterateCollection:
DoEvents 'needed to allow the process to be interrupted
Next varDoc
SendToMerge = True
SendToMergeExit:
Exit Function
SendToMergeErr:
Select Case Err
Case 5922
strMsg = "Word was unable to open the data source for " & varDoc.DocName & ".@@"
strMsg = strMsg & "This document will be skipped for now..."
MsgBox strMsg, vbOKOnly + vbCritical, "Uh-oh"
Err.Clear
Resume IterateCollection
Case 5174 'word doc not found
strMsg = "Word was unable to locate " & vbCrLf & varDoc.DocName & ".@@"
strMsg = strMsg & "Please verify the name and location of the document."
MsgBox strMsg, vbOKOnly + vbCritical
Resume IterateCollection
Case Else
If Err <> 0 Then
MsgBox Err & ":" & Err.Description
End If
Resume SendToMergeExit
End Select
End Function
--------------------
Code:
--------------------
Public Function TerminateWord() As Boolean
gobjWordApp.Application.Quit wdDoNotSaveChanges
Set gobjWordApp = Nothing
TerminateWord = True
End Function
--------------------
Code:
--------------------
Public Function rgbProcessMailMerge(frm As Form, bPreview As Boolean)
Dim fContinue As Boolean
Dim strMsg As String
Dim varReturn
'Create DSN once
strMsg = "Registering DSN..."
varReturn = SysCmd(acSysCmdSetStatus, strMsg)
fContinue = CreateDSN ' This creates a DSN for the current database using the gstrcDSNname variable
If fContinue Then
'Initialize Word
strMsg = "Locating Microsoft Word..."
varReturn = SysCmd(acSysCmdSetStatus, strMsg)
fContinue = InitializeWord
If fContinue Then
'Queue docs
strMsg = "Queueing documents..."
varReturn = SysCmd(acSysCmdSetStatus, strMsg)
fContinue = QueueDocs(frm)
If fContinue Then
'Send to merge
strMsg = "Sending documents to printer..."
varReturn = SysCmd(acSysCmdSetStatus, strMsg)
fContinue = SendToMerge(mcolWordDoc, bPreview)
If Not fContinue Then
If bPreview Then
strMsg = "There was a problem sending documents to Word."
Else
strMsg = "There was a problem sending documents to printer."
End If
MsgBox strMsg, vbOKOnly + vbExclamation
End If
Else
strMsg = "There was a problem queueing the documents."
MsgBox strMsg, vbOKOnly + vbExclamation
End If
If Not bPreview Then
'Terminate Word
strMsg = "Wrapping things up..."
varReturn = SysCmd(acSysCmdSetStatus, strMsg)
fContinue = TerminateWord
If Not fContinue Then
strMsg = "There was a problem finishing the process."
MsgBox strMsg, vbOKOnly + vbExclamation
End If
Else
gobjWordApp.Visible = True
End If
Else
strMsg = "There was a problem locating Microsoft Word."
MsgBox strMsg, vbOKOnly + vbExclamation
End If
Else
strMsg = "There was a problem registering the data source."
MsgBox strMsg, vbOKOnly + vbExclamation
End If
'don't forget to clear status!
varReturn = SysCmd(acSysCmdClearStatus)
--------------------
Some additional information:
- The rgbProcessMailMerge function is the start of the whole thing.
- The varDoc variable is used to facilitate a loop and print multiple
documents off of a document list at a single button click.
- The Run command used right before the mail merge is used to fill in
data that can't be done with a simple query. Namely, these are loops to
fill names of people into the document when the person count is unknown
at design time. The parameters passed in are key data that distinguish
this merge from another. Data is filled in through the use of bookmarks
in the "template" document.
- This needs to work in both Access 2000 and XP, with the corresponding
Word applications. At compile time, the database, which starts out in
an Access 2000 format, is converted to a second database in an Access
XP format. Then, each of the databases is compiled into an mde file.
Before compiling, I also uncomment the :SubType parameter of the
.OpenDataSource method.
- Currently, the Access 2000 version tends to be pretty stable. There
are the occasional errors, but overall, it does well.
- The Access XP version, however, is not performing well at all. It
frequently crashes during the merge process. Also, once I get an error
during the merge, I then get "remote server unavailable" messages until
I restart Access.
- Both versions also, occasionally, give me "Unable to find datasource
errors". I thought for a while that the presence of header information
in the base document was causing this, but I (tried to) remove all of
those, and the errors continue.
On to my questions:
- Would it help if I didn't convert the database to Access XP, but
instead just compiled the mde file in XP with a 2000 formatted
database? Is that even possible?
- Does the :SubType parameter do what it is supposed to do according to
the knowledge base articles that I've read? Is it really necessary?
- Would using the .MainDocumentType property of the MailMerge object
help at all? I tried it once with wdNotAMergeDocument to see if it
still worked and it did. Would this help avoid the data source errors?
- Does anyone have any thoughts or ideas on how I could stabilize this
process for both versions of Access?
Thanks,
Matt James
response to a button click on an Access form.
I'm copied some code fragments below to show you what I have in plac
right now.
Code
-------------------
Public Function InitializeWord() As Boolean
On Error Resume Next
Dim objTemp As Word.Application
Set gobjWordApp = GetObject(, "Word.Application")
If Err <> 0 Then 'Word was not running, so we'll want to close it when we're done.
Err.Clear
Set objTemp = CreateObject("Word.Application") 'necessary workaround for automation bug see mskb Q188546
Set gobjWordApp = CreateObject("Word.Application")
objTemp.Quit
Set objTemp = Nothing
gfWordWasRunning = False
Else
gfWordWasRunning = True
End If
InitializeWord = True
End Function
-------------------
Code
-------------------
Public Function QueueDocs(frm As Form) As Boolean
Dim objWordDoc As cWordDoc
Dim varDoc
Dim rstDoc As DAO.Recordset
Dim strMsg As String
Set rstDoc = frm.RecordsetClone
With rstDoc
.MoveFirst
Set mcolWordDoc = New Collection
Do Until .EOF
If !SelectedYN Then
If ValidateQuery(Nz(!DocQuery, "None"), !DocName, !DocCriteriaName) Then
' ValidateQuery checks to make sure that data exists before allowing the merge to continue.
Set objWordDoc = New cWordDoc
objWordDoc.DocName = !DocName
objWordDoc.DocPath = gstrRootDir & !DocPath
objWordDoc.DocQuery = Nz(!DocQuery, "None")
objWordDoc.DocFunction = Nz(!DocFunction, "")
objWordDoc.DocCriteria = Nz(!DocCriteriaName, "")
mcolWordDoc.Add objWordDoc
End If
End If
.MoveNext
Loop
End With
rstDoc.Close
QueueDocs = True
End Function
-------------------
Code
-------------------
Public Function SendToMerge(mcolWordDoc, bEdit As Boolean) As Boolean
'loop through collection sending one doc at a time to printer
On Error GoTo SendToMergeErr
Dim varDoc
Dim strMsg As String
Dim varStatus
Dim strSQLMerge As String
Dim strSource As String
Dim n As Long
For Each varDoc In mcolWordDoc
If bEdit Then
strMsg = "Previewing " & CStr(varDoc.DocName)
Else
strMsg = "Printing " & CStr(varDoc.DocName)
End If
varStatus = SysCmd(acSysCmdSetStatus, strMsg)
strSource = "DSN=" & gstrcDSNname
Select Case varDoc.DocCriteria
' sets up the strSQLMerge string. i can't include it here for proprietary reasons.
End Select
'Open existing Word Document
With gobjWordApp
.Documents.Open filename:=varDoc.DocPath
Dim templateDoc As Word.Document
Set templateDoc = .ActiveDocument
If Len(varDoc.DocFunction) <> 0 Then
Run varDoc.DocFunction, gobjWordApp, Nz(Screen.ActiveForm!cbo1.Column(1), ""), _
Nz(Screen.ActiveForm!txtID1, "-1"), Nz(Screen.ActiveForm!txtID2, "-1")
End If
With .ActiveDocument.MailMerge
.OpenDataSource Name:=CurrentDb.Name, ConfirmConversions:=False, _
ReadOnly:=True, linkToSource:=True, Connection:=strSource, _
SQLStatement:=strSQLMerge ', SubType:=wdMergeSubTypeWord2000
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.Execute
End With
If Not bEdit Then
'following line needed per kb article #Q159328
.Application.Options.PrintBackground = False
.Application.ActiveDocument.PrintOut
.ActiveDocument.Close wdDoNotSaveChanges
.ActiveDocument.Close wdDoNotSaveChanges 'required twice because of merging to new doc.
Else
templateDoc.Close wdDoNotSaveChanges
' .Visible = True
End If
End With
IterateCollection:
DoEvents 'needed to allow the process to be interrupted
Next varDoc
SendToMerge = True
SendToMergeExit:
Exit Function
SendToMergeErr:
Select Case Err
Case 5922
strMsg = "Word was unable to open the data source for " & varDoc.DocName & ".@@"
strMsg = strMsg & "This document will be skipped for now..."
MsgBox strMsg, vbOKOnly + vbCritical, "Uh-oh"
Err.Clear
Resume IterateCollection
Case 5174 'word doc not found
strMsg = "Word was unable to locate " & vbCrLf & varDoc.DocName & ".@@"
strMsg = strMsg & "Please verify the name and location of the document."
MsgBox strMsg, vbOKOnly + vbCritical
Resume IterateCollection
Case Else
If Err <> 0 Then
MsgBox Err & ":" & Err.Description
End If
Resume SendToMergeExit
End Select
End Function
--------------------
Code:
--------------------
Public Function TerminateWord() As Boolean
gobjWordApp.Application.Quit wdDoNotSaveChanges
Set gobjWordApp = Nothing
TerminateWord = True
End Function
--------------------
Code:
--------------------
Public Function rgbProcessMailMerge(frm As Form, bPreview As Boolean)
Dim fContinue As Boolean
Dim strMsg As String
Dim varReturn
'Create DSN once
strMsg = "Registering DSN..."
varReturn = SysCmd(acSysCmdSetStatus, strMsg)
fContinue = CreateDSN ' This creates a DSN for the current database using the gstrcDSNname variable
If fContinue Then
'Initialize Word
strMsg = "Locating Microsoft Word..."
varReturn = SysCmd(acSysCmdSetStatus, strMsg)
fContinue = InitializeWord
If fContinue Then
'Queue docs
strMsg = "Queueing documents..."
varReturn = SysCmd(acSysCmdSetStatus, strMsg)
fContinue = QueueDocs(frm)
If fContinue Then
'Send to merge
strMsg = "Sending documents to printer..."
varReturn = SysCmd(acSysCmdSetStatus, strMsg)
fContinue = SendToMerge(mcolWordDoc, bPreview)
If Not fContinue Then
If bPreview Then
strMsg = "There was a problem sending documents to Word."
Else
strMsg = "There was a problem sending documents to printer."
End If
MsgBox strMsg, vbOKOnly + vbExclamation
End If
Else
strMsg = "There was a problem queueing the documents."
MsgBox strMsg, vbOKOnly + vbExclamation
End If
If Not bPreview Then
'Terminate Word
strMsg = "Wrapping things up..."
varReturn = SysCmd(acSysCmdSetStatus, strMsg)
fContinue = TerminateWord
If Not fContinue Then
strMsg = "There was a problem finishing the process."
MsgBox strMsg, vbOKOnly + vbExclamation
End If
Else
gobjWordApp.Visible = True
End If
Else
strMsg = "There was a problem locating Microsoft Word."
MsgBox strMsg, vbOKOnly + vbExclamation
End If
Else
strMsg = "There was a problem registering the data source."
MsgBox strMsg, vbOKOnly + vbExclamation
End If
'don't forget to clear status!
varReturn = SysCmd(acSysCmdClearStatus)
--------------------
Some additional information:
- The rgbProcessMailMerge function is the start of the whole thing.
- The varDoc variable is used to facilitate a loop and print multiple
documents off of a document list at a single button click.
- The Run command used right before the mail merge is used to fill in
data that can't be done with a simple query. Namely, these are loops to
fill names of people into the document when the person count is unknown
at design time. The parameters passed in are key data that distinguish
this merge from another. Data is filled in through the use of bookmarks
in the "template" document.
- This needs to work in both Access 2000 and XP, with the corresponding
Word applications. At compile time, the database, which starts out in
an Access 2000 format, is converted to a second database in an Access
XP format. Then, each of the databases is compiled into an mde file.
Before compiling, I also uncomment the :SubType parameter of the
.OpenDataSource method.
- Currently, the Access 2000 version tends to be pretty stable. There
are the occasional errors, but overall, it does well.
- The Access XP version, however, is not performing well at all. It
frequently crashes during the merge process. Also, once I get an error
during the merge, I then get "remote server unavailable" messages until
I restart Access.
- Both versions also, occasionally, give me "Unable to find datasource
errors". I thought for a while that the presence of header information
in the base document was causing this, but I (tried to) remove all of
those, and the errors continue.
On to my questions:
- Would it help if I didn't convert the database to Access XP, but
instead just compiled the mde file in XP with a 2000 formatted
database? Is that even possible?
- Does the :SubType parameter do what it is supposed to do according to
the knowledge base articles that I've read? Is it really necessary?
- Would using the .MainDocumentType property of the MailMerge object
help at all? I tried it once with wdNotAMergeDocument to see if it
still worked and it did. Would this help avoid the data source errors?
- Does anyone have any thoughts or ideas on how I could stabilize this
process for both versions of Access?
Thanks,
Matt James