Merge form data with Word template, then auto publish to PDF

[chadbrewyet]

For some reason I can't seem to wrap my head around what I would think would be a simple process. I needed to merge a form's data into a pre-existing Word template so I looked around and found MANY MANY MANY code samples to do a word merge with each one being different from the last. :banghead:

I ended up finding a modified version of Kallal's Simple Word Merge (code below) that finally did what I needed. All the fields I need are merge and everything looks good. But after looking at so many different way to go about a word merge, I can't really understand what each section of the code does or how I can modify it further.

Now, what I would like to do is to create a command button that merges the form data with the word template but then automatically publishes it to a pdf document, ideally using some form fields as part of the file name. Can someone take a look at the code I'm using and offer some modifications to do that or maybe suggest a better, simpler, or cleaner way of doing the merge and publish?

Thanks.

Button Action code:

Private Sub Command205_Click()

TemplateName = Me.QuoteType & " Form.doc"
MergeSingleWord



End Sub

Word Merge Module Code (revision comments have been removed)

Option Compare Database
Option Explicit

Public Const mstrTemplatePath As String = "C:\letter templates\"
Public Const mstrTemplateName As String = ""
Public TemplateName As String

'Const TextMerge     As String = "merge.txt"

Const TextMerge      As String = "merge.888"


