I am VERY new to Access 2013. Our company does not support Access, but we have a Division dependent on the use of Access for logging employee field inspections. In 2003, the following code used to open up Excel, dump query information into an excel document, transfer the data into a word document with access merge fields, then automatically close the excel document. We have over 130 Word templates created during our Access 2003 days, so a rewrite of each template would take forever. There is a RunExcel Code, there is a RunWord Code, and a WordMerge Module which defines the process. I updated the office libraries, but the run code asks for keystrokes which is "over my breath of understanding" Is there a way to rewrite the following existing codes and modules to automate the process:
WordMerge Code:
RunExcel Code (see attached)
Word Excel Code (see attached)
Merge Code for specific word document:
WordMerge Code:
Code:
WordMergeCode - 1
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/200
8)
Dim HoldStrTemplate
HoldStrTemplate = StrTemplate
'pubTemplateFolder is a constant located in the GenMods module
StrTemplate = pubTemplateFolder & StrTemplate
If StrQuery = "none" Then GoTo SkipQuery
'Run query
Dim dbs As DAO.Database, rst As DAO.Recordset, qdf As QueryDef
Dim N As Integer
Dim StrDataDoc As String
StrDataDoc = pubCurrDBPath & "WDmerge.xls"
'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
WordMergeCode - 2
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, acSpreadsheetTypeExcel97, 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:="Ent
ire 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:="Enti
re Spreadsheet", subtype:=wdMergeSubTypeWord2000
.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
WordMergeCode - 3
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
Public Function CloseDoc()
'ActiveWindow.Close SaveChanges:=wdSaveChanges
'This example prompts the user to save the active document before closing it. If the user clicks Cance
l, error 4198 (command failed) is trapped and a message is displayed.
On Error GoTo errorHandler
ActiveDocument.Close SaveChanges:=wdPromptToSaveChanges, OriginalFormat:=wdPromptUser
errorHandler:
If Err = 4198 Then MsgBox "Document was not closed"
End Function
Public Function copymerge()
Dim StrTemplate
StrTemplate = "Generic.doc"
Dim StrQuery
StrQuery = "mqtest"
Dim strFolder
strFolder = "Junk"
Dim strPermitDoc
strPermitDoc = "30004004af 001.doc"
Const pubPermitFolder As String = "D:\bakerw\" '"d:\bakerw\WordConv\Finished\"
strPermitDoc = pubPermitFolder & strPermitDoc
DoCmd.Hourglass True
Const pubTemplateFolder As String = "D:\bakerw\Templates\" '"d:\bakerw\WordConv\Finished\"
If pubCurrDBPath = "" Then Call genCurrDBPath
StrTemplate = pubTemplateFolder & StrTemplate
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.xls"
' delete current Word data file.
WordMergeCode - 4
' ignore error if file doesn't exist
On Error Resume Next
Kill StrDataDoc
On Error GoTo 0
Set dbs = CurrentDb
On Error GoTo dMergeError
Set qdf = dbs.QueryDefs(StrQuery)
' the next bit just checks that there is data to merge
' iterate parameters collection and evaluate each parameter
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"
DoCmd.Hourglass False
GoTo Exit_Here
End If
rst.Close
qdf.Close
SkipQuery:
Dim wApp As New Word.Application
Dim wDoc As Word.Document
' create new Word data file
On Error GoTo dMergeError
' open word merge document
Set wDoc = wApp.Documents.Open(StrTemplate)
Dim strSampleFile
strSampleFile = pubCurrDBPath & "Sample.doc"
'wDoc.SaveAs FileName:=strSampleFile
If StrQuery = "none" Then GoTo FinishdMerge
On Error GoTo dMergeError
'DoCmd.TransferText acExportMerge, , strQuery, strDataDoc
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel97, StrQuery, StrDataDoc, True
' execute merge
'Documents("Sales.doc").MailMerge.EditDataSource
With wDoc.MailMerge
.MainDocumentType = wdFormLetters
.SuppressBlankLines = True
.Destination = wdSendToNewDocument
'.OpenDataSource Name:=strDataDoc, Format:=wdOpenFormatText, LinkToSource:=False
.OpenDataSource Name:=StrDataDoc, Format:=wdOpenFormatAuto, LinkToSource:=False, Connection:="Entire S
preadsheet"
'.OpenDataSource Name:=strDataDoc, ReadOnly:=True, Connection:="Entire Spreadsheet"
'AQMergeSource
.Execute
End With
wDoc.Close (wdDoNotSaveChanges)
'Open and copy permit document
Set wDoc = wApp.Documents.Open(strPermitDoc)
wDoc.Select
wApp.Selection.Copy
wDoc.Close (wdDoNotSaveChanges)
With Selection.Find
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
.Execute FindText:="PermitInfoHere"
End With
On Error GoTo dMergeError
wApp.Selection.Paste
'close the merge 'main document' without saving
FinishdMerge:
' show document in maximized window
WordMergeCode - 5
DoCmd.Hourglass False
wApp.Options.DefaultFilePath(wdDocumentsPath) = "d:\bakerw\" & strFolder
wApp.Visible = True
wApp.WindowState = wdWindowStateMaximize
Exit_Here:
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
Public Function GetWordPermit(strPermitName)
'original before 6/6/07
'Public Function GetWordPermit(strPermitDoc)
Dim strPermitDoc
Dim strPermitPDF As String
strPermitDoc = strPermitName & ".doc"
strPermitPDF = strPermitName & ".pdf"
DoCmd.Hourglass True
'pubPermitFolder is a constant located in the GenMods module
With Application.FileSearch
.NewSearch
.LookIn = pubPermitFolder
.SearchSubFolders = False
.FileName = strPermitDoc
.MatchTextExactly = True
.FileType = msoFileTypeWordDocuments
If .Execute() = 0 Then
MsgBox ("There is no Word permit document for this Permit No")
DoCmd.Hourglass False
'Exit Function
GoTo GetPDF
End If
End With
'gets here if a Word Permit Document
strPermitDoc = pubPermitFolder & strPermitDoc
Dim wApp As New Word.Application
Dim wDoc As Word.Document
' create new Word data file
On Error GoTo dMergeError
' open word merge document
Set wDoc = wApp.Documents.Open(strPermitDoc)
wApp.Visible = True
wApp.WindowState = wdWindowStateMaximize
ExitWord_Here:
DoCmd.Hourglass False
Exit Function
dMergeError:
Select Case Err.Number
Case 5174
MsgBox ("Word doc named " & strPermitDoc & " cannot be located.")
Case Else
MsgBox ("error # " & Err.Number & Err.Description)
End Select
Resume ExitWord_Here
'-----------------P D F STUFF
'to adapt from Get PDFInsp
GetPDF:
With Application.FileSearch
WordMergeCode - 6
.NewSearch
.LookIn = pubPermitFolder
.SearchSubFolders = True
.FileName = strPermitPDF
.MatchAllWordForms = True
.FileType = msoFileTypeAllFiles
If .Execute() = 0 Then
DoCmd.Hourglass False
MsgBox ("Permit Document" & strPermitName & " does not exist.")
Else
'YOU GET HERE IF IT FINDS SOMETHING
'KeyCode = 0
'Display the Files *ProjectNum.Doc
Dim i As Integer
Dim ActualPermitPDF As String
For i = 1 To .FoundFiles.Count
'Msgbox .foundfiles(i)
'response = MsgBox("Do you want to open " & .FoundFiles(i) & "?", vbYesNo)
'If response = vbYes Then
ActualPermitPDF = .FoundFiles(i)
GoTo BRINGUP_THE_PDF_DOCUMENT
'End If
Next i
End If
End With
BRINGUP_THE_PDF_DOCUMENT:
On Error GoTo PDFOpenErr
Dim stAppName As String
'ME: 1/31/07:
Dim wPDF As String
stAppName = "C:\Program Files\Adobe\Reader 9.0\Reader\Reader\AcroRd32.exe"
wPDF = stAppName & " " & ActualPermitPDF
Call Shell(wPDF, 1)
ExitPDF_Here:
DoCmd.Hourglass False
Exit Function
PDFOpenErr:
MsgBox Err.Description
Resume ExitPDF_Here
End Function
'----------------------
'End Function
Public Function GetWordComplaint(strComplaintDoc, Response, GotIt, DocSource)
DoCmd.Hourglass True
'pubComplaintDocFolder is a constant located in the GenMods module
'This Function gets an already-existing document, if it is there and if the user wants to use it
'check to see if there is already a document by this name in the Complaint Document Folder
'if not, exit this function
'If so, tell them it exists and find out if they want to replace it with a new one?
'If they don't want to replace it, exit this function; otherwise, make a new document
'If they want to replace it with a new one, open a brand new WordDocument for them according to name c
riteria
Dim FolderSource As String
If DocSource = "cmp" Then
FolderSource = pubComplaintDocFolder
Else
FolderSource = pubInspDocFolder
End If
WordMergeCode - 7
If Dir(FolderSource & "\" & strComplaintDoc) = "" Then
DoCmd.Hourglass False
If Response = "edit" Then
GotIt = 1
MsgBox ("Complaint document " & strComplaintDoc & " does not exist in Word. If you need to cr
eate one, go to the 'Merge' icon.")
End If
Exit Function
Else
'KeyCode = 0
'ME: 7/11/03 - add code so it knows which control got you in here: new merge or edit
If Response <> "edit" Then
Response = MsgBox("The Document " & strComplaintDoc & " has previously been merged-Do You Want
To MERGE Anyway?", vbYesNo)
'ME: 7/11/03 - take out the following line and exit regardless of response
' we don't need to bring up the existing document from the "Create" button (consistency
)
'If response = vbYes Then GoTo Exit_Here
GoTo Exit_Here
End If
End If
strComplaintDoc = pubComplaintDocFolder & strComplaintDoc
Dim wApp As New Word.Application
Dim wDoc As Word.Document
' make new Word data file
On Error GoTo dMergeError
' open word merge document
Set wDoc = wApp.Documents.Open(strComplaintDoc)
wApp.Visible = True
wApp.WindowState = wdWindowStateMaximize
Exit_Here:
DoCmd.Hourglass False
Exit Function
dMergeError:
Select Case Err.Number
Case 5174
MsgBox ("Word doc named " & strComplaintDoc & " cannot be located.")
Case Else
MsgBox ("error # " & Err.Number & Err.Description)
End Select
Resume Exit_Here
End Function
Public Function GetWordInsp(strInspDoc, Response, GotIt, DocSource)
'***START HERE*** ME: 10/21/04
DoCmd.Hourglass True
'pubInspDocFolder is a constant located in the GenMods module
'This Function gets an already-existing document, if it is there and if the user wants to use it
'check to see if there is already a document by this name in the Inspection Document Folder
'if not, exit this function
'If so, tell them it exists and find out if they want to replace it with a new one?
'If they don't want to replace it, exit this function; otherwise, make a new document
'If they want to replace it with a new one, open a brand new WordDocument for them according to name c
riteria
'ME: 3/19/07: added the following to determine proper Folder for Document Source (enf or insp)
Dim FolderSource As String
If DocSource = "enf" Then
FolderSource = pubEnfDocFolder
Else
FolderSource = pubInspDocFolder
End If
With Application.FileSearch
.NewSearch
.LookIn = FolderSource
.SearchSubFolders = True
.FileName = strInspDoc
.MatchAllWordForms = True
.FileType = msoFileTypeWordDocuments
WordMergeCode - 8
If .Execute() = 0 Then
DoCmd.Hourglass False
If Response = "edit" Then
GotIt = 1
'MsgBox ("Inspection document " & strInspDoc & " does not exist in Word.")
End If
Exit Function
Else
'YOU GET HERE IF IT FINDS SOMETHING
'KeyCode = 0
'Display the Files *ProjectNum.Doc
Dim i As Integer
Dim ActualInspDoc As String
For i = 1 To .FoundFiles.Count
'Msgbox .foundfiles(i)
'response = MsgBox("Do you want to open " & .FoundFiles(i) & "?", vbYesNo)
'If response = vbYes Then
ActualInspDoc = .FoundFiles(i)
GoTo BRINGUP_THEDOCUMENT
'End If
Next i
End If
End With
BRINGUP_THEDOCUMENT:
Dim wApp As New Word.Application
Dim wDoc As Word.Document
' make new Word data file
On Error GoTo dMergeError
' open word merge document
Set wDoc = wApp.Documents.Open(ActualInspDoc)
wApp.Visible = True
wApp.WindowState = wdWindowStateMaximize
Exit_Here:
DoCmd.Hourglass False
Exit Function
dMergeError:
Select Case Err.Number
Case 5174
MsgBox ("Word doc named " & strInspDoc & " cannot be located.")
Case Else
MsgBox ("error # " & Err.Number & Err.Description)
End Select
Resume Exit_Here
End Function
Public Function GetPDFInsp(strInspPDF, Response, GotIt, DocSource)
'1/31/07: ME: COPIED FROM GetWordInsp....
DoCmd.Hourglass True
'pubInspDocFolder is a constant located in the GenMods module
'This Function gets an already-existing document, if it is there and if the user wants to use it
'check to see if there is already a document by this name in the Inspection Document Folder
'if not, exit this function
'If so, tell them it exists and find out if they want to replace it with a new one?
'If they don't want to replace it, exit this function; otherwise, make a new document
'If they want to replace it with a new one, open a brand new WordDocument for them according to name c
riteria
'ME: 3/19/07: added the following to determine proper Folder for Document Source (enf or insp)
Dim FolderSource As String
If DocSource = "enf" Then
FolderSource = pubEnfDocFolder
ElseIf DocSource = "cmp" Then
FolderSource = pubComplaintDocFolder
Else
FolderSource = pubInspDocFolder
End If
With Application.FileSearch
.NewSearch
.LookIn = FolderSource
.SearchSubFolders = True
WordMergeCode - 9
.FileName = strInspPDF
.MatchAllWordForms = True
'.FileType = msoFileTypeWordDocuments
'ME: 02/01/2007: or possibly the following
.FileType = msoFileTypeAllFiles
If .Execute() = 0 Then
DoCmd.Hourglass False
If Response = "edit" Then
If GotIt = 1 Then
GotIt = 2
'MsgBox ("Inspection document " & strInspPDF & " does not exist.")
End If
End If
Exit Function
Else
'YOU GET HERE IF IT FINDS SOMETHING
'KeyCode = 0
'Display the Files *ProjectNum.Doc
Dim i As Integer
Dim ActualInspPDF As String
For i = 1 To .FoundFiles.Count
'Msgbox .foundfiles(i)
'response = MsgBox("Do you want to open " & .FoundFiles(i) & "?", vbYesNo)
'If response = vbYes Then
ActualInspPDF = .FoundFiles(i)
GoTo BRINGUP_THE_PDF_DOCUMENT
'End If
Next i
End If
End With
BRINGUP_THE_PDF_DOCUMENT:
On Error GoTo PDFOpenErr
Dim stAppName As String
'ME: 1/31/07:
Dim wPDF As String
stAppName = "C:\Program Files\Adobe\Reader 11.0\Reader\AcroRd32.exe"
wPDF = stAppName & " " & ActualInspPDF
Call Shell(wPDF, 1)
Exit_Here:
DoCmd.Hourglass False
Exit Function
PDFOpenErr:
MsgBox Err.Description
Resume Exit_Here
End FunctionRunExcel Code (see attached)
Word Excel Code (see attached)
Merge Code for specific word document:
Code:
Private Sub cmdWDInsp_Click()
Dim DocSource
DocSource = ""
Dim strInspName
Dim strWordInsp
Dim strPDFInsp As String
If IsNull(Forms![fFacInsp01]![fFacInspSetup01].Form![Proj_ID]) Then
MsgBox ("Project # is needed to open Word document!")
Exit Sub
End If
'develops a Word document name from the Project #
strWordInsp = "*" & (Forms![fFacInsp01]![fFacInspSetup01].Form![Proj_ID]) & ".doc"
'develops a PDF document name from the Project #
strPDFInsp = "*" & (Forms![fFacInsp01]![fFacInspSetup01].Form![Proj_ID]) & ".pdf"
strInspName = "*" & (Forms![fFacInsp01]![fFacInspSetup01].Form![Proj_ID])
'MsgBox (strWordInsp & " would be the Inspection Document name")
Dim Response
Response = "edit"
Dim GotIt
GotIt = 0
Call GetWordInsp(strWordInsp, Response, GotIt, DocSource)
If GotIt = 1 Then
Call GetPDFInsp(strPDFInsp, Response, GotIt, DocSource)
End If
If GotIt = 2 Then
MsgBox ("Inspection document " & strInspName & " does not exist.")
End If
End Sub