Access to Word Merge Process 3

[LarryDeLaruelle]

I am setting up a merge routine in Access to merge selected data to a Word form. The form was created as a mailmerge and linked to a table in Access (the database uses Access security).

On a form, the user selects the record to merge and clicks on a command button to initiate the merge. The merge process runs a make table query for the selected record, opens the word document (prompts twice for UserID/Password??) then merges the data into the document. So far so good.

If I then try to run the merge for another record, I get the run time error 3262 -- "Couldn't lock table 'tblWordMerge'; currently in use by . . . ". I have figured out that this is because of the iteration of the database that was opened for the merge -- if I close that, the merge will work fine.

Here is the code I have so far:

Dim objWord As Word.Document
Dim strSQL As String

strSQL = "SELECT Client.ClientID, Client.FullName, Client.DOB, DateDiff('d',[dob],Date())\365 AS Age, "
strSQL = strSQL & "Client.Sex, Client.OaklawnNum, Client.SocialSecurityNum, Race.Race, "
strSQL = strSQL & "Client.CurrentStatusID INTO tblWordMerge "
strSQL = strSQL & "FROM Client INNER JOIN Race ON Client.RaceID = Race.RaceID "
strSQL = strSQL & "WHERE (((Client.OaklawnNum) = '" & Me.OaklawnNum & "') And ((Client.CurrentStatusID) = 2)); "
DoCmd.SetWarnings False
DoCmd.RunSQL (strSQL)
DoCmd.SetWarnings True

