Mail Merge SQL Table Data To MS Word

Here's two options I've used before.

1.Use Word's mail merge to merge data from a table via a DSN connection.

2.Create a csv file from a recordset then merge data from csv file using Word's mail merge.


1.Mail merge via ODBC DSN

Function MergeWordDoc(strTemplateName as string, Optional varTable As String) As Integer
   
    Dim i As Integer
    Dim nSec As Integer
   
    'Requires declarations and string values set for variables sDbPath & sDbName

    On Error GoTo ErrHandler
   
        With wdApp.ActiveDocument.MailMerge
            'Create Main Document from template
            .MainDocumentType = wdFormLetters

            'Get data source
            .OpenDataSource Name:= _
                sDbPath & sDbName, _
                ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
                PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
                WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, _
                Connection:="Table " & varTable, _
                SQLStatement:="SELECT * FROM " & varTable, SQLStatement1:=""
           
            .EditMainDocument
        End With

 '       'Hide Access window set property to false
 '       WindowVisible(FindWindowPartial("Microsoft Access")) = False

        'Merge Document
        With wdApp.ActiveDocument.MailMerge
            .Destination = wdSendToNewDocument
            .MailAsAttachment = False
            .MailAddressFieldName = ""
            .MailSubject = ""
            .SuppressBlankLines = True
            With .DataSource
                .FirstRecord = wdDefaultFirstRecord
                .LastRecord = wdDefaultLastRecord
            End With
            .Execute Pause:=True
        End With
   
    MergeWordDoc = 0

Exit Function

ErrHandler:
    MsgBox Err.Description

End Function
'-----------------------------------------------------------------------------------------------------------


2. Mail merge from rs via csv

Public Function MergeDoc(adoRS As adodb.Recordset, sTempCopy, varTable As String) As Boolean
   
    Dim i As Integer
    Dim j As Integer
    Dim n As Integer
    Dim nSec As Integer
    Dim wdDoc As New Word.Document
    Dim nflds As Integer
    Dim wdGlobVar As New Word.Global
    Dim nDocs As Integer
    Dim sData As String
    Dim bMergeFieldsFound As Boolean
    Dim nRecs As Integer
    Dim sFieldList As String
   
   
    'Can't pass RS to Word's normal mailmerge without an ODBC DSN
    'This code creates a csv data source and uses Word MailMerge to merge records to one doc?
   
   
    MergeDoc = False
   
    bError = False
   
    On Error GoTo errHandler
   
   
    If Not bAppDocOpen Then OpenDoc (sTempCopy)
       
        'Create Data Source Table in CSV file
       
        sFieldList = ""
       
        sDataDoc = Replace(sTempCopy, ".tmp", "Data.csv")
        sDataDoc = GetFileNameFromPath(sDataDoc)
        sDataDoc = sTempPath & sDataDoc
       
        bError = False
       
        'Write Csv file
        If WriteCsvFile(adoRS, sDataDoc, True) Then
   
            'Merge csv data file with doc
            With wdApp
                With .ActiveDocument.MailMerge
                    .OpenDataSource Name:=sDataDoc, _
                            ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
                            PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
                            WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, _
                            Connection:="Table " & varTable, _
                            SQLStatement:="", SQLStatement1:=""
                    .Destination = wdSendToNewDocument
                    .MailAsAttachment = False
                    .MailAddressFieldName = ""
                    .MailSubject = ""
                    .SuppressBlankLines = True
                    With .DataSource
                        .FirstRecord = wdDefaultFirstRecord
                        .LastRecord = wdDefaultLastRecord
                    End With
                    .Execute Pause:=True
                End With
            End With
           
            oPrintOptions.ProgressBar 1
        Else
            bError = True
        End If
               
   
    If Not bError = True Then MergeDoc = True


Exit Function

errHandler:
    MsgBox Err.Description

End Function
'-----------------------------------------------------------------------------------------------------------
Function GetFileNameFromPath(sPath As String) As String
  Dim sTemp As String
  Dim nPrev As Integer
  Dim nResult As Integer
  nPrev = 1
  If InStr(1, sPath, "\") = 0 Then
    GetFileNameFromPath = sPath
    Exit Function
  End If
  Do While True
    nResult = InStr(nPrev, sPath, "\")
    If nResult > 0 Then
      nPrev = nResult + 1
    Else
      If nPrev > 1 Then
        GetFileNameFromPath = Mid$(sPath, nPrev)
        Exit Do
      End If
    End If
  Loop
End Function
'-----------------------------------------------------------------------------------------------------------
Public Function WriteCsvFile(rs As adodb.Recordset, sFileNameWithPath As String, bShowProgress As Boolean) As Boolean
'Open named txt file in path or application path write field names and data records from passed recordset and close file
   
    Dim sFieldList As String
    Dim sDataRow As String
    Dim iFile As Integer
    Dim i As Integer
    Dim j As Integer
    Dim nRecs As Integer
    Dim nflds As Integer


    WriteCsvFile = False
   
    On Error GoTo errHandler
   
    rs.MoveFirst
   
    nRecs = rs.RecordCount
    nflds = rs.Fields.Count
   
                     
    iFile = FreeFile                        ' Get unused file number
   
    Open sFileNameWithPath For Output As #iFile
   
    'Write field list
    For i = 0 To nflds - 1
        If i = 0 Then
            sFieldList = Chr(34) & Trim(rs.Fields(i).Name) & Chr(34)
        Else
            sFieldList = sFieldList & ", " & Chr(34) & Trim(rs.Fields(i).Name) & Chr(34)
        End If
    Next i
   
    Print #iFile, sFieldList & vbCrLf
   
    'Write records
    For j = 0 To nRecs - 1
        For i = 0 To nflds - 1
            If i = 0 Then
                sDataRow = Chr(34) & Trim(rs.Fields(i).Value) & Chr(34)
            Else
                sDataRow = sDataRow & ", " & Chr(34) & Trim(rs.Fields(i).Value) & Chr(34)
            End If
        Next i
        Print #iFile, sDataRow & vbCrLf
        rs.MoveNext
        If bShowProgress Then oPrintOptions.ProgressBar 1
    Next j
       
    Close #iFile
   
    WriteCsvFile = True
   
   
    Exit Function
   
errHandler:
    MsgBox "Error writing local data file"
    On Error GoTo 0
   
End Function
'-----------------------------------------------------------------------------------------------------------