INTELLIGENT WORK FORUMS FOR COMPUTER PROFESSIONALS
Log In
Come Join Us!
Are you a Computer / IT professional? Join Tek-Tips Forums!
- Talk With Other Members
- Be Notified Of Responses
To Your Posts
- Keyword Search
- One-Click Access To Your
Favorite Forums
- Automated Signatures
On Your Posts
- Best Of All, It's Free!
*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.
Posting Guidelines
Promoting, selling, recruiting, coursework and thesis posting is forbidden. Students Click Here
|
Microsoft: Access Modules (VBA Coding) FAQ
How To
Automate mailmerge - without a template by redapples
Posted: 3 Jul 03 (Edited 27 Aug 03)
|
I have used a reference to Microsoft Word 9.0 for this, lower versions of this reference may or may not work.
This FAQ is rather long but if you want to create word documents for scratch you can disregard the rather long code section at the start.
I have written this FAQ in response to a problem that I was having in the hope that it will help others to achieve similar results. The contents of this have been cobbled together using both MS Knowledgebase article 209882 and samples from the NorthWind Database.
What I was attempting to do was to allow users of a mailing database create a mailmerge document using a table generated from the Database with any document that they had created. Perhaps a simpler solution would be to set up a template for a letter that used the mailmerge fields, however, in my experience getting users to use the correct template is no easy task.
The first problem I had was how to find and select the document from the database. This turned out to be relatively simple using code from the NorthWind DB:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' FindThatDOC ' ' ' ' This module contains code to allow you to open ' ' a word document based on Northwind stuff ' ' ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Option Explicit ' Require variables to be declared before being used. Option Compare Database ' Use database order for string comparisons.
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _ "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _ "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Type MSA_OPENFILENAME ' Filter string used for the Open dialog filters. ' Use MSA_CreateFilterString() to create this. ' Default = All Files, *.* strfilter As String ' Initial Filter to display. ' Default = 1. lngFilterIndex As Long ' Initial directory for the dialog to open in. ' Default = Current working directory. strInitialDir As String ' Initial file name to populate the dialog with. ' Default = "". strInitialFile As String strDialogTitle As String ' Default extension to append to file if user didn't specify one. ' Default = System Values (Open File, Save File). strDefaultExtension As String ' Flags (see constant list) to be used. ' Default = no flags. lngFlags As Long ' Full path of file picked. When the File Open dialog box is ' presented, if the user picks a nonexistent file, ' only the text in the "File Name" box is returned. strFullPathReturned As String ' File name of file picked. strFileNameReturned As String ' Offset in full path (strFullPathReturned) where the file name ' (strFileNameReturned) begins. intFileOffset As Integer ' Offset in full path (strFullPathReturned) where the file extension begins. intFileExtension As Integer End Type
Const ALLFILES = "All Files"
Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As Long nMaxCustrFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String Flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustrData As Long lpfnHook As Long lpTemplateName As Long End Type
Const OFN_ALLOWMULTISELECT = &H200 Const OFN_CREATEPROMPT = &H2000 Const OFN_EXPLORER = &H80000 Const OFN_FILEMUSTEXIST = &H1000 Const OFN_HIDEREADONLY = &H4 Const OFN_NOCHANGEDIR = &H8 Const OFN_NODEREFERENCELINKS = &H100000 Const OFN_NONETWORKBUTTON = &H20000 Const OFN_NOREADONLYRETURN = &H8000 Const OFN_NOVALIDATE = &H100 Const OFN_OVERWRITEPROMPT = &H2 Const OFN_PATHMUSTEXIST = &H800 Const OFN_READONLY = &H1 Const OFN_SHOWHELP = &H10 Function FindDoc(strSearchPath) As String ' Displays the Open dialog box for the user to locate ' the Northwind database. Returns the full path to Northwind. Dim msaof As MSA_OPENFILENAME ' Set options for the dialog box. msaof.strDialogTitle = "Where is the document you wish to open?" msaof.strInitialDir = strSearchPath msaof.strfilter = MSA_CreateFilterString("Word Documents (*.doc)", "*.doc") ' Call the Open dialog routine. MSA_GetOpenFileName msaof ' Return the path and file name. FindDoc = Trim(msaof.strFullPathReturned) ReadyToMerge (FindDoc) End Function
Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String ' Creates a filter string from the passed in arguments. ' Returns "" if no argumentss are passed in. ' Expects an even number of argumentss (filter name, extension), but ' if an odd number is passed in, it appends "*.*". Dim strfilter As String Dim intRet As Integer Dim intNum As Integer
intNum = UBound(varFilt) If (intNum <> -1) Then For intRet = 0 To intNum strfilter = strfilter & varFilt(intRet) & vbNullChar Next If intNum Mod 2 = 0 Then strfilter = strfilter & "*.*" & vbNullChar End If strfilter = strfilter & vbNullChar Else strfilter = "" End If
MSA_CreateFilterString = strfilter End Function
Function MSA_ConvertFilterString(strFilterIn As String) As String ' Creates a filter string from a bar ("|") separated string. ' The string should pairs of filter|extension strings, i.e. "Access Databases|*.mdb|All Files|*.*" ' If no extensions exists for the last filter pair, *.* is added. ' This code will ignore any empty strings, i.e. "||" pairs. ' Returns "" if the strings passed in is empty.
Dim strfilter As String Dim intNum As Integer, intPos As Integer, intLastPos As Integer
strfilter = "" intNum = 0 intPos = 1 intLastPos = 1
' Add strings as long as we find bars. ' Ignore any empty strings (not allowed). Do intPos = InStr(intLastPos, strFilterIn, "|") If (intPos > intLastPos) Then strfilter = strfilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar intNum = intNum + 1 intLastPos = intPos + 1 ElseIf (intPos = intLastPos) Then intLastPos = intPos + 1 End If Loop Until (intPos = 0) ' Get last string if it exists (assuming strFilterIn was not bar terminated). intPos = Len(strFilterIn) If (intPos >= intLastPos) Then strfilter = strfilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar intNum = intNum + 1 End If ' Add *.* if there's no extension for the last string. If intNum Mod 2 = 1 Then strfilter = strfilter & "*.*" & vbNullChar End If ' Add terminating NULL if we have any filter. If strfilter <> "" Then strfilter = strfilter & vbNullChar End If MSA_ConvertFilterString = strfilter End Function
Private Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer ' Opens the file save dialog. Dim of As OPENFILENAME Dim intRet As Integer
MSAOF_to_OF msaof, of of.Flags = of.Flags Or OFN_HIDEREADONLY intRet = GetSaveFileName(of) If intRet Then OF_to_MSAOF of, msaof End If MSA_GetSaveFileName = intRet End Function
Function MSA_SimpleGetSaveFileName() As String ' Opens the file save dialog with default values.
Dim msaof As MSA_OPENFILENAME Dim intRet As Integer Dim strRet As String intRet = MSA_GetSaveFileName(msaof) If intRet Then strRet = msaof.strFullPathReturned End If MSA_SimpleGetSaveFileName = strRet End Function
Private Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer ' Opens the Open dialog. Dim of As OPENFILENAME Dim intRet As Integer
MSAOF_to_OF msaof, of intRet = GetOpenFileName(of) If intRet Then OF_to_MSAOF of, msaof End If MSA_GetOpenFileName = intRet End Function
Function MSA_SimpleGetOpenFileName() As String ' Opens the Open dialog with default values.
Dim msaof As MSA_OPENFILENAME Dim intRet As Integer Dim strRet As String intRet = MSA_GetOpenFileName(msaof) If intRet Then strRet = msaof.strFullPathReturned End If MSA_SimpleGetOpenFileName = strRet End Function
Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME) ' This sub converts from the Win32 structure to the Microsoft Access structure. msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1) msaof.strFileNameReturned = of.lpstrFileTitle msaof.intFileOffset = of.nFileOffset msaof.intFileExtension = of.nFileExtension End Sub
Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME) ' This sub converts from the Microsoft Access structure to the Win32 structure. Dim strFile As String * 512
' Initialize some parts of the structure. of.hwndOwner = Application.hWndAccessApp of.hInstance = 0 of.lpstrCustomFilter = 0 of.nMaxCustrFilter = 0 of.lpfnHook = 0 of.lpTemplateName = 0 of.lCustrData = 0 If msaof.strfilter = "" Then of.lpstrFilter = MSA_CreateFilterString(ALLFILES) Else of.lpstrFilter = msaof.strfilter End If of.nFilterIndex = msaof.lngFilterIndex of.lpstrFile = msaof.strInitialFile _ & String(512 - Len(msaof.strInitialFile), 0) of.nMaxFile = 511
of.lpstrFileTitle = String(512, 0) of.nMaxFileTitle = 511
of.lpstrTitle = msaof.strDialogTitle
of.lpstrInitialDir = msaof.strInitialDir of.lpstrDefExt = msaof.strDefaultExtension
of.Flags = msaof.lngFlags of.lStructSize = Len(of) End Sub
Private Function ReadyToMerge(strFileName As String) As Boolean
Call CreateMergeDoc (False,False,strFileName) æthese false declarations can be set as true to use DDE and to Print, Sequentially End Function
Phew! Basically what this does is allow you to browse for and select a word document in a window the same as open document in Office applications. Once selected it prepares the path of the document into a useable string. In the end it call a function (see below) for executing the mailmerge itself. There are three variables carried to this last function. The first two are Boolean, controlling whether to use DDE or ODBC û the first Boolean û and whether or not to automatically print the document. The last is the name and path of the selected document.
The merge Function is here and comes from KB article 209882. I have modified this to open an existing document rather than a new one. I have left in bits of code I chose not to use but commented them out. This way you can see an illustration of additional functionality that you might choose to use.
Function CreateMergeDoc(UseDDE As Boolean, PrintDoc As Boolean, strDocName) Dim WordApp As Word.Application Dim WordDoc As Word.Document Dim strLetter As String Dim strConnect As String
' Create an instance of Microsoft Word 2000. Set WordApp = CreateObject("Word.Application")
' Create a new, empty document. Set WordDoc = WordApp.Documents.Open(strDocName) With WordDoc.MailMerge If UseDDE Then strConnect = "Table tblMailMerge" Else ' Note that on your computer the path ' and database used will be different. strConnect = "DSN=MS Access " _ & "Database;DBQ=M:\Net_Stephen\New Folder\access\Other Work\Mailing Database\" _ & "MGHNv2.1.mdb;" _ & "FIL=MS Access;" End If ' Note that on your computer the path ' and database used will be different. .OpenDataSource _ Name:="M:\Net_Stephen\New Folder\access\Other Work\Mailing Database\" _ & "MGHNv2.1.mdb", _ ReadOnly:=True, LinkToSource:=True, _ Connection:=strConnect, _ SQLStatement:="SELECT * FROM [tblMailMerge]"
' Define the Merge fields in the document. With .Fields .Add Range:=WordApp.Selection.Range, Name:="Name" WordApp.Selection.TypeParagraph .Add Range:=WordApp.Selection.Range, Name:="Organisation" WordApp.Selection.TypeParagraph .Add Range:=WordApp.Selection.Range, Name:="Address_1" WordApp.Selection.TypeParagraph .Add Range:=WordApp.Selection.Range, Name:="Address_2" WordApp.Selection.TypeParagraph .Add Range:=WordApp.Selection.Range, Name:="Address_3" WordApp.Selection.TypeParagraph .Add Range:=WordApp.Selection.Range, Name:="PostCode" 'these fields are likely to change in your database too! End With End With
' Define the body of the letter in the merge document. 'strLetter = "Thank you for your business during the past year." 'With WordApp.Selection ' .TypeParagraph ' .TypeParagraph ' .TypeText Text:=strLetter ' .TypeParagraph ' .TypeParagraph ' .TypeText Text:="Sincerely," ' .TypeParagraph ' .TypeParagraph ' .TypeText Text:="Northwind Traders" 'End With
With WordDoc.MailMerge ' Only merge records 1-10 from the table. '.DataSource.FirstRecord = 1 '.DataSource.LastRecord = 10
' Merge the data to a new document. .Destination = wdSendToNewDocument
' Execute the mail merge. .Execute
' If user specified to print the document, disable ' background printing, and then print the merged document.
If PrintDoc Then .Application.Options.PrintBackground = False .Application.ActiveDocument.PrintOut End If End With
' Show the instance of Microsoft Word. WordApp.Visible = True End Function
In the above example the fields are entered into the top of the document, this is because the Selection on an opened document is the insertion point in the document before the first word of the first paragraph. To change this you can either change the range in the
.Add Range:=WordApp.Selection.Range, Name:="Organisation" statement to something like
.Add Range:= myRange, Name := "organisation" where myRange is a Word.Range object or change the Wordapp.Selection.Range position in the document.
Below is an example of how to do this where you search for a date and insert the address after that.
'the following declarations are needed. Dim p As Integer Dim myPara As Word.Paragraph
'Find the date 'get the number of paragraphs in the document pCount = WordDoc.Paragraphs.Count - 1 'loop through the paragraphs to find a date For Each myPara In WordDoc.Paragraphs p = p + 1'assign value to p If IsDate(myPara.Range) Then ' is there a date in the letter could be substituted to find text in the paragraph 'extend the selection to incorporate the paragraph you want. With WordApp.Selection .StartOf Unit:=wdParagraph, Extend:=wdMove .MoveDown Unit:=wdParagraph, Count:=(p+1), Extend:=wdExtend End With 'Set the Selection to the paragraph you want in this case after a date. WordApp.Selection.Paragraphs(p).Range.Select WordApp.Selection.EndKey Unit:=wdLine, Extend:=wdMove Exit For End If Next
after the above code has run the WordApp.Selection.Range is in the appropriate place and entries of the fields containing the address details will appear after the date. This works fine for letters but might need manipulation where another document is used. Where only one field is to be inserted then setting the range might be more useful.
a statement of
Set myRange = ActiveDocument.Range( _ Start:=ActiveDocument.Paragraphs(p).Range.Start, _ End:=ActiveDocument.Paragraphs(p).Range.End)
Would set a particular paragraph as the insertion point for
.Add Range:= myRange, Name := "organisation"
Ok, so what I have basically done is some research. However, hopefully having this both these bits of code in one place will make some of this a bit easier for people trying to do something similar. I take no real credit for the contents as other people have written it all, mostly.
I should also mention Tek-tips user hermananlaksko who answered one of my posts with a similar solution to the first bunch of functions to select a file. Skol Herman.
enjoy
redapples
|
Back to Microsoft: Access Modules (VBA Coding) FAQ Index
Back to Microsoft: Access Modules (VBA Coding) Forum |
|
|
|