Automating mailmerge from Acces form to Word document (1 Viewer)

msowards

Registered User.
Local time
Today, 10:04
Joined
Feb 16, 2012
Messages
21
I am having the strangest results with my automated mailmerge. Basically it does work, but not all the time. The basic idea is to allow the user to dynamically create a query that produces a result list which fills a temporary table. The use then selects a prebuilt merge template and merge is executed against the temp table. The merge template are of the .doc type, but sme have been converted to .docx; the .doc files tend to work most often, but all of the will eventually get a Table is locked message... However if I run in test mode with code breaks and manually step through the process it always works...
here is the heart of the code ...
Err_Pos = 10

Code:
                DoCmd.SetWarnings False
                ' if tmp tbl left over from last run kill it
                DoCmd.RunSQL "Drop table Word_Merge_Tmp_TBL"
Err_Pos = 12
                ' this create a temp table named "Word_Merge_Tmp_TBL"
                CurrentDb.Execute Create_Tmp_Word_Mrg_QryStr
                
                DoCmd.SetWarnings True
                cont = False
Err_Pos = 15
                For Each Tdef In CurrentDb.TableDefs
                    If StrComp(Tdef.Name, "Word_Merge_Tmp_TBL", vbTextCompare) = 0 Then
                        cont = True
                        Exit For
                    End If
                Next Tdef
                If cont Then
Err_Pos = 20
                    oApp.Quit False
                    Set oApp = Nothing
 Err_Pos = 25
                    Set oApp = CreateObject("Word.Application")
                    Set oMainDoc = oApp.Documents.Open(Mrg_Tmplt_Str, True, False, False, , , True, , , , , , True)
                     
Err_Pos = 30
                    'Set up the mail merge data source to Current DB.
                    sDBPath = CurrentProject.FullName
                    Pause_Ops (5000)
                    With oMainDoc.MailMerge
Err_Pos = 40
            
    
                        .OpenDataSource Name:=sDBPath, _
                            Connection:="DSN=MS Access Database;DBQ=" & CurrentDb.Name & "; FIL=MS Access;", _
                            LinkToSource:=True, AddToRecentFiles:=False, ReadOnly:=True, _
                           SQLStatement:="SELECT * FROM [Word_Merge_Tmp_TBL]"
                        
                    
                    'Perform the mail merge to a new document.
                        .Destination = wdSendToNewDocument
Err_Pos = 50
                        .Execute Pause:=False
                    End With
                    DoCmd.SetWarnings False
                    DoCmd.RunSQL "Drop table Word_Merge_Tmp_TBL"
                    DoCmd.SetWarnings True
                Else
                    If MsgBox("Access Table error!" & vbNewLine & "Cannot find Query results temp table." & vbNewLine & _
                        "Do you want to try again?", vbYesNo + vbQuestion, App_Q_MsgBx_Ttl) = vbYes Then
                        GoTo Re_Try
                    Else
                        GoTo Close_Template_On_Error
                    End If
                End If

There are many error cases in the error catch routine. That I have managed to make Access stop hanging when word has a problem or the table is locked. But I can't get the table to be free consistantly and why does it always work when I manually step through the code. :banghead:
 

JHB

Have been here a while
Local time
Today, 18:04
Joined
Jun 17, 2012
Messages
7,732
You didn't tell in which line the error raise?
Only to show a part of some code is not preferable, show the whole procedure.
However if I run in test mode with code breaks and manually step through the process it always works...
It could be because the system gets time to finish it's work before the next line is executed, therefore sometimes a DoEvents placed in the right place, do wonders.
 

msowards

Registered User.
Local time
Today, 10:04
Joined
Feb 16, 2012
Messages
21
Here are all the inter-related pieces...
The merge modual...

Code:
Private Sub Merge_CMD_Click()
On Error GoTo Err_Merge_CMD_Click

'  need to browes to allow user to select Mailmerge template
'  open document and start mailmerge from this Db

