Option Compare Database
Option Explicit
Public Function dmerge(StrTemplate As String, StrQuery As String, strFolder As String)
DoCmd.Hourglass True
'pubCurrDBPath is a variable located in the GenMods module
'it is normally primed when db is opened via macro
'AutoExec(Runcode OpenProcs) by a call to genCurrDBPath
If pubCurrDBPath = "" Then Call genCurrDBPath
'this field is checked later in the procedure for a template named Generic or Generic CMS (added 9/2008)
StrTemplate = pubTemplateFolder & StrTemplate
StrQuery = StrQuery
strFolder = pubTemplateFolder
Dim HoldStrTemplate
HoldStrTemplate = StrTemplate
'pubTemplateFolder is a constant located in the GenMods module
If StrQuery = "none" Then GoTo SkipQuery
'Run query
Dim dbs As DAO.Database, rst As DAO.Recordset, qdf As DAO.QueryDef
Dim N As Integer
Dim StrDataDoc As String
StrDataDoc = pubCurrDBPath & "WDmerge.xlsx"
'delete current Excel data file.
'ignore error if file doesn't exist
On Error Resume Next
'from a macro for adding a new sheet to the spreadsheet
''If StrDataDoc Then
'Sheets.Add
'Sheets("Sheet1").Select
' Sheets("Sheet1").Name = "XYZ"
' Range("A1").Select
''Else
'original
Kill StrDataDoc
On Error GoTo 0
Set dbs = CurrentDb
On Error GoTo dMergeError
Set qdf = dbs.QueryDefs(StrQuery)
'this checks that the query results in data to merge
For N = 0 To qdf.Parameters.Count - 1
qdf.Parameters(N) = Eval(qdf.Parameters(N).Name)
Next N
Set rst = qdf.OpenRecordset
'exit function if recordset is empty
If rst.EOF Then
MsgBox "No data to merge.", vbInformation, "Mail Merge"
rst.Close
GoTo Exit_Here
End If
rst.Close
qdf.Close
SkipQuery:
Dim wApp As New Word.Application
Dim wDoc As Word.Document
On Error GoTo dMergeError
' open word merge template document
Set wDoc = wApp.Documents.Open(StrTemplate)
'Dim strSampleFile
'strSampleFile = pubCurrDBPath & "Sample.doc"
'if there is no query associated with the passed strTemplate
'then goto procedure exit
If StrQuery <> "none" Then GoTo DodMerge
'StrQuery "none" means that the document is a blank
'form with no merge required
'this copies the template document and pastes it to a
'new open document
wDoc.Select
wApp.Selection.Copy
'close the templates document
wDoc.Close (wdDoNotSaveChanges)
'Documents.Add DocumentType:=wdNewBlankDocument
wApp.Documents.Add DocumentType:=wdNewBlankDocument
wApp.Selection.Paste
GoTo FinishUpDoc
'merge processing
DodMerge:
On Error GoTo dMergeError
'transfer data from the query to the Excel spreadsheet for merging with template data
'NOTE: An excel spreadsheet is used instead of a txt file because the
'latter has problems with quotes within the text
'original statement
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, StrQuery, StrDataDoc, True
'possible newer version of Excel
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel2003, StrQuery, StrDataDoc, True
'execute merge
With wDoc.MailMerge
.MainDocumentType = wdFormLetters
.SuppressBlankLines = True
.Destination = wdSendToNewDocument
'6/15/05: ME: change format to wdOpenFormatDocument; hopefully will correct issue w. Generic merge
'.OpenDataSource Name:=StrDataDoc, Format:=wdOpenFormatDocument, LinkToSource:=False, Connection:="Entire Spreadsheet"
'.OpenDataSource Name:=StrDataDoc, Format:=wdOpenFormatAuto, LinkToSource:=False, Connection:="Entire Spreadsheet"
'12/20/05: ME: subtype is Word2000 for the merges
.OpenDataSource Name:=StrDataDoc, Format:=wdOpenFormatDocument, LinkToSource:=False, Connection:="Entire Spreadsheet", subtype:=wdMergeSubTypeWord
.Execute
End With
'close the merge 'template document' without saving
wDoc.Close (wdDoNotSaveChanges)
'ME: 6/21/06: THIS IS THE AREA APPROXIMATELY WHERE THE EXCEL SPREADSHEET SHOULD CLOSE
If HoldStrTemplate = "Generic" Then GoTo GenericProcessing
If HoldStrTemplate = "Generic CMS" Then GoTo GenericProcessing
'If HoldStrTemplate = "Generic CMS" Then GoTo GenericProcessing
GoTo FinishdMerge
'If HoldStrTemplate <> "Generic" Or HoldStrTemplate <> "Generic CMS" Then GoTo FinishdMerge
'ORIGINAL STATEMENT: ME: 9/9/2008
'If HoldStrTemplate <> "Generic" Then GoTo FinishdMerge
GenericProcessing:
''Generic' document processing follows
'pubCopyPermitDoc is a variable located in GenMods module
'it is primed in form fLetterPInsp when the Generic document
'is selected and when there is a valid document to copy
If IsNull(pubCopyPermitDoc) Then GoTo FinishdMerge
Dim strPermitDoc
'pubPermitDocFolder is a constant located in GenMods module
strPermitDoc = pubPermitDocFolder & pubCopyPermitDoc
'open the permit document and copy its contents to the clipboard
Set wDoc = wApp.Documents.Open(strPermitDoc)
wDoc.Select
wApp.Selection.Copy
'close the permit document
wDoc.Close (wdDoNotSaveChanges)
'locate and select "PermitInfoHere" text in the
'open (merged) document
With wApp.Selection.Find
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
.Execute FindText:="PermitInfoHere"
End With
On Error GoTo dMergeError
'paste the contents of the clipboard over the current selected text
wApp.Selection.Paste
'2/25/05 ME: add the following statement-see if it will give another case
On Error GoTo dMergeError
'set permit variable to null in prep for next 'generic' call
' pubCopyPermitDoc = Null
pubCopyPermitDoc = ""
FinishUpDoc:
'place cursor at top of document
wApp.Selection.GoTo What:=wdGoToLine, which:=wdGoToAbsolute, Count:=1
'select and copy a small amount of data to the clipboard
'this is done because otherwise user would have to answer a Windows-
'generated question on having to keep a large amount of data in the
'clipboard.
wApp.ActiveDocument.Characters(1).Select
wApp.Selection.Copy
FinishdMerge:
'show document in maximized window
'pubSaveAsFolder is a constant located in the GenMods module
wApp.Options.DefaultFilePath(wdDocumentsPath) = pubSaveAsFolder & strFolder
wApp.Visible = True
wApp.WindowState = wdWindowStateMaximize
Exit_Here:
DoCmd.Hourglass False
Exit Function
dMergeError:
DoCmd.Hourglass False
Select Case Err.Number
Case 3265
MsgBox ("Query named " & StrQuery & " cannot be located.")
Case 5174
MsgBox ("Word doc named " & StrTemplate & " cannot be located.")
ActiveDocument.Close
Case 5922
MsgBox ("Data transferred to Word cannot contain quotes!")
ActiveDocument.Close savechanges:=wdPromptToSaveChanges, OriginalFormat:=wdPromptUser
Case Else
MsgBox ("error # " & Err.Number & Err.Description)
End Select
Resume Exit_Here
End Function