Public Function MergeSingleWord(Optional strDir As String = "Word\", Optional bolFullPath As Boolean = False)
 
On Error GoTo Err_Handler
'Last mod date 15/06/2011
'tested
   Dim strOutFile As String      ' temp csv merge text file name
   Dim frmF As Form

   Set frmF = Screen.ActiveForm
   frmF.Refresh


   strOutFile = mstrTemplatePath & TextMerge

   ' output our simple merge file

   If MakeMergeText(frmF, strOutFile) Then
    Call MergeWord(mstrTemplatePath & TemplateName, mstrTemplatePath)
   End If

Exit_Handler:
    On Error Resume Next
    Set frmF = Nothing
    Exit Function
Err_Handler:
    Debug.Print Err.Number, Err.Description, "MergeSingleWord", Now
    Resume Exit_Handler

End Function

Public Function MergeAllWord(strSql As String, _
                     Optional strDir As String = "Word\", _
                     Optional bolFullPath As Boolean = False) As Boolean


On Error GoTo Err_Handler
'Last mod date 15/06/2011
'tested
   Dim strDirPath As String            ' full path name to working dir
   Dim OneField As DAO.Field          ' dao code
   Dim strFields As String
   Dim strData As String
   Dim intFile As Integer
   Dim lngCount As Long
   Dim rstOutput As DAO.Recordset
   Dim strOutFile As String      ' csv file output name

   On Error GoTo exit1     ' if sql is bad...simply exit...

   'Debug.Print strSQL
   Set rstOutput = CurrentDb.OpenRecordset(strSql)

   lngCount = rstOutput.RecordCount
   'Debug.Print lngCount
   If lngCount <= 0 Then
      ' no records...exit.
      GoTo exit1
   End If

   ' build the merge file, but show the process bar
   '
   rstOutput.MoveLast
   rstOutput.MoveFirst

   ' build the first line of fields for csv

    For Each OneField In rstOutput.Fields
          If strFields <> "" Then strFields = strFields & ","
          strFields = strFields & qu(OneField.Name)
    Next OneField

    ' build the merge.txt file

    strOutFile = mstrTemplatePath & TextMerge
    'delete the out file if there
    On Error Resume Next
    Kill strOutFile

   ' now open file...

   On Error GoTo exit1
   intFile = FreeFile()
   Open strOutFile For Output As intFile
   Print #intFile, strFields

   ' output all data
   Do While rstOutput.EOF = False

      strData = ""         ' one line of data for csv file
      For Each OneField In rstOutput.Fields

         If strData <> "" Then strData = strData & ","
         strData = strData & qu(rstOutput(OneField.Name))

      Next OneField

      Print #intFile, strData

      rstOutput.MoveNext
   Loop

   Close intFile

   MergeAllWord = True

   Call MergeWord(mstrTemplatePath & TemplateName, mstrTemplatePath)
   Exit Function

exit1:
   MsgBox "No data was created for this merge" & vbCrLf & _
          "Make sure the sql is correct" & vbCrLf & _
          "sql was " & vbCrLf & vbCrLf & strSql, _
          vbCritical, "no data for this merge"

   MergeAllWord = False

Exit_Handler:
    On Error Resume Next
    Set rstOutput = Nothing
    Exit Function
Err_Handler:
    Debug.Print Err.Number, Err.Description, "MergeAllWord", Now
    Resume Exit_Handler


End Function


Public Function qu(vText As Variant) As String
   ' takes a string and surrounds it with double quotes
   ' All " (double quotes) are converted to ' (single quotes) before
   ' this is done
On Error GoTo Err_Handler
'Last mod date 15/06/2011
'tested
   If IsNull(vText) = False Then
      If InStr(vText, Chr(34)) > 0 Then
         vText = strDReplace(CStr(vText), Chr(34), "'")
      End If
   End If

   qu = Chr$(34) & vText & Chr$(34)

Exit_Handler:
    Exit Function
Err_Handler:
    Debug.Print Err.Number, Err.Description, "qu", Now
    Resume Exit_Handler

End Function

Public Function strDReplace(vText As String, strSearchFor As String, strReplaceTo As String) As String
On Error GoTo Err_Handler
'Last mod date 15/06/2011
'tested
   Dim intFoundPos      As Integer
   Dim intSearchLen     As Integer
   Dim intReplaceLen    As Integer

   intSearchLen = Len(strSearchFor)
   intReplaceLen = Len(strReplaceTo)

   intFoundPos = InStr(vText, strSearchFor)

   Do While intFoundPos > 0
      vText = Left$(vText, intFoundPos - 1) & strReplaceTo & Mid(vText, intFoundPos + intSearchLen)
      intFoundPos = InStr(vText, strSearchFor)
   Loop

   strDReplace = vText

Exit_Handler:
    Exit Function
Err_Handler:
    Debug.Print Err.Number, Err.Description, "strDReplace", Now
    Resume Exit_Handler

End Function

Public Function MergeWord(strDocName As String, strDataDir As String)

On Error GoTo Err_Handler
'Last mod date 15/06/2011
'tested
   Dim wordApp       As Object            ' running instance of word
   Dim WordDoc       As Object            ' one instance of a word doc
   Dim strActiveDoc  As String            ' doc name (no path)
   Dim lngWordDest   As Long              ' const for dest, 0 = new doc, 1 = printer

   On Error GoTo CreateWordApp
   Set wordApp = GetObject(, "Word.Application")
   On Error Resume Next


   Set WordDoc = wordApp.Documents.Open(strDocName)


   strActiveDoc = wordApp.ActiveDocument.Name

   WordDoc.MailMerge.OpenDataSource _
        Name:=strDataDir & TextMerge, _
        ConfirmConversions:=False, _
        ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
        PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
        WritePasswordTemplate:="", Revert:=False, Format:=0, _
        Connection:="", SQLStatement:="", SQLStatement1:=""




   With WordDoc.MailMerge
      .Destination = 0        ' 0 = new doc
      .MailAsAttachment = False
      .MailAddressFieldName = ""
      .MailSubject = ""
      .SuppressBlankLines = True
      With .DataSource
         .FirstRecord = 1
'            .LastRecord = 1
      End With
      .Execute Pause:=True
   End With
   WordDoc.Close (False)

   wordApp.Visible = True
   wordApp.Windows(wordApp.Windows.count).Activate



   AppActivate "Microsoft Word"
   wordApp.Activate
   wordApp.WindowState = 0  'wdWindowStateRestore

   Set wordApp = Nothing
   Set WordDoc = Nothing

    DoEvents

'   If bolShowMerge = True Then
'      wordApp.Dialogs(676).Show       'wdDialogMailMerge
'   End If

   Exit Function

CreateWordApp:
   ' this code is here to use the EXISTING copy of
   ' ms-word running. If getobject fails, then
   ' ms-word was NOT running. The below will then
   ' launch word
   Set wordApp = CreateObject("Word.Application")
   Resume Next

Exit_Handler:
    On Error Resume Next
    Set wordApp = Nothing
    Exit Function
Err_Handler:
    Debug.Print Err.Number, Err.Description, "MergeWord", Now
    Resume Exit_Handler

End Function


Public Function MakeMergeText(frmF As Form, strOutFile As String) As Boolean
   ' build our merge file, and write a simple "csv" file to disk
On Error GoTo Err_Handler
'Last mod date 15/06/2011
'tested

   Dim OneField As DAO.Field
   Dim strFields As String
   Dim strData As String
   Dim intFile As Integer

   If frmF.RecordsetClone.Fields.count > 0 Then
      For Each OneField In frmF.RecordsetClone.Fields

         If strFields <> "" Then strFields = strFields & ","
         strFields = strFields & qu(OneField.Name)

         If strData <> "" Then strData = strData & ","
         strData = strData & qu(frmF(OneField.Name))

      Next OneField
   End If

   'delete the out file if there
   On Error Resume Next
    Kill strOutFile

   ' now open file...

   On Error GoTo exit1
   intFile = FreeFile()
   Open strOutFile For Output As intFile
   Print #intFile, strFields
   Print #intFile, strData
   Close intFile

   MakeMergeText = True
   Exit Function

exit1:

   MsgBox "Can't make merge file in directory called word" & vbCrLf & _
          "The Word template may already be in use. Try closing word first." & vbCrLf & vbCrLf & _
          "Make sure a directory called Word exists" & vbCrLf & _
          "path name was " & strOutFile & vbCrLf & vbCrLf & _
          "Please create a word directory, exit word and try again", vbCritical, "no word directory, or in already in use"

   MakeMergeText = False


Exit_Handler:
    Exit Function
Err_Handler:
    Debug.Print Err.Number, Err.Description, "MakeMergeText", Now
    Resume Exit_Handler

End Function


Public Function strDCount(mytext As String, delim As String) As Integer
   ' This routine simply returnds a count of a particular delim string.
   ' Note that delim can be more then one char, and thus we can use
   ' this for line couting in memo fields

On Error GoTo Err_Handler
'Last mod date 15/06/2011
'tested
   Dim intPtr     As Integer
   Dim intFound   As Integer
   Dim delimLen   As Integer

   delimLen = Len(delim)

   intPtr = InStr(mytext, delim)

   Do While intPtr
      intFound = intFound + 1
      intPtr = intPtr + delimLen
      intPtr = InStr(intPtr, mytext, delim)
   Loop

   strDCount = intFound


Exit_Handler:
    Exit Function
Err_Handler:
    Debug.Print Err.Number, Err.Description, "strDCount", Now
    Resume Exit_Handler

End Function

Public Function strDField(mytext As String, delim As String, groupnum As Integer) As String
   ' Returnds a group extract from a string via a delimter.
   ' Hence to grab "cat" from the string dog-cat  you get:
   ' strDField("dog-cat","-",2)
On Error GoTo Err_Handler
'Last mod date 15/06/2011
'tested
   Dim startpos As Integer
   Dim endpos As Integer
   Dim groupptr As Integer
   Dim chptr As Integer

   chptr = 1
   startpos = 0
    For groupptr = 1 To groupnum - 1
       chptr = InStr(chptr, mytext, delim)
       If chptr = 0 Then
          strDField = ""
          Exit Function
       Else
          chptr = chptr + 1
       End If
    Next groupptr
   startpos = chptr
   endpos = InStr(startpos + 1, mytext, delim)
   If endpos = 0 Then
      endpos = Len(mytext) + 1
   End If

   strDField = Mid$(mytext, startpos, endpos - startpos)

Exit_Handler:
    Exit Function
Err_Handler:
    Debug.Print Err.Number, Err.Description, "strDField", Now
    Resume Exit_Handler

End Function

Public Function strDSort(mytext As String, delim As String) As String
   ' This routine simply sorts a delimited string and retruns the result.
   ' This is NOT a high speed sort, but for listboxes etc that only have
   ' 100 or less elements, the sort delay time is not noticeable on a
   ' moderm pc today. This routine assumes non blank values
On Error GoTo Err_Handler
'Last mod date 15/06/2011
'tested

   Dim intCount As Integer
   Dim i As Integer
   Dim SortBuf() As String
   Dim strOne As String
   Dim j As Integer
   Dim iPoint As Integer

   intCount = strDCount(mytext, delim)
   If intCount = 0 Then
      strDSort = mytext
      Exit Function
   End If

   intCount = intCount + 1       ' One delinter actually means two values  abc;def is two values!

   ReDim SortBuf(intCount)       ' our results are sorted into this array.

   For i = 1 To intCount
      strOne = strDField(mytext, delim, i)
      GoSub InsertOne
   Next i

   ' now convert results back to a string

   For i = 1 To intCount
     If strDSort <> "" Then
        strDSort = strDSort & delim
     End If
     strDSort = strDSort & SortBuf(i)
   Next i

   Exit Function


InsertOne:
   ' find place to insert
   For j = 1 To intCount
      If (strOne <= SortBuf(j)) Or (SortBuf(j) = "") Then
         iPoint = j
         Exit For
      End If
   Next j

   ' make a hole for the value by moving everthing down
   For j = intCount To iPoint + 1 Step -1
      SortBuf(j) = SortBuf(j - 1)
   Next j
   SortBuf(iPoint) = strOne
   Return

Exit_Handler:
    Exit Function
Err_Handler:
    Debug.Print Err.Number, Err.Description, "strDSort", Now
    Resume Exit_Handler

End Function