Option Compare Database
Option Explicit
' *****************************************************
' Name: clsDocument
' Created: 24 Jan 2012
' Purpose: Define data structure, elements and
' methods used to create and manipulate
' auto-generated documents
' *****************************************************
Dim pCSVFile As String
Dim pDocumentTemplate As String
Public Property Get DataSource() As String
DataSource = pCSVFile
End Property
Public Property Let DataSource(ByVal sSQL As String)
pCSVFile = ExportToCsvFile(sSQL)
End Property
Public Property Get DocumentTemplate() As String
DocumentTemplate = pDocumentTemplate
End Property
Public Property Let DocumentTemplate(sDocumentTemplateID As String)
Dim sDocumentTemplate As String
sDocumentTemplate = ExtractDocumentFile(CLng(sDocumentTemplateID))
pDocumentTemplate = sDocumentTemplate
End Property
Public Sub ExportDocument(ByVal docSaveFormat As WdSaveFormat)
'On Error GoTo ErrHandler
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim oMergedDoc As Word.Document
Dim i As Integer, j As Integer
Dim NewResult As String
Dim blnCreated As Boolean
Dim strExtension As String
blnCreated = False
'Make sure the CSVFile property is set
If Nz(pCSVFile, vbNullString) = vbNullString Then
MsgBox "Error: DataSource propery of Document Class must be set prior to executing ExportDocument method.", vbOKOnly, "clsDocument:ExportDocument"
Exit Sub
End If
'Make sure the DocumentTemplate is set
If Nz(pDocumentTemplate, vbNullString) = vbNullString Then
MsgBox "Error: DocumentTemplate propery of Document Class must be set prior to executing ExportDocument method.", vbOKOnly, "clsDocument:ExportDocument"
Exit Sub
End If
Set oWord = New Word.Application
Set oDoc = oWord.Documents.Add(pDocumentTemplate)
'attach temp csv file to mail merge document template; execute mail merge
With oDoc.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource Name:=pCSVFile, LinkToSource:=False, Connection:="", SQLStatement:="", ConfirmConversions:=False
.Destination = wdSendToNewDocument
.Execute
End With
'save merged document in Word and PDF format
Set oMergedDoc = oWord.ActiveDocument
If docSaveFormat = wdFormatPDF Then
strExtension = ".pdf"
Else
strExtension = ".docx"
End If
sOutputDocumentFile = SaveFile(Environ("USERPROFILE") & "\" & oMergedDoc.FullName & strExtension, oDoc.Name)
If Nz(sOutputDocumentFile, vbNullString) = vbNullString Then
MsgBox "Cancelled."
GoTo ExitClass
End If
If docSaveFormat = wdFormatPDF Then 'PDF
oMergedDoc.ExportAsFixedFormat OutputFileName:=sOutputDocumentFile, ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
blnCreated = True
Else 'Word Doc
oMergedDoc.SaveAs sOutputDocumentFile, FileFormat:=docSaveFormat
blnCreated = True
End If
ExitClass:
'Kill our instance of Word, then shut down and clean up ;)
On Error Resume Next
oWord.Quit False
Set oWord = Nothing
Set oDoc = Nothing
Set oMergedDoc = Nothing
' If FileExist(pCSVFile) Then Kill (pCSVFile)
If FileExist(pDocumentTemplate) Then Kill (pDocumentTemplate)
If blnCreated Then
If MsgBox("Document creation is complete. Would you like to view the file now?", vbYesNo, _
"View created document") = vbYes Then
OpenThisFile (sOutputDocumentFile)
End If
End If
Exit Sub
ErrHandler:
MsgBox "Unhandled Error: " & Err.Description
If Err.Number = 429 Then
'If we got an error, that means there was no Word Instance
Set oWord = New Word.Application
End If
'Reset Error Handler
On Error GoTo 0
End Sub
Private Function ExportToCsvFile(strQueryNameOrSQL As String) As String
On Error GoTo Err_Handler
Dim db As DAO.Database
Dim strTimestamp As String
Dim strQdfName As String
Dim tempTable As String
Dim tempDirectory As String
Dim ExportFileName As String
Dim qdf As DAO.QueryDef
strTimestamp = Format(Now(), "HhNnSs-yyyymmdd")
strQdfName = "~temp" & strTimestamp
Dim qr As DAO.QueryDef
Dim QueryName As String
QueryName = strQueryNameOrSQL
Set db = CurrentDb
Set qdf = db.CreateQueryDef(strQdfName, strQueryNameOrSQL)
tempTable = "~temptbl" & strTimestamp
tempDirectory = Environ("USERPROFILE")
ExportFileName = tempDirectory & "\" & strTimestamp & ".csv"
DoCmd.TransferText acExportDelim, , strQdfName, ExportFileName, True
DoCmd.DeleteObject acQuery, strQdfName
ExportToCsvFile = ExportFileName
exit_function:
Exit Function
Err_Handler:
MsgBox Err.Description
Resume exit_function
End Function
Private Function FileExist(strFile As String) As Boolean
On Error GoTo Err_Handler
FileExist = False
If Len(Dir(strFile)) > 0 Then
FileExist = True
End If
Exit_Err_Handler:
Exit Function
Err_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: FileExist" & vbCrLf & _
"Error Description: " & Err.Description, vbCritical, "An Error has Occured!"
GoTo Exit_Err_Handler
End Function