If Not IsNull(Actv_User) Then
    If Len(Actv_User) > 0 Then
        If Me.Slct_Cnt_TXT > 0 Then
            Dim oMainDoc As Word.Document, Mrg_Tmplt_Str As String, App_Path As String
            Dim oSel As Word.Selection, strConnect As String, Create_Tmp_Word_Mrg_QryStr As String
            Dim sDBPath As String, Re_Try_Cnts As Integer, Tdef As TableDef, cont As Boolean, Wait_Cnt As Integer, cls_atmpts As Integer
            Dim Error_Cnts As Integer, ErrAns As Integer, ErrMsg As String, Err_Pos As Integer

            
Err_Pos = 1
            App_Path = CurrentProject.Path
            Mrg_Tmplt_Str = CmnDlg_C_FileOpenSave( _
                                OpFlNm_OVERWRITEPROMPT Or OpFlNm_CREATEPROMPT Or OpFlNm_EXPLORER Or OpFlNm_SHOWHELP, _
                                App_Path, _
                                "*.doc,*.wpd,*.docx", _
                                1, _
                                "", _
                                "", _
                                "Select the Merge template you wish to use", _
                                , _
                                True)
        
            'Open the selected  main document for the mail merge.
            If Len(Mrg_Tmplt_Str) > 0 Then
Err_Pos = 5
                DoCmd.Hourglass True

Re_Try:
Re_Try_Cnts = Re_Try_Cnts + 1
               
                ' run a query to creat a tmp table
                Create_Tmp_Word_Mrg_QryStr = "SELECT Editor_Names_Tbl.Prefix, Editor_Names_Tbl.[First Name], " & _
                "Editor_Names_Tbl.[Mid Name],Editor_Names_Tbl.[Last Name], Editor_Names_Tbl.Suffix, " & _
                "Editor_Names_Tbl.Title, New_Editors_TBL.Greeting,  New_Editors_TBL.DirectDial, " & _
                "New_Editors_TBL.DirectFax, New_Editors_TBL.Email,  New_MAGS_TBL.Publication, " & _
                "New_MAGS_TBL.Address1, New_MAGS_TBL.Address2, New_MAGS_TBL.City, New_MAGS_TBL.State, New_MAGS_TBL.Zip, New_MAGS_TBL.Country, " & _
                "New_MAGS_TBL.Telephone, New_MAGS_TBL.Fax, New_MAGS_TBL.FieldServed, New_MAGS_TBL.[Freq/FEA], New_MAGS_TBL.Shows, " & _
                "New_MAGS_TBL.Circulation, New_MAGS_TBL.Language,  " & _
                "New_MAGS_TBL.PublishingHouse, New_MAGS_TBL.Website, New_MAGS_TBL.Readership, " & _
                "New_MAGS_TBL.AdRates INTO Word_Merge_Tmp_TBL " & _
                "FROM ((Editor_Names_Tbl INNER JOIN New_Editors_TBL ON Editor_Names_Tbl.EditorID=New_Editors_TBL.EditorID) " & _
                "LEFT JOIN New_MAGS_TBL ON New_Editors_TBL.MagID=New_MAGS_TBL.MagID) " & _
                "INNER JOIN Results_Tmp_Tbl ON New_Editors_TBL.EditorID=Results_Tmp_Tbl.EditorID WHERE (((Results_Tmp_Tbl.Selected)=True)) order by Publication;"
Err_Pos = 10

                DoCmd.SetWarnings False
                ' if tmp tbl left over from last run kill it
                'DoCmd.RunSQL "Drop table Word_Merge_Tmp_TBL"
Err_Pos = 12
                ' this creates a temp table named "Word_Merge_Tmp_TBL"
                CurrentDb.Execute Create_Tmp_Word_Mrg_QryStr
                
                DoCmd.SetWarnings True
                cont = False
Err_Pos = 15
              'check the table existence  this has never failed
                For Each Tdef In CurrentDb.TableDefs
                    If StrComp(Tdef.Name, "Word_Merge_Tmp_TBL", vbTextCompare) = 0 Then
                        cont = True
                        Exit For
                    End If
                Next Tdef
                If cont Then
