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
|
|
|
|
Talk To Other Members