Access to Word Merge into Separately Saved Documents

[alpinegroove]

I use the following code to merge data from Access into a Word document in which the merge had been set up.
The result is a long list of letters in one Word file.

Is there a way to add code that would save each letter separately?
The file name should be based on two fields from the same query the merge is based on: qryComp.


The fields are [LastName] and [CourseTitle].

Thank you.

Private Sub Command1_Click()

     
        Dim strPath As String
        Dim strDataSource As String
        Dim conTemplate As String
        Dim conQuery As String
     
        Dim doc As Word.Document
        Dim wrdApp As Word.Application
     
        conTemplate = "11 Instructor Contract Template.doc"
        conQuery = "qryComp"
     
        On Error GoTo HandleErrors
        ' Delete the rtf file, if it already exists.
        strPath = "H:\"
        strDataSource = strPath & conQuery & ".doc"
        Kill strDataSource
     
        ' Export the data to rtf format.
        DoCmd.OutputTo acOutputQuery, conQuery, _
         acFormatRTF, strDataSource, False
     
        ' Start Word using the mail merge template.
        Set wrdApp = New Word.Application
        Set doc = wrdApp.Documents.Add(strPath & conTemplate)
     
        ' Do the mail merge to a new document.
        With doc.MailMerge
            .OpenDataSource Name:=strDataSource
            .Destination = wdSendToNewDocument
            .SuppressBlankLines = True
            With .DataSource
                .FirstRecord = wdDefaultFirstRecord
                .LastRecord = wdDefaultLastRecord
            End With
            If .State = wdMainAndDataSource Then
                .Execute
            End If
        End With
     
        ' Display the mail merge document.
        wrdApp.Visible = True
     
     
ExitHere:
        Set doc = Nothing
        Set wrdApp = Nothing
        Set doc2 = Nothing
        Set wrdApp2 = Nothing
        Exit Sub
     
HandleErrors:
        Select Case Err.Number
            Case 53         ' File not found.
                Resume Next
            Case Else
                MsgBox Err.Number & ": " & Err.Description
                Resume ExitHere
        End Select
     
     
     
    End Sub

[June7]

Google: access word mail merge save letters separate files

Here is one

http://www.gmayor.com/individual_merge_letters.htm

[alpinegroove]

Thanks for the link. I saw it earlier. Isn't that code for Word, not Access?

[June7]

Didn't notice but guess it is set up behind Word document. However, it is VBA and should be adaptable to run behind Access although might be better and easier behind the Word document. Do you have a saved Word document that is used for this merge? I suppose code could go there. I have never coded for Word.

Else, try Google some more.

[alpinegroove]

Ok, thanks.

[alpinegroove]

Update: I ended up using the following VBA code in Word. It is based on the widely discussed add-on:
http://www.gmayor.com/individual_merge_letters.htm

My document has a header/letterhead, so I could not use the Normal template. I had to create a different template and direct the code to it.

So my Access VBA code merges the document and the opens the Word macro. I would rather have all of this happen via Access, but this will do for now.

Thanks for the help.

Sub SplitMergedLetter()

' splitter Macro modified to save individual letters with
' information from data source. The filename data must be added to
' the top of the merge letter - see web article.

Dim sName As String
Dim docName As String
Dim Letters As String
Dim Counter As Long
Dim oDoc As Document
Dim oNewDoc As Document

Set oDoc = ActiveDocument
oDoc.SaveAs "C:\Documents and Settings\xyz\Desktop\MergeTest\MergedContracts.doc "
Selection.EndKey Unit:=wdStory
Letters = Selection.Information(wdActiveEndSectionNumber)
Selection.HomeKey Unit:=wdStory
Counter = 1
While Counter < Letters
Application.ScreenUpdating = False
With Selection

.HomeKey Unit:=wdStory
.EndKey Unit:=wdLine, Extend:=wdExtend
.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend

End With

sName = Selection
docName = "C:\Documents and Settings\xyz\Desktop\MergeTest\" & sName & ".doc"

oDoc.Sections.First.Range.Cut
Set oNewDoc = Documents.Add(Template:="C:\Documents and Settings\xyz\Application Data\Microsoft\Templates\Contract Template.dot")

With Selection
.Paste
.HomeKey Unit:=wdStory
.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
.Delete
End With
oNewDoc.SaveAs filename:=docName, _
FileFormat:=wdFormatDocument, _
AddToRecentFiles:=False
ActiveWindow.Close
Counter = Counter + 1
Application.ScreenUpdating = True
Wend

oDoc.Close wdDoNotSaveChanges
End Sub

[June7]

Congratulations! Glad you got a solution.