Ok guys - I cannot quick grasp this
I need to hard code the directoy to absolute to
C:\Bumblebee\
(I will switch the code to my network..)
but I cannot see where
Option Compare Database
Option Explicit
'Const TextMerge As String = "merge.txt"
' May 20/2003 - see below comments why txt file name was changed.
Const TextMerge As String = "merge.888"
'******************************************
'* Word merge code *
'* (c) 2001 Albert D. Kallal *
'* kallal@msn.com *
'* *
'******************************************
'
' Usage:
' In code on a form with a data source, just place the following
' command behind a button
'
' MergeSingleWord
'
' That is it!!!
'
' You can also specify a dir for the above. This dir location is relative
' to location of the access dir. The default dir is "Word\". Hence, the real
' usage is:
' MergeSingleWord [dir],[bolFullPath]
'
' Example:
' MergeSingleWord "Customers"
'
' The above would use/create the templates in a dir called Customers (relative to app dir).
' The "\" is optional. If you leave out the "\", then my code appends a "\" to the dir
'
' An absolute location can be specified as:
' MergeSingleWord "c:\MyWord\", True
' The use of the True above forces the dir to be a full path name, and not relative
' to the app dir. The path must be a FULL path, and not relative.
'
'==========================================
' Revisions
' Date who Comments
' May 20, 2003 ADK - added on error resume next to the mkdir command in GetWordDir
' May 20, 2003 ADK - changed merge.txt file to merge.888 to fix text import bug
' (this is a know problem when you turn off file extensions
' in windows, the mail merge will fail KB article 137385)
' Aug 06, 2003 ADK - added ability to use different dire for each form.
' Aug 09, 2003 ADK - added a listbox sort routine
' Aug 28, 2003 ADK - change the "modify" template option to *always* set the
' data source to merge.888. That way, just hitting modify option
' will set the data source to the correct dir.
'
' Oct 22, 2003 ADK - changed the "qu" routine that surrounds the text data field to
' remove all " quotes to a ' (single quote).
'
' Oct 29, 2003 ADK - removed use of AppActivate "Microsoft Word" to use
' wordApp.Activate (this works with all versions, including xp where
' the window names are "separate"
' Feb 14, 2004 ADK - Added the code to set the data source EACH TIME a word doc is loaded.
' (This was done to fix problems with office 2003, and the message:
' "Opening This Will Run the Following SQL Command Message"
' There is a number of registry settings that can be changed. However
' just setting the data source EACH TIME the word doc is loaded also
' seems to by-pass the run SQL command nag message. Since this is hole
' in what is supposed to prevent automation code from setting the data
' source, I am betting that future releases will beak my code!
' Sept 24, 2004 ADK - added some code to allow name of output doc to be set.
' Mar 06, 2005 ADK - unbound text boxes are now included for single word merge
' Sep 07, 2005 ADK - mergenoprompts now allows sql string to be based
' Oct 10, 2006 ADK - text boxes on forms now can be used in the merge.
' Oct 14, 2006 ADK - fill prompt fields cased menu bars to not show, fixed by
' moving the visible + activate code to BEFORE the merge.
' Dec 11, 2006 ADK - fixed a focus bug, and now use a SEPERATE instance of
' the "open" word document to fix a problem when docuemnts
' are already open
Public Function MergeSingleWord(Optional strDir As String = "Word\", _
Optional bolFullPath As Boolean = False, _
Optional strOutPutDoc As String = "")
' Main Word merge function
' Albert D. Kallal
' kallal@msn.com
'
'
' starts the whole process of a "merge" template (single record) in rides.
'
' Simply place this command behind a button on a form.
' A function was used here in place of a "sub". This was done since a
' custom menu bar can call this code by placing =MergeSingleWord() in the
' menu's on-action. Thus, if you use custom menu bars, this code will work!
' This code thus picks up the active screen name, and functions from that.
' Parms are:
' strDir optional dir (include the \) the dir name - relative to applicaton dir
' bolfullPath optinal flag. Set to TRUE if the above dir is a full path name. If you
' do NOT set this flag (or leave it as false), the the path name is relative
' to the appliction dir.
' stroutPutDoc Name of the document to be saved to disk. (full path requied here)
Dim strOutFile As String ' temp csv merge text file name
Dim frmF As Form
Dim strDirPath As String ' full path name to working dir
Set frmF = Screen.ActiveForm
frmF.Refresh
strDirPath = DirToPath(strDir, bolFullPath)
strOutFile = strDirPath & TextMerge
' output our simple merge file
If MakeMergeText(frmF, strOutFile) Then
DoCmd.OpenForm "GuiWordTemplate", , , , , , strDirPath & "~" & strOutPutDoc
End If
End Function
Public Function MergeAllWord(strSql As String, _
Optional strDir As String = "Word\", _
Optional bolFullPath As Boolean = False, _
Optional strOutPutDoc As String) As Boolean
' Merge all reocrds from the form.
' This rouinte can take any sql statement you pass, and create
' a merge doc. Thus, this is used for "many" merged, and not
' a single merge.
' Simply this rouintes writes out a csv file based on the
' sql, and then launches the merge form.
' Parms are:
' strDir relative path to dir
' bolFullPath if set true, then above path is NOT relative
' strOutPutDoc if set, then write out the merged doc to this file
' build our merge file, and write a "csv" file to disk
Dim strDirPath As String ' full path name to working dir
Dim OneField As DAO.Field ' dao code
Dim strFields As String
Dim strData As String
Dim intFile As Integer
Dim rstOutput As DAO.Recordset
Dim strOutFile As String ' csv file output name
On Error GoTo exit2 ' if sql is bad...simply exit...
Set rstOutput = CurrentDb.OpenRecordset(strSql)
If rstOutput.RecordCount = 0 Then
' no records...exit.
GoTo exit1
End If
' build the merge file, but show the process bar
'
clsRidesPBar.ShowProgress
clsRidesPBar.TextMsg = "Building merge file..."
On Error GoTo exit1 ' if sql is bad...simply exit...
rstOutput.MoveLast
rstOutput.MoveFirst
' set max value of progress bar to number of records
clsRidesPBar.Pmax = rstOutput.RecordCount
' build the first line of fields for csv
For Each OneField In rstOutput.Fields
If strFields <> "" Then strFields = strFields & ","
strFields = strFields & qu(OneField.Name)
Next OneField
' build the merge.txt file
strDirPath = DirToPath(strDir, bolFullPath)
strOutFile = strDirPath & TextMerge
'delete the out file if there
On Error Resume Next
Kill strOutFile
' now open file...
On Error GoTo exit1
intFile = FreeFile()
Open strOutFile For Output As intFile
Print #intFile, strFields
' output all data
Do While rstOutput.EOF = False
strData = "" ' one line of data for csv file
For Each OneField In rstOutput.Fields
If strData <> "" Then strData = strData & ","
strData = strData & qu(rstOutput(OneField.Name))
Next OneField
Dim vField As Control
Print #intFile, strData
rstOutput.MoveNext
clsRidesPBar.IncOne
Loop
Close intFile
MergeAllWord = True
clsRidesPBar.HideProgress
DoCmd.OpenForm "GuiWordTemplate", , , , , , strDirPath & "~" & strOutPutDoc
Exit Function
exit1:
clsRidesPBar.HideProgress
exit2:
MsgBox "No data was created for this merge" & vbCrLf & _
"Make sure the sql is correct" & vbCrLf & _
"sql was " & vbCrLf & vbCrLf & strSql, _
vbCritical, "no data for this merge"
MergeAllWord = False
End Function
Public Function MergeNoPrompts(strDoc As String, _
Optional strDir As String = "word\", _
Optional bolFullPath As Boolean = False, _
Optional strOutDocName As String, _
Optional strSql As String = "", _
Optional bolPrint As Boolean = False, _
Optional StrPrinter As String = "")
Dim frmF As Form
Dim strFullDocName As String
Dim strDirPath As String
Dim strOutFile As String
Set frmF = Screen.ActiveForm
frmF.Refresh
strDirPath = DirToPath(strDir, bolFullPath)
strFullDocName = strDirPath & strDoc
strOutFile = strDirPath & TextMerge ' temp text file name
' sql passed?
If strSql <> "" Then
If MakeMergeAll(strSql, strDir, bolFullPath) = False Then
' could not create...exit
Exit Function
End If
Else
If MakeMergeText(frmF, strOutFile) = False Then
' could not create...exit
Exit Function
End If
End If
Call RidesMergeWord(strFullDocName, strDirPath, strOutDocName, bolPrint, StrPrinter)
End Function
Function GetAppDir() As String
' This routine simply returns the current applction dir
'+ \word
' If the dir does not exist, then we create it.
' This is the dir where the word docs will be created.
Dim strDB As String
' build a string based on the CURRENT mdb direcotry + \word
strDB = CurrentDb.Name
GetAppDir = Left(strDB, Len(strDB) - Len(Dir(strDB)))
End Function
Function DirToPath(strDir As String, bolFullPath) As String
If Right(strDir, 1) <> "\" Then
strDir = strDir & "\"
End If
If bolFullPath = True Then
' full path name to a dir ...not relative
DirToPath = strDir
Else
DirToPath = GetAppDir & strDir
End If
Call CheckDir(DirToPath) ' checks if dir exist..if not it creates the dir
End Function
Sub CheckDir(strDir As String)
If strDir = "" Then Exit Sub
If Len(Dir(strDir)) = 0 Then
On Error Resume Next
MkDir strDir
End If
End Sub
Function qu(vText As Variant) As String
' takes a string and surrounds it with double quotes
' All " (double quotes) are converted to ' (single quotes) before
' this is done
If IsNull(vText) = False Then
If InStr(vText, Chr(34)) > 0 Then
vText = strDReplace(CStr(vText), Chr(34), "'")
End If
End If
qu = Chr$(34) & vText & Chr$(34)
End Function
Function strDReplace(vText As String, strSearchFor As String, strReplaceTo As String) As String
Dim intFoundPos As Integer
Dim intSearchLen As Integer
Dim intReplaceLen As Integer
intSearchLen = Len(strSearchFor)
intReplaceLen = Len(strReplaceTo)
intFoundPos = InStr(vText, strSearchFor)
Do While intFoundPos > 0
vText = Left$(vText, intFoundPos - 1) & strReplaceTo & Mid(vText, intFoundPos + intSearchLen)
intFoundPos = InStr(vText, strSearchFor)
Loop
strDReplace = vText
End Function
Function RidesMergeWord(strDocName As String, _
strDataDir As String, _
Optional strOutDocName As String, _
Optional bolPrint As Boolean = False, _
Optional StrPrinter As String)
' This code takes a word document that has been setup as a MERGE document.
' This merge document is opened, then mailmerge is executed. The original
' document is then closed. The result is a raw word document with no connectons
' to the merge.txt (a csv source data file).
'Parms:
' strDocName - full path name of word doc (.doc)
' strDataDir - dir (full path) where docuemnts and the merge.888 file is placed
' strOutDocName - full path name of merged document (saved).
' bolPrint - if true, then output docuemnt is printed - if strOutDocName is suppled then we close the docuemnt
' strPrinter - sends output to the printer name
'
'
' The above parms are suppled by other routines. You likey should not need to call this
' routine directly. See the sub called MergeNoPrompts.
' Albert D. Kallal (c) 2001
' kalla@msn.com
'
Dim WordApp As Object ' running instance of word
Dim WordDoc As Object ' one instance of a word doc
Dim WordDocM As Object ' one instance of a word doc
Dim strActiveDoc As String ' doc name (no path)
Dim lngWordDest As Long ' const for dest, 0 = new doc, 1 = printer
Dim MyPbar As New clsRidesPBar ' create a instance of our Progress bar.
MyPbar.ShowProgress
MyPbar.TextMsg = "Launching Word...please wait..."
MyPbar.Pmax = 4 ' 4 steps to inc
MyPbar.IncOne ' step 1....start!
On Error GoTo CreateWordApp
Set WordApp = GetObject(, "Word.Application")
On Error Resume Next
MyPbar.IncOne ' step 2, word is loaded.
Set WordDoc = WordApp.Documents.Open(strDocName)
MyPbar.IncOne ' step 3, doc is loaded
strActiveDoc = WordApp.ActiveDocument.Name
'wordApp.Activate
If bolPrint = False Then
WordApp.Visible = True
WordApp.Activate
WordApp.WindowState = 0 'wdWindowStateRestore
End If
WordDoc.MailMerge.OpenDataSource _
Name:=strDataDir & TextMerge, _
ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=0, _
Connection:="", SQLStatement:="", SQLStatement1:=""
With WordDoc.MailMerge
.Destination = 0 ' 0 = new doc
.MailAsAttachment = False
.MailAddressFieldName = ""
.MailSubject = ""
.SuppressBlankLines = True
With .datasource
.FirstRecord = 1
' .LastRecord = 1
End With
.Execute Pause:=False
End With
Set WordDocM = WordApp.ActiveDocument
MyPbar.IncOne ' step 4, doc is merged
WordDoc.Close (False)
WordApp.Visible = True
If strOutDocName <> "" Then
'wordApp.ActiveDocument.SaveAs strOutDocName
WordDocM.SaveAs strOutDocName
End If
If bolPrint = False Then
WordDocM.Activate
Else
' print this document
If StrPrinter <> "" Then
With WordApp.Dialogs(97) ' 97 - wdDialogFilePrintSetup
.Printer = StrPrinter
.DoNotSetAsSysDefault = True
.Execute
End With
End If
WordDocM.PrintOut
'If strOutDocName <> "" Then
'wordApp.ActiveDocument.Close (False)
' when we print...we *always* close the docuemnt..
WordDocM.Close (False)
'End If
WordApp.Visible = True
End If
MyPbar.HideProgress
Set WordApp = Nothing
Set WordDoc = Nothing
Set WordDocM = Nothing
Set MyPbar = Nothing
DoEvents
' If bolShowMerge = True Then
' WordApp.Dialogs(676).Show 'wdDialogMailMerge
' End If
Exit Function
CreateWordApp:
' this code is here to use the EXISTING copy of
' ms-access running. If getobject fails, then
' ms-word was NOT running. The below will then
' launch word
Set WordApp = CreateObject("Word.Application")
Resume Next
End Function
Function RidesEditTemplate(strWordDoc As String, strSaveDir As String)
' Opens a word doc in mail merge mode
Dim WordApp As Object
Dim WordDoc As Object
clsRidesPBar.ShowProgress
clsRidesPBar.TextMsg = "Launching Word...please wait..."
On Error GoTo CreateWordApp
Set WordApp = GetObject(, "Word.Application")
On Error GoTo 0
Set WordDoc = WordApp.Documents.Open(strWordDoc)
WordApp.Visible = True
'*-
WordDoc.MailMerge.MainDocumentType = 0 ' wdFormLetters = 0
WordDoc.MailMerge.OpenDataSource _
Name:=strSaveDir & TextMerge, _
ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=0, _
Connection:="", SQLStatement:="", SQLStatement1:=""
'*-
'AppActivate "Microsoft Word"
WordApp.Activate
WordApp.WindowState = 0 'wdWindowStateRestore
clsRidesPBar.HideProgress
Exit Function
CreateWordApp:
Set WordApp = CreateObject("Word.Application")
Resume Next
End Function
Function RidesNewTemplate(strSaveDir As String)
' ask user for template name to create
'
' Parms:
' strSaveDir = full path of dir is (includes the last backslash \
Dim strNewName As String
Dim WordApp As Object 'Word.Applicaton
Dim WordDoc As Object 'Word.Document
strNewName = ""
strNewName = InputBox("What name for new template" & vbCrLf & vbCrLf & _
"(Enter name with no file extension)", _
"Create New Word merge Template")
If strNewName = "" Then Exit Function
' get work object...
clsRidesPBar.ShowProgress
clsRidesPBar.TextMsg = "Launching Word...please wait..."
clsRidesPBar.Pmax = 4
clsRidesPBar.IncOne
On Error GoTo CreateWordApp
Set WordApp = GetObject(, "Word.Application")
On Error GoTo 0
clsRidesPBar.IncOne
Set WordDoc = WordApp.Documents.Add
WordDoc.MailMerge.MainDocumentType = 0 ' wdFormLetters = 0
'MsgBox strSaveDir
WordDoc.MailMerge.OpenDataSource _
Name:=strSaveDir & TextMerge, _
ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=0, _
Connection:="", SQLStatement:="", SQLStatement1:=""
clsRidesPBar.IncOne
' write doc to disk....
WordDoc.SaveAs FileName:=strSaveDir & strNewName, _
FileFormat:=0, _
LockComments:=False, Password:="", AddToRecentFiles:=False, WritePassword:="", _
ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
clsRidesPBar.IncOne
WordApp.Visible = True
'AppActivate "Microsoft Word"
WordApp.Activate
WordApp.WindowState = 0 'wdWindowStateRestore
clsRidesPBar.HideProgress
Exit Function
CreateWordApp:
Set WordApp = CreateObject("Word.Application")
Resume Next
End Function
Function MakeMergeText(frmF As Form, strOutFile As String) As Boolean
' build our merge file, and write a simple "csv" file to disk
Dim OneField As DAO.Field
Dim strFields As String
Dim strData As String
Dim intFile As Integer
Dim vField As Control
Dim t As Variant
If frmF.RecordSource <> "" Then
If frmF.RecordsetClone.Fields.Count > 0 Then
For Each OneField In frmF.RecordsetClone.Fields
If strFields <> "" Then strFields = strFields & ","
strFields = strFields & qu(OneField.Name)
If strData <> "" Then strData = strData & ","
strData = strData & qu(frmF(OneField.Name))
Next OneField
End If
End If
For Each vField In frmF.Controls
If vField.ControlType = acTextBox Then
' if it is a text box, then include in field list
If vField.ControlSource = "" Then
If strFields <> "" Then strFields = strFields & ","
strFields = strFields & qu(vField.Name)
' now add data from this box
If strData <> "" Then strData = strData & ","
strData = strData & qu(frmF(vField.Name))
Else
' text box is bound, but ONLY include if it is NOT in the field list
On Error Resume Next
t = frmF.RecordsetClone.Fields(vField.Name).Name
If Err.Number = 0 Then
' field name is in reocrd set...skip
Else
Err.Clear
If strFields <> "" Then strFields = strFields & ","
strFields = strFields & qu(vField.Name)
' now add data from this box
If strData <> "" Then strData = strData & ","
strData = strData & qu(frmF(vField.Name))
End If
End If
End If
Next vField
'delete the out file if there
On Error Resume Next
Kill strOutFile
' now open file...
On Error GoTo exit1
intFile = FreeFile()
Open strOutFile For Output As intFile
Print #intFile, strFields
Print #intFile, strData
Close intFile
MakeMergeText = True
Exit Function
exit1:
MsgBox "Can't make merge file in directory called word" & vbCrLf & _
"The Word template may already be in use. Try closing word first." & vbCrLf & vbCrLf & _
"Make sure a directory called Word exists" & vbCrLf & _
"path name was " & strOutFile & vbCrLf & vbCrLf & _
"Please create a word directory, exit word and try again", vbCritical, "no word directory, or in already in use"
MakeMergeText = False
End Function
I need to hard code the directoy to absolute to
C:\Bumblebee\
(I will switch the code to my network..)
but I cannot see where
Option Compare Database
Option Explicit
'Const TextMerge As String = "merge.txt"
' May 20/2003 - see below comments why txt file name was changed.
Const TextMerge As String = "merge.888"
'******************************************
'* Word merge code *
'* (c) 2001 Albert D. Kallal *
'* kallal@msn.com *
'* *
'******************************************
'
' Usage:
' In code on a form with a data source, just place the following
' command behind a button
'
' MergeSingleWord
'
' That is it!!!
'
' You can also specify a dir for the above. This dir location is relative
' to location of the access dir. The default dir is "Word\". Hence, the real
' usage is:
' MergeSingleWord [dir],[bolFullPath]
'
' Example:
' MergeSingleWord "Customers"
'
' The above would use/create the templates in a dir called Customers (relative to app dir).
' The "\" is optional. If you leave out the "\", then my code appends a "\" to the dir
'
' An absolute location can be specified as:
' MergeSingleWord "c:\MyWord\", True
' The use of the True above forces the dir to be a full path name, and not relative
' to the app dir. The path must be a FULL path, and not relative.
'
'==========================================
' Revisions
' Date who Comments
' May 20, 2003 ADK - added on error resume next to the mkdir command in GetWordDir
' May 20, 2003 ADK - changed merge.txt file to merge.888 to fix text import bug
' (this is a know problem when you turn off file extensions
' in windows, the mail merge will fail KB article 137385)
' Aug 06, 2003 ADK - added ability to use different dire for each form.
' Aug 09, 2003 ADK - added a listbox sort routine
' Aug 28, 2003 ADK - change the "modify" template option to *always* set the
' data source to merge.888. That way, just hitting modify option
' will set the data source to the correct dir.
'
' Oct 22, 2003 ADK - changed the "qu" routine that surrounds the text data field to
' remove all " quotes to a ' (single quote).
'
' Oct 29, 2003 ADK - removed use of AppActivate "Microsoft Word" to use
' wordApp.Activate (this works with all versions, including xp where
' the window names are "separate"
' Feb 14, 2004 ADK - Added the code to set the data source EACH TIME a word doc is loaded.
' (This was done to fix problems with office 2003, and the message:
' "Opening This Will Run the Following SQL Command Message"
' There is a number of registry settings that can be changed. However
' just setting the data source EACH TIME the word doc is loaded also
' seems to by-pass the run SQL command nag message. Since this is hole
' in what is supposed to prevent automation code from setting the data
' source, I am betting that future releases will beak my code!
' Sept 24, 2004 ADK - added some code to allow name of output doc to be set.
' Mar 06, 2005 ADK - unbound text boxes are now included for single word merge
' Sep 07, 2005 ADK - mergenoprompts now allows sql string to be based
' Oct 10, 2006 ADK - text boxes on forms now can be used in the merge.
' Oct 14, 2006 ADK - fill prompt fields cased menu bars to not show, fixed by
' moving the visible + activate code to BEFORE the merge.
' Dec 11, 2006 ADK - fixed a focus bug, and now use a SEPERATE instance of
' the "open" word document to fix a problem when docuemnts
' are already open
Public Function MergeSingleWord(Optional strDir As String = "Word\", _
Optional bolFullPath As Boolean = False, _
Optional strOutPutDoc As String = "")
' Main Word merge function
' Albert D. Kallal
' kallal@msn.com
'
'
' starts the whole process of a "merge" template (single record) in rides.
'
' Simply place this command behind a button on a form.
' A function was used here in place of a "sub". This was done since a
' custom menu bar can call this code by placing =MergeSingleWord() in the
' menu's on-action. Thus, if you use custom menu bars, this code will work!
' This code thus picks up the active screen name, and functions from that.
' Parms are:
' strDir optional dir (include the \) the dir name - relative to applicaton dir
' bolfullPath optinal flag. Set to TRUE if the above dir is a full path name. If you
' do NOT set this flag (or leave it as false), the the path name is relative
' to the appliction dir.
' stroutPutDoc Name of the document to be saved to disk. (full path requied here)
Dim strOutFile As String ' temp csv merge text file name
Dim frmF As Form
Dim strDirPath As String ' full path name to working dir
Set frmF = Screen.ActiveForm
frmF.Refresh
strDirPath = DirToPath(strDir, bolFullPath)
strOutFile = strDirPath & TextMerge
' output our simple merge file
If MakeMergeText(frmF, strOutFile) Then
DoCmd.OpenForm "GuiWordTemplate", , , , , , strDirPath & "~" & strOutPutDoc
End If
End Function
Public Function MergeAllWord(strSql As String, _
Optional strDir As String = "Word\", _
Optional bolFullPath As Boolean = False, _
Optional strOutPutDoc As String) As Boolean
' Merge all reocrds from the form.
' This rouinte can take any sql statement you pass, and create
' a merge doc. Thus, this is used for "many" merged, and not
' a single merge.
' Simply this rouintes writes out a csv file based on the
' sql, and then launches the merge form.
' Parms are:
' strDir relative path to dir
' bolFullPath if set true, then above path is NOT relative
' strOutPutDoc if set, then write out the merged doc to this file
' build our merge file, and write a "csv" file to disk
Dim strDirPath As String ' full path name to working dir
Dim OneField As DAO.Field ' dao code
Dim strFields As String
Dim strData As String
Dim intFile As Integer
Dim rstOutput As DAO.Recordset
Dim strOutFile As String ' csv file output name
On Error GoTo exit2 ' if sql is bad...simply exit...
Set rstOutput = CurrentDb.OpenRecordset(strSql)
If rstOutput.RecordCount = 0 Then
' no records...exit.
GoTo exit1
End If
' build the merge file, but show the process bar
'
clsRidesPBar.ShowProgress
clsRidesPBar.TextMsg = "Building merge file..."
On Error GoTo exit1 ' if sql is bad...simply exit...
rstOutput.MoveLast
rstOutput.MoveFirst
' set max value of progress bar to number of records
clsRidesPBar.Pmax = rstOutput.RecordCount
' build the first line of fields for csv
For Each OneField In rstOutput.Fields
If strFields <> "" Then strFields = strFields & ","
strFields = strFields & qu(OneField.Name)
Next OneField
' build the merge.txt file
strDirPath = DirToPath(strDir, bolFullPath)
strOutFile = strDirPath & TextMerge
'delete the out file if there
On Error Resume Next
Kill strOutFile
' now open file...
On Error GoTo exit1
intFile = FreeFile()
Open strOutFile For Output As intFile
Print #intFile, strFields
' output all data
Do While rstOutput.EOF = False
strData = "" ' one line of data for csv file
For Each OneField In rstOutput.Fields
If strData <> "" Then strData = strData & ","
strData = strData & qu(rstOutput(OneField.Name))
Next OneField
Dim vField As Control
Print #intFile, strData
rstOutput.MoveNext
clsRidesPBar.IncOne
Loop
Close intFile
MergeAllWord = True
clsRidesPBar.HideProgress
DoCmd.OpenForm "GuiWordTemplate", , , , , , strDirPath & "~" & strOutPutDoc
Exit Function
exit1:
clsRidesPBar.HideProgress
exit2:
MsgBox "No data was created for this merge" & vbCrLf & _
"Make sure the sql is correct" & vbCrLf & _
"sql was " & vbCrLf & vbCrLf & strSql, _
vbCritical, "no data for this merge"
MergeAllWord = False
End Function
Public Function MergeNoPrompts(strDoc As String, _
Optional strDir As String = "word\", _
Optional bolFullPath As Boolean = False, _
Optional strOutDocName As String, _
Optional strSql As String = "", _
Optional bolPrint As Boolean = False, _
Optional StrPrinter As String = "")
Dim frmF As Form
Dim strFullDocName As String
Dim strDirPath As String
Dim strOutFile As String
Set frmF = Screen.ActiveForm
frmF.Refresh
strDirPath = DirToPath(strDir, bolFullPath)
strFullDocName = strDirPath & strDoc
strOutFile = strDirPath & TextMerge ' temp text file name
' sql passed?
If strSql <> "" Then
If MakeMergeAll(strSql, strDir, bolFullPath) = False Then
' could not create...exit
Exit Function
End If
Else
If MakeMergeText(frmF, strOutFile) = False Then
' could not create...exit
Exit Function
End If
End If
Call RidesMergeWord(strFullDocName, strDirPath, strOutDocName, bolPrint, StrPrinter)
End Function
Function GetAppDir() As String
' This routine simply returns the current applction dir
'+ \word
' If the dir does not exist, then we create it.
' This is the dir where the word docs will be created.
Dim strDB As String
' build a string based on the CURRENT mdb direcotry + \word
strDB = CurrentDb.Name
GetAppDir = Left(strDB, Len(strDB) - Len(Dir(strDB)))
End Function
Function DirToPath(strDir As String, bolFullPath) As String
If Right(strDir, 1) <> "\" Then
strDir = strDir & "\"
End If
If bolFullPath = True Then
' full path name to a dir ...not relative
DirToPath = strDir
Else
DirToPath = GetAppDir & strDir
End If
Call CheckDir(DirToPath) ' checks if dir exist..if not it creates the dir
End Function
Sub CheckDir(strDir As String)
If strDir = "" Then Exit Sub
If Len(Dir(strDir)) = 0 Then
On Error Resume Next
MkDir strDir
End If
End Sub
Function qu(vText As Variant) As String
' takes a string and surrounds it with double quotes
' All " (double quotes) are converted to ' (single quotes) before
' this is done
If IsNull(vText) = False Then
If InStr(vText, Chr(34)) > 0 Then
vText = strDReplace(CStr(vText), Chr(34), "'")
End If
End If
qu = Chr$(34) & vText & Chr$(34)
End Function
Function strDReplace(vText As String, strSearchFor As String, strReplaceTo As String) As String
Dim intFoundPos As Integer
Dim intSearchLen As Integer
Dim intReplaceLen As Integer
intSearchLen = Len(strSearchFor)
intReplaceLen = Len(strReplaceTo)
intFoundPos = InStr(vText, strSearchFor)
Do While intFoundPos > 0
vText = Left$(vText, intFoundPos - 1) & strReplaceTo & Mid(vText, intFoundPos + intSearchLen)
intFoundPos = InStr(vText, strSearchFor)
Loop
strDReplace = vText
End Function
Function RidesMergeWord(strDocName As String, _
strDataDir As String, _
Optional strOutDocName As String, _
Optional bolPrint As Boolean = False, _
Optional StrPrinter As String)
' This code takes a word document that has been setup as a MERGE document.
' This merge document is opened, then mailmerge is executed. The original
' document is then closed. The result is a raw word document with no connectons
' to the merge.txt (a csv source data file).
'Parms:
' strDocName - full path name of word doc (.doc)
' strDataDir - dir (full path) where docuemnts and the merge.888 file is placed
' strOutDocName - full path name of merged document (saved).
' bolPrint - if true, then output docuemnt is printed - if strOutDocName is suppled then we close the docuemnt
' strPrinter - sends output to the printer name
'
'
' The above parms are suppled by other routines. You likey should not need to call this
' routine directly. See the sub called MergeNoPrompts.
' Albert D. Kallal (c) 2001
' kalla@msn.com
'
Dim WordApp As Object ' running instance of word
Dim WordDoc As Object ' one instance of a word doc
Dim WordDocM As Object ' one instance of a word doc
Dim strActiveDoc As String ' doc name (no path)
Dim lngWordDest As Long ' const for dest, 0 = new doc, 1 = printer
Dim MyPbar As New clsRidesPBar ' create a instance of our Progress bar.
MyPbar.ShowProgress
MyPbar.TextMsg = "Launching Word...please wait..."
MyPbar.Pmax = 4 ' 4 steps to inc
MyPbar.IncOne ' step 1....start!
On Error GoTo CreateWordApp
Set WordApp = GetObject(, "Word.Application")
On Error Resume Next
MyPbar.IncOne ' step 2, word is loaded.
Set WordDoc = WordApp.Documents.Open(strDocName)
MyPbar.IncOne ' step 3, doc is loaded
strActiveDoc = WordApp.ActiveDocument.Name
'wordApp.Activate
If bolPrint = False Then
WordApp.Visible = True
WordApp.Activate
WordApp.WindowState = 0 'wdWindowStateRestore
End If
WordDoc.MailMerge.OpenDataSource _
Name:=strDataDir & TextMerge, _
ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=0, _
Connection:="", SQLStatement:="", SQLStatement1:=""
With WordDoc.MailMerge
.Destination = 0 ' 0 = new doc
.MailAsAttachment = False
.MailAddressFieldName = ""
.MailSubject = ""
.SuppressBlankLines = True
With .datasource
.FirstRecord = 1
' .LastRecord = 1
End With
.Execute Pause:=False
End With
Set WordDocM = WordApp.ActiveDocument
MyPbar.IncOne ' step 4, doc is merged
WordDoc.Close (False)
WordApp.Visible = True
If strOutDocName <> "" Then
'wordApp.ActiveDocument.SaveAs strOutDocName
WordDocM.SaveAs strOutDocName
End If
If bolPrint = False Then
WordDocM.Activate
Else
' print this document
If StrPrinter <> "" Then
With WordApp.Dialogs(97) ' 97 - wdDialogFilePrintSetup
.Printer = StrPrinter
.DoNotSetAsSysDefault = True
.Execute
End With
End If
WordDocM.PrintOut
'If strOutDocName <> "" Then
'wordApp.ActiveDocument.Close (False)
' when we print...we *always* close the docuemnt..
WordDocM.Close (False)
'End If
WordApp.Visible = True
End If
MyPbar.HideProgress
Set WordApp = Nothing
Set WordDoc = Nothing
Set WordDocM = Nothing
Set MyPbar = Nothing
DoEvents
' If bolShowMerge = True Then
' WordApp.Dialogs(676).Show 'wdDialogMailMerge
' End If
Exit Function
CreateWordApp:
' this code is here to use the EXISTING copy of
' ms-access running. If getobject fails, then
' ms-word was NOT running. The below will then
' launch word
Set WordApp = CreateObject("Word.Application")
Resume Next
End Function
Function RidesEditTemplate(strWordDoc As String, strSaveDir As String)
' Opens a word doc in mail merge mode
Dim WordApp As Object
Dim WordDoc As Object
clsRidesPBar.ShowProgress
clsRidesPBar.TextMsg = "Launching Word...please wait..."
On Error GoTo CreateWordApp
Set WordApp = GetObject(, "Word.Application")
On Error GoTo 0
Set WordDoc = WordApp.Documents.Open(strWordDoc)
WordApp.Visible = True
'*-
WordDoc.MailMerge.MainDocumentType = 0 ' wdFormLetters = 0
WordDoc.MailMerge.OpenDataSource _
Name:=strSaveDir & TextMerge, _
ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=0, _
Connection:="", SQLStatement:="", SQLStatement1:=""
'*-
'AppActivate "Microsoft Word"
WordApp.Activate
WordApp.WindowState = 0 'wdWindowStateRestore
clsRidesPBar.HideProgress
Exit Function
CreateWordApp:
Set WordApp = CreateObject("Word.Application")
Resume Next
End Function
Function RidesNewTemplate(strSaveDir As String)
' ask user for template name to create
'
' Parms:
' strSaveDir = full path of dir is (includes the last backslash \
Dim strNewName As String
Dim WordApp As Object 'Word.Applicaton
Dim WordDoc As Object 'Word.Document
strNewName = ""
strNewName = InputBox("What name for new template" & vbCrLf & vbCrLf & _
"(Enter name with no file extension)", _
"Create New Word merge Template")
If strNewName = "" Then Exit Function
' get work object...
clsRidesPBar.ShowProgress
clsRidesPBar.TextMsg = "Launching Word...please wait..."
clsRidesPBar.Pmax = 4
clsRidesPBar.IncOne
On Error GoTo CreateWordApp
Set WordApp = GetObject(, "Word.Application")
On Error GoTo 0
clsRidesPBar.IncOne
Set WordDoc = WordApp.Documents.Add
WordDoc.MailMerge.MainDocumentType = 0 ' wdFormLetters = 0
'MsgBox strSaveDir
WordDoc.MailMerge.OpenDataSource _
Name:=strSaveDir & TextMerge, _
ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=0, _
Connection:="", SQLStatement:="", SQLStatement1:=""
clsRidesPBar.IncOne
' write doc to disk....
WordDoc.SaveAs FileName:=strSaveDir & strNewName, _
FileFormat:=0, _
LockComments:=False, Password:="", AddToRecentFiles:=False, WritePassword:="", _
ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
clsRidesPBar.IncOne
WordApp.Visible = True
'AppActivate "Microsoft Word"
WordApp.Activate
WordApp.WindowState = 0 'wdWindowStateRestore
clsRidesPBar.HideProgress
Exit Function
CreateWordApp:
Set WordApp = CreateObject("Word.Application")
Resume Next
End Function
Function MakeMergeText(frmF As Form, strOutFile As String) As Boolean
' build our merge file, and write a simple "csv" file to disk
Dim OneField As DAO.Field
Dim strFields As String
Dim strData As String
Dim intFile As Integer
Dim vField As Control
Dim t As Variant
If frmF.RecordSource <> "" Then
If frmF.RecordsetClone.Fields.Count > 0 Then
For Each OneField In frmF.RecordsetClone.Fields
If strFields <> "" Then strFields = strFields & ","
strFields = strFields & qu(OneField.Name)
If strData <> "" Then strData = strData & ","
strData = strData & qu(frmF(OneField.Name))
Next OneField
End If
End If
For Each vField In frmF.Controls
If vField.ControlType = acTextBox Then
' if it is a text box, then include in field list
If vField.ControlSource = "" Then
If strFields <> "" Then strFields = strFields & ","
strFields = strFields & qu(vField.Name)
' now add data from this box
If strData <> "" Then strData = strData & ","
strData = strData & qu(frmF(vField.Name))
Else
' text box is bound, but ONLY include if it is NOT in the field list
On Error Resume Next
t = frmF.RecordsetClone.Fields(vField.Name).Name
If Err.Number = 0 Then
' field name is in reocrd set...skip
Else
Err.Clear
If strFields <> "" Then strFields = strFields & ","
strFields = strFields & qu(vField.Name)
' now add data from this box
If strData <> "" Then strData = strData & ","
strData = strData & qu(frmF(vField.Name))
End If
End If
End If
Next vField
'delete the out file if there
On Error Resume Next
Kill strOutFile
' now open file...
On Error GoTo exit1
intFile = FreeFile()
Open strOutFile For Output As intFile
Print #intFile, strFields
Print #intFile, strData
Close intFile
MakeMergeText = True
Exit Function
exit1:
MsgBox "Can't make merge file in directory called word" & vbCrLf & _
"The Word template may already be in use. Try closing word first." & vbCrLf & vbCrLf & _
"Make sure a directory called Word exists" & vbCrLf & _
"path name was " & strOutFile & vbCrLf & vbCrLf & _
"Please create a word directory, exit word and try again", vbCritical, "no word directory, or in already in use"
MakeMergeText = False
End Function