Err_Pos = 20
                    oApp.Quit False
                    Set oApp = Nothing
 Err_Pos = 25
                    Set oApp = CreateObject("Word.Application")
                    Set oMainDoc = oApp.Documents.Open(Mrg_Tmplt_Str, True, False, False, , , True, , , , , , True)
                     
Err_Pos = 30
                    'Set up the mail merge data source to Current DB.
                    sDBPath = CurrentProject.FullName
                    Pause_Ops (5000)
                    With oMainDoc.MailMerge
Err_Pos = 40
            
  'open the merge  data source - this database   
                        .OpenDataSource Name:=sDBPath, _
                            Connection:="DSN=MS Access Database;DBQ=" & CurrentDb.Name & "; FIL=MS Access;", _
                            LinkToSource:=True, AddToRecentFiles:=False, ReadOnly:=True, _
                           SQLStatement:="SELECT * FROM [Word_Merge_Tmp_TBL]"
                        
                    
                    'Perform the mail merge to a new document.
                        .Destination = wdSendToNewDocument
Err_Pos = 50
                        .Execute Pause:=False
                    End With
                    DoCmd.SetWarnings False
                    DoCmd.RunSQL "Drop table Word_Merge_Tmp_TBL"
                    DoCmd.SetWarnings True
                Else
                    If MsgBox("Access Table error!" & vbNewLine & "Cannot find Query results temp table." & vbNewLine & _
                        "Do you want to try again?", vbYesNo + vbQuestion, App_Q_MsgBx_Ttl) = vbYes Then
                        GoTo Re_Try
                    Else
                        GoTo Close_Template_On_Error
                    End If
                End If
            Else
                MsgBox "Merge Cancelled.", vbOKOnly + vbInformation, App_N_MsgBx_Ttl
            End If
        Else
           MsgBox "No Editors Selected.", vbInformation + vbOKOnly, App_N_MsgBx_Ttl
        End If
    Else
        MsgBox "Lost Global variables!" & vbCrLf & _
        "For security purposes please close and reopen Database.", vbExclamation + vbOKOnly, App_S_MsgBx_Ttl
    End If
Else
    MsgBox "Lost Global variables!" & vbCrLf & _
    "For security purposes please close and reopen Database.", vbExclamation + vbOKOnly, App_S_MsgBx_Ttl
End If

GoTo Exit_Merge_CMD_Click

Close_Template_On_Error:
    oMainDoc.Close False
    If Not oApp Is Nothing And cls_atmpts < 4 Then
        cls_atmpts = cls_atmpts + 1
        oApp.Quit False
        Set oApp = Nothing
    End If
    DoCmd.SetWarnings False
    DoCmd.RunSQL "Drop table Word_Merge_Tmp_TBL"
    DoCmd.SetWarnings True
Exit_Merge_CMD_Click:
    

    DoCmd.SetWarnings True
    DoCmd.Hourglass False
    Exit Sub

