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

My Archive

My FAQ Archive

Come Join Us!

Posting Guidelines

Jobs

Microsoft: Access Modules (VBA Coding) FAQ

How To

My Archive

Join Tek-Tips® Today!

Join Tek-Tips^® Today!