Set objWord = GetObject("G:\Database\TCC Reports\AccessMergeTest.Doc", "Word.Document&quot
'Prompts for log on twice at this line.

objWord.MailMerge.Execute
Set objWord = Nothing

Is there a way I can, in code, close that extra iteration of Access that is locking the merge table? Or, is there a way I can release the lock on the table?

When this is done, I want to be able to merge the information in tblWordMerge to a number of different documents as well as run the merge for a number of records.

Thanks.


Larry De Laruelle

 

[Kotaro24]

I have a similar App. I checked to see if I have the same problem, and I probably do, but it doesn't show because I prompt for the printer before doing the mailmerge, and immediately print the merged document (the user doesn't have to do any editing of the merged document, so I can print it immediately. This reduces my 'locked' window to a few seconds.

If you do need to edit the merged document, then the best I can offer is to make a Unique Temp table name for each merge. (I've tacked on Year-Month-Day-Hours-Minutes-Seconds to a temp table name in code below, for example).

'EXAMPLES:

'**** My MailMerge Function ****
'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.
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

'********* My Temp Table Functions *******
'### CREATE TEMP TABLE THAT HOLDS FIELD DATA
Sleep 1 '### Guarantees a unique file name
TempDataTableName = &quot;TempHL7Data_&quot; & Format(Now(), &quot;yyyymmddhhmmss&quot
If TableDefExists(TempDataTableName) Then KillTable TempDataTableName
CreateTable TempDataTableName, &quot;HL7DataFldID&quot;, dbAutoIncrField, 4, &quot;HL7IntID&quot;, dbLong, 4, _
&quot;HL7RecID&quot;, dbLong, 4, &quot;HL7FldID&quot;, dbLong, 4, &quot;Text&quot;, dbText, 255
CreateIndex TempDataTableName, &quot;PrimKey&quot;, True, &quot;HL7DataFldID&quot;


Private Function CleanUpTempTables()
'Delete Orphaned Temp Tables FileName format = TempHL7Data_yyyymmddhhmmss
Dim DateStarts As Integer
Dim TableDate As Date
Dim TableName As String
Dim Tdf As TableDef
For Each Tdf In DBHL7.TableDefs
TableName = Tdf.Name
DateStarts = Max(1, InStr(TableName, &quot;_&quot)
If Left$(TableName, DateStarts - 1) = &quot;TempHL7Data&quot; Then
KillTable TableName
End If
If Left$(TableName, DateStarts - 1) = &quot;tempSegment&quot; Then KillTable TableName
Next 'Tdf
Set Tdf = Nothing
End Function

'************ OTHER FUNCTIONS MENTIONED ABOVE *****
Public Function KillTable(ByVal iTableName As String) As Boolean
Dim db As Database
KillTable = True
If Not TableDefExists(iTableName) Then Exit Function
Set db = Currentdb
On Error GoTo KTErrorTrap
db.TableDefs.DELETE iTableName
Exit_Function:
Set db = Nothing
Exit Function
KTErrorTrap:
KillTable = False 'Potentially, if Table is related to other tables?
Resume Exit_Function
End Function

Public Function Sleep(iSeconds As Long)
Dim TimeNow As Date
TimeNow = Now()
Do Until DateDiff(&quot;s&quot;, TimeNow, Now()) > iSeconds
DoEvents
Loop
End Function


Public Function TableDefExists(ByVal TableName$) As Boolean ' Does Table Exist?
Dim Dbt As Database
Dim X As Integer
Set Dbt = Currentdb
TableDefExists = False
For X = 0 To Dbt.TableDefs.Count - 1
If Dbt.TableDefs(X).Name = TableName$ Then
TableDefExists = True
Exit For
End If
Next
Set Dbt = Nothing
End Function

'Field Types are: dbAutoIncrField, dbBoolean, dbByte, dbCurrency, dbDate,
' dbDouble, dbInteger, dbLong, dbMemo, dbSingle, dbText
Public Function CreateTable(ByVal iTableName As String, _
ByVal iField1 As String, ByVal iField1Type As Long, ByVal iField1Size As Integer, _
Optional ByVal iField2 As String, Optional ByVal iField2Type As Long, Optional ByVal iField2Size As Integer, _
Optional ByVal iField3 As String, Optional ByVal iField3Type As Long, Optional ByVal iField3Size As Integer, _
Optional ByVal iField4 As String, Optional ByVal iField4Type As Long, Optional ByVal iField4Size As Integer, _
Optional ByVal iField5 As String, Optional ByVal iField5Type As Long, Optional ByVal iField5Size As Integer, _
Optional ByVal iField6 As String, Optional ByVal iField6Type As Long, Optional ByVal iField6Size As Integer, _
Optional ByVal iField7 As String, Optional ByVal iField7Type As Long, Optional ByVal iField7Size As Integer, _
Optional ByVal iField8 As String, Optional ByVal iField8Type As Long, Optional ByVal iField8Size As Integer, _
Optional ByVal iField9 As String, Optional ByVal iField9Type As Long, Optional ByVal iField9Size As Integer, _
Optional ByVal iField10 As String, Optional ByVal iField10Type As Long, Optional ByVal iField10Size As Integer _
) As Boolean
Dim db As Database
Dim fld As DAO.Field
Dim strFldName As String
Dim lngFldType As Long
Dim intFldSize As Integer
Dim idx As Index
Dim Tdf As TableDef


If TableDefExists(iTableName) Then Exit Function
Set db = Currentdb
Set Tdf = db.CreateTableDef(iTableName)
strFldName = iField1: lngFldType = iField1Type: intFldSize = iField1Size: GoSub Add_Field
strFldName = iField2: lngFldType = iField2Type: intFldSize = iField2Size: GoSub Add_Field
strFldName = iField3: lngFldType = iField3Type: intFldSize = iField3Size: GoSub Add_Field
strFldName = iField4: lngFldType = iField4Type: intFldSize = iField4Size: GoSub Add_Field
strFldName = iField5: lngFldType = iField5Type: intFldSize = iField5Size: GoSub Add_Field
strFldName = iField6: lngFldType = iField6Type: intFldSize = iField6Size: GoSub Add_Field
strFldName = iField7: lngFldType = iField7Type: intFldSize = iField7Size: GoSub Add_Field
strFldName = iField8: lngFldType = iField8Type: intFldSize = iField8Size: GoSub Add_Field
strFldName = iField9: lngFldType = iField9Type: intFldSize = iField9Size: GoSub Add_Field
strFldName = iField10: lngFldType = iField10Type: intFldSize = iField10Size: GoSub Add_Field
db.TableDefs.Append Tdf ' Append TableDef to Database

Set fld = Nothing
Set Tdf = Nothing
Set db = Nothing
CreateTable = True
Exit Function

Add_Field:
If Len(strFldName) > 0 Then
With Tdf
If lngFldType = dbText Then
Set fld = .CreateField(strFldName, lngFldType, intFldSize)
fld.AllowZeroLength = True
Else
If lngFldType = dbAutoIncrField Then 'dbAutoIncrField=16
lngFldType = dbLong
Set fld = .CreateField(strFldName, lngFldType)
fld.Attributes = dbAutoIncrField
Else
Set fld = .CreateField(strFldName, lngFldType)
End If
End If
.Fields.Append fld ' Add field to TableDef
End With
End If
Return
End Function

Public Function CreateIndex(ByVal iTableName As String, _
ByVal iIndexName As String, _
ByVal iPrimary As Boolean, _
ByVal iField1 As String, _
Optional ByVal iField2 As String, _
Optional ByVal iField3 As String, _
Optional ByVal iField4 As String, _
Optional ByVal iField5 As String, _
Optional ByVal iField6 As String, _
Optional ByVal iField7 As String, _
Optional ByVal iField8 As String, _
Optional ByVal iField9 As String, _
Optional ByVal iField10 As String) As Boolean
Dim db As Database
Dim fld As Field
Dim idx As Index
Dim Tdf As TableDef
If Not TableDefExists(iTableName) Then Exit Function
Set db = Currentdb
Set Tdf = db.TableDefs(iTableName)
With Tdf
If Not KeyExists(.Indexes, iIndexName) Then 'Create an Index Definition
Set idx = .CreateIndex(iIndexName)
idx.Primary = iPrimary ' if .Primary=True then Field values must be unique
Set fld = idx.CreateField(iField1)
idx.Fields.Append fld
If Len(iField2) > 0 Then
Set fld = idx.CreateField(iField2)
idx.Fields.Append fld
End If
If Len(iField3) > 0 Then
Set fld = idx.CreateField(iField3)
idx.Fields.Append fld
End If
If Len(iField4) > 0 Then
Set fld = idx.CreateField(iField4)
idx.Fields.Append fld
End If
If Len(iField5) > 0 Then
Set fld = idx.CreateField(iField5)
idx.Fields.Append fld
End If
If Len(iField6) > 0 Then
Set fld = idx.CreateField(iField6)
idx.Fields.Append fld
End If
If Len(iField7) > 0 Then
Set fld = idx.CreateField(iField7)
idx.Fields.Append fld
End If
If Len(iField8) > 0 Then
Set fld = idx.CreateField(iField8)
idx.Fields.Append fld
End If
If Len(iField9) > 0 Then
Set fld = idx.CreateField(iField9)
idx.Fields.Append fld
End If
If Len(iField10) > 0 Then 'Maximum of 10 fields per index.
Set fld = idx.CreateField(iField10)
idx.Fields.Append fld
End If
.Indexes.Append idx
End If
End With
CreateIndex = True
Set idx = Nothing
Set Tdf = Nothing
Set db = Nothing
End Function

 

[JoyInOK]

I've got an FAQ on how to fully automate Word from Access.
faq705-3237
If you use this technique, Access opens the mail merge main document, performs the Word merge, saves the merged document, and closes the main document without any other interface witht the user. The user can then edit the merged document as needed.
Since the mail merge main document is closed, so is the instance of Access it opens.

 

[LarryDeLaruelle]

Kotaro & Joy:

Thanks much for the code. This will likely keep me busy for the rest of the day.

Larry De Laruelle
ldelaruelle@familychildrenscenter.org

 

[JoyInOK]

Thanks for the star. Good to know we're keeping you busy and off the streets!

 

[LarryDeLaruelle]

Joy:

I used your code in a truncated version and it does the job very nicely. Here is what I have:

Private Sub cmdMerge_Click()

Dim strSQL As String
Dim strFileName As String
Dim objWord As New Word.Application
Dim objDoc As Word.Document

strFileName = &quot;MergeTest-&quot; & Me.OaklawnNum & &quot;.doc&quot;
strSQL = &quot;SELECT * INTO tblWordMerge FROM qbeWordMerge &quot; _
& &quot;WHERE (((OaklawnNum)='&quot; & Me.OaklawnNum & &quot;'));&quot;

DoCmd.SetWarnings False
DoCmd.RunSQL (strSQL)
DoCmd.SetWarnings True

objWord.Application.Visible = False
Set objDoc = objWord.Documents.Open(&quot;G:\Database\TCC Reports\AccessMergeTest2k.Doc&quot

objDoc.MailMerge.Destination = wdSendToNewDocument
objDoc.MailMerge.Execute
objWord.Application.Documents(1).SaveAs (&quot;G:\Database\TCC REports\&quot; & strFileName)
objWord.Application.Documents(2).Close wdDoNotSaveChanges
objWord.Application.Documents(strFileName).Close

Set objWord = Nothing
Set objDoc = Nothing

End Sub

My next task is to set this up so the user can select from a list (multi-select) of documents and save them dynamically based on the client record selected.

Good thing I enjoy doing this stuff.

Thanks again; wish I could give you another star, I've been tinkering with this off and on for quite a while and now I finally have a handle on it.

Larry De Laruelle
ldelaruelle@familychildrenscenter.org