Err_Merge_CMD_Click:
Error_Cnts = Error_Cnts + 1
    If Error_Cnts > 1000 Then
        If ErrChoice = vbYesNoCancel Then
            ErrMsg = "Error count too high!  " & Error_Cnts & vbCrLf & Err.Description & ": " & Str(Err.Number) & vbNewLine & "Press 'Yes' to resume next;" & vbCrLf & _
                "'No' to Exit Procedure." & vbCrLf & "or 'Cancel' to break into code"
        Else
            ErrMsg = "Error count too high!  " & Error_Cnts & vbCrLf & Err.Description & ": " & Str(Err.Number) & vbNewLine & "Press 'Yes' to resume next;" & vbCrLf & _
                "'No' to Exit Procedure."
        End If
        ErrAns = MsgBox(ErrMsg, _
            vbCritical + vbQuestion + ErrChoice, Me.Name & ": Merge_CMD_Click")
        If ErrAns = vbYes Then
            Resume Next
        ElseIf ErrAns = vbCancel Then
            On Error GoTo 0
            Resume
        Else
            Resume Close_Template_On_Error
        End If
    Else
        Select Case Err.Number
            Case 91
                Resume Next
            Case 462 'remote server ??? error
                If Err_Pos = 20 Then Resume Next
                Select Case MsgBox(Err.Number & ": " & Err.Description & vbCrLf & "'Yes' to resume next" & vbCrLf & "'No' to cancel procedure" & vbCrLf & _
                "Cancel to break into code", vbCritical + vbYesNoCancel, App_Q_MsgBx_Ttl)
                    Case vbYes
                        cls_atmpts = 0
                        Re_Try_Cnts = 0
                        Resume Next
                    Case vbNo
                        Resume Close_Template_On_Error
                    Case vbCancel
                        On Error GoTo 0
                        Resume
                End Select
            
            Case 3009 'wait and try again
                Wait_Cnt = Wait_Cnt + 1
                If Wait_Cnt < 3 Then
                    Pause_Ops (10000)
    MsgBox "Had to wait"  'remove me befor delivery
                    Resume
                Else
                    If MsgBox("Table Locked!  This has produced error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
                    "Press 'Yes' to re-try; press 'No' to terminate merge attempt.", _
                        vbYesNo + vbInformation, App_N_MsgBx_Ttl) = vbYes Then
                        Wait_Cnt = 0
                        Resume Re_Try
                    Else
                        Resume Close_Template_On_Error
                    End If
                End If
            Case 3010 ' table already exists
                If Re_Try_Cnts < 6 Then
                    If Err_Pos < 15 Then
                        Pause_Ops (2000)
                        DoCmd.SetWarnings False
                        DoCmd.RunSQL "Drop table Word_Merge_Tmp_TBL"
                        DoCmd.SetWarnings True
                        Resume
                    End If
                End If
                If ErrChoice = vbYesNoCancel Then
                    ErrMsg = "Error count too high!  " & Error_Cnts & vbCrLf & Err.Description & ": " & Str(Err.Number) & vbNewLine & "Press 'Yes' to resume next;" & vbCrLf & _
                        "'No' to Exit Procedure." & vbCrLf & "or 'Cancel' to break into code"
                Else
                    ErrMsg = "Error count too high!  " & Error_Cnts & vbCrLf & Err.Description & ": " & Str(Err.Number) & vbNewLine & "Press 'Yes' to resume next;" & vbCrLf & _
                        "'No' to Exit Procedure."
                End If
            Case 3211 ' Table in use
                If Re_Try_Cnts < 6 Then
                    If Err_Pos = 10 Then
                        Resume Next
                    Else
                        Pause_Ops (2000)
                        Resume Re_Try
                    End If
                Else
                    MsgBox "Re Try counts have reached " & Re_Try_Cnts & ":" & Err_Pos & ".  This has produced error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
                    "Merge process terminated.", _
                        vbOKOnly + vbInformation, App_N_MsgBx_Ttl
                        Resume Close_Template_On_Error
                End If
            Case 3376  ' table not found to delete
                Resume Next
            Case 5922
                MsgBox "The database is in an unstable state.  Please exit and reopen Database and try again.", vbOKOnly + vbCritical, App_N_MsgBx_Ttl
                    Resume Close_Template_On_Error
            Case Else
                If ErrChoice = vbYesNoCancel Then
                    ErrMsg = Err.Description & ": " & Str(Err.Number) & vbNewLine & "Press 'Yes' to resume next;" & vbCrLf & _
                        "'No' to Exit Procedure." & vbCrLf & "or 'Cancel' to break into code"
                Else
                    ErrMsg = Err.Description & ": " & Str(Err.Number) & vbNewLine & "Press 'Yes' to resume next;" & vbCrLf & _
                        "'No' to Exit Procedure."
                End If
        End Select
        ErrAns = MsgBox(ErrMsg, _
            vbCritical + vbQuestion + ErrChoice, Me.Name & ": Merge_CMD_Click")
        If ErrAns = vbYes Then
            Resume Next
        ElseIf ErrAns = vbCancel Then
            On Error GoTo 0
            Resume
        Else
            Resume Close_Template_On_Error
        End If
    End If
