Private Sub cmdPrintCurrentRecord_Click()
Dim ReadOnlyMode As Boolean, strDocument As String
strDocument = Me.txtPathToYourWordDocument 'uses a text box on your form to get the full name of the Word mail-merge template or use a dlookup to get it from a settings table
If Dir(strDocument) = "" Then
MsgBox strDocument & " not found!", vbInformation, "Document not found!"
Exit Sub
End If
response = MsgBox("Do you wish to generate a Read-Only Mail Merge document using " & Chr(13) & _
strDocument & Chr(13) & Chr(13) & _
Chr(13) & Chr(13) & "Select YES for Read-Only" & _
Chr(13) & "Select NO for Read-Write" & _
Chr(13) & "Select CANCEL to halt.", vbYesNoCancel + vbQuestion, "Generate a Mail Merge Document")
If response = vbCancel Then Exit Sub
If response = vbYes Then
ReadOnlyMode = True
Else
ReadOnlyMode = False
End If
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Dim iFileCount As Integer
Dim strMailMergeFolder as string
strMailMergeFolder = CurrentProject.path
vcKillMailMerge
If Right(strMailMergeFolder, 1) <> "\" Then strMailMergeFolder = strMailMergeFolder & "\"
iFileCount = 1
On Error GoTo Error_Kill
Kill_File:
If Len(Dir(strMailMergeFolder & "DB_MailMerge" & iFileCount & ".txt")) > 0 Then Kill strMailMergeFolder & "DB_MailMerge" & iFileCount & ".txt"
GoTo relink
Error_Kill:
iFileCount = iFileCount + 1
GoTo Kill_File
relink:
DoCmd.TransferText acExportDelim, , "qryYourQueryForCurrentID", strMailMergeFolder & "DB_MailMerge" & iFileCount & ".txt", True
RelinkDocMailMergeText strMailMergeFolder & "DB_MailMerge" & iFileCount & ".txt", strDocument, ReadOnlyMode
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
End Sub
Sub RelinkDocMailMergeText(strMailMergeFileName As String, strDoc As String, boReadOnlyMode As Boolean)
Dim WordApp As Object
Dim retcode
Dim strFileName
Dim sPathNotmalTemplate
'On Error Resume Next
strFileName = strDoc
If Dir(strFileName) = "" Then
MsgBox strFileName & " was not found! Is it hidden?", vbExclamation, "Document not in this folder!"
Exit Sub
End If
Set WordApp = CreateObject("Word.Application")
With WordApp
.Application.Visible = True
On Error GoTo telluser
.StatusBar = "Preparing to add a new Mail-Merge document in Word format. Please wait..."
.Documents.Open strFileName, ReadOnly:=boReadOnlyMode, AddToRecentFiles:=False, Revert:=True
.ActiveDocument.MailMerge.OpenDataSource Name:= _
strMailMergeFileName, ConfirmConversions:=False, ReadOnly:= _
boReadOnlyMode, LinkToSource:=True, Revert:=True, AddToRecentFiles:=False
.NormalTemplate.Saved = True
.ActiveDocument.MailMerge.ViewMailMergeFieldCodes = False
.ActiveDocument.MailMerge.DataSource.ActiveRecord = -4 'first record
.ActiveDocument.MailMerge.Destination = 0 'new record
.ActiveDocument.MailMerge.Execute
.Documents(1).Printout 'print merged doc
.Documents(1).Close 0 'wdDoNotSaveChanges close merged doc
.ActiveDocument.Close 0 'close mail-merge template
End With
Set WordApp = Nothing
Exit Sub
telluser:
Set WordApp = Nothing
MsgBox "An error occurred while attempting to open a Mail-Merge document:" & Chr(13) & strFileName, vbExclamation, "Add New Mail-Merge Document"
End Sub
Public Sub vcKillMailMerge()
Dim strFileName As String
Dim iFolderCount As Integer
Dim strFolders() As String
Dim i As Integer
Dim strFolder As String, strFilePattern As String
On Error Resume Next
strFolder = CurrentProject.path
strFilePattern = "*DB_MailMerge*"
'Collect child folders
strFileName = Dir$(strFolder & "\", vbDirectory)
Do Until strFileName = ""
If (GetAttr(strFolder & "\" & strFileName) And vbDirectory) = vbDirectory Then
If Left$(strFileName, 1) <> "." Then
ReDim Preserve strFolders(iFolderCount)
strFolders(iFolderCount) = strFolder & "\" & strFileName
iFolderCount = iFolderCount + 1
End If
End If
strFileName = Dir$()
Loop
'process files in current folder
strFileName = Dir$(strFolder & "\" & strFilePattern)
Do Until strFileName = ""
'*******************************************
Kill strFolder & "\" & strFileName
'*******************************************
strFileName = Dir$()
Loop
End Sub