End Sub
The form global declaration to catch word events...
Code:
Dim WithEvents oApp As Word.Application
the aftermerge event procedure...

Code:
Private Sub oApp_MailMergeAfterMerge(ByVal Doc As Word.Document, ByVal DocResult As Word.Document)
On Error GoTo Err_oApp_MailMergeAfterMerge

    'When the mail merge is complete, 1) close the mail merge document         'leaving only the resulting document open,  2) make Word visible,  and
    ' 3) display a message.

    Doc.Close False
    
    MsgBox "Merge Complete: " & oApp.ActiveDocument.Name, vbOKOnly + vbInformation, App_N_MsgBx_Ttl
    
    
    oApp.Visible = True

    
Exit_oApp_MailMergeAfterMerge:
    Exit Sub

Err_oApp_MailMergeAfterMerge:
    Select Case Err.Number
        Case Else
            Dim ErrAns As Integer, ErrMsg As String
            If ErrChoice = vbYesNoCancel Then
                ErrMsg = Err.Description & ": " & Str(Err.Number) & vbNewLine & "Press 'Yes' to resume next;" & vbCrLf & _
                    "'No' to Exit Procedure." & vbCrLf & "or 'Cancel' to break into code"
            Else
                ErrMsg = Err.Description & ": " & Str(Err.Number) & vbNewLine & "Press 'Yes' to resume next;" & vbCrLf & _
                    "'No' to Exit Procedure."
            End If
            ErrAns = MsgBox(ErrMsg, _
                vbCritical + vbQuestion + ErrChoice, Me.Name & ": oApp_MailMergeAfterMerge")
            If ErrAns = vbYes Then
                Resume Next
            ElseIf ErrAns = vbCancel Then
                On Error GoTo 0
                Resume
            Else
                Resume Exit_oApp_MailMergeAfterMerge
            End If
    End Select
End Sub
The main reason I didn't say where there error occurs is because it seems to move; most of the time it occurs at err_pos 10 - which means the table delete. But that error should not be occurring unless the table is being held by the closed word document. The other big error happens at err_pos 40, but when it does happen Access and the Word process hang. So I'm unable to get a clear idea what is going on. When the process work it does a beautiful job and the user likes it, but I can't have unexpected hangs. I don't like my current error routines and I'll smooth them out when I fix this error problem.

I'm going to test some do event placements and see what happens...
 

msowards

Registered User.
Local time
Today, 10:04
Joined
Feb 16, 2012
Messages
21
The Strategically placed DoEvents through out the code seemed to do the trick. What was odd is the Pause_Ops(XXXX) is a global sub that does just that; it loops performing DoEvents while waiting for XXXX milliseconds to pass and that was not enough.
Anyway thanks for the suggestion. And if anyone wants to use similar automated mailmerge from Access to word code. I also made a major change. I removed the Dim Withevents declaration of oAPP which effectively got rid of the oApp_AfterMerge event sub routine. I moved the actions from the AfterMerge sub to directly after the merge .Execute command in the merge sub routine.
It works really smooth now allowing the user to select any ready made merge template and produce merge output from the query they dynamically created. A 2000+ record result merges in less than 20 seconds. Before when the user would export to word, this query result would take 2hrs+.
 

JHB

Have been here a while
Local time
Today, 18:04
Joined
Jun 17, 2012
Messages
7,732
... What was odd is the Pause_Ops(XXXX) is a global sub that does just that; it loops performing DoEvents while waiting for XXXX milliseconds to pass and that was not enough.
If it is only a loop it doesn't really giving the handling back to the system, because a loop required handling from the system, (counting or what ever it is in there).
 

Users who are viewing this thread

Top Bottom