Mail Merge from Table Saving each record to Word and PDF

[JimLes]

I have a code that is working where I can select multiple employees from a list box to create a table and then mail merge the data to a word document.

Here is my current code:

Dim currentDbName As String
Dim strList As String
Dim ObjWord As Word.Document
DoCmd.SetWarnings False
strList = Forms![frmSeverance]![SeveranceTest]
Dim MyDB As DAO.Database
Dim qdef As DAO.QueryDef
Dim i As Integer
Dim strSQL As String
Dim strWhere As String
Dim strIN As String
Dim flgSelectAll As Boolean
Dim varItem As Variant
Set MyDB = CurrentDb()


'If no items selected in listbox, exit sub
    If Me.LetList.ItemsSelected.Count = 0 Then
       MsgBox "You must make a selection(s) from the list", , "Selection Required !"
      Exit Sub
    End If
    
    'select all employees from query
    strSQL = "SELECT * FROM qrySeveranceLetters"
    
           
    'Build the IN string by looping through the listbox
    For i = 0 To LetList.ListCount - 1
        If LetList.Selected(i) Then
            If LetList.Column(0, i) = "All" Then
                flgSelectAll = True
            End If
            strIN = strIN & "'" & LetList.Column(0, i) & "',"
        End If
    Next i
    
    'Create the WHERE string, and strip off the last comma of the IN string
    strWhere = " WHERE [EID] in " & _
               "(" & Left(strIN, Len(strIN) - 1) & ")"

    'If "All" was selected in the listbox, don't add the WHERE condition
    If Not flgSelectAll Then
        strSQL = strSQL & strWhere
    End If

    MyDB.QueryDefs.Delete "qrySeveranceLetters2"
    Set qdef = MyDB.CreateQueryDef("qrySeveranceLetters2", strSQL)
    DoCmd.OpenQuery "qrySeveranceLetters3"
    
      If strList = "Severance Test" Then
        Set ObjWord = GetObject("\\C\Severance.docx", "Word.Document")
        ObjWord.Application.Visible = True
        ObjWord.MailMerge.OpenDataSource _
        Name:=currentDbName, LinkToSource:=True, Connection:="DSN=MS Access Database;" & "DBQ=" & CurrentDb.Name & ";", _
        SQLStatement:="SELECT * FROM [tblSeveranceLetters]"
        ObjWord.MailMerge.Execute
        ObjWord.Close SaveChanges:=False

I would like to incorporate this code for MS Word that I found into mine so I can export each mail merge record to a PDF and WORD document. Here is the code I would like to incorporate but don't know how. Any assistance is greatly appreciated.

Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
  StrFolder = .Path & Application.PathSeparator
  For i = 1 To .MailMerge.DataSource.RecordCount
    With .MailMerge
      .Destination = wdSendToNewDocument
      .SuppressBlankLines = True
      With .DataSource
        .FirstRecord = i
        .LastRecord = i
        .ActiveRecord = i
        If Trim(.DataFields("Last_Name")) = "" Then Exit For
        'StrFolder = .DataFields("Folder") & Application.PathSeparator
        StrName = .DataFields("First_Name") & "_" & .DataFields("Last_Name")
      End With
      .Execute Pause:=False
    End With
      For j = 1 To Len(StrNoChr)
        StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
      Next
    StrName = Trim(StrName)
    With ActiveDocument
      .SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
      ' and/or:
      .SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  Next i
End With
Application.ScreenUpdating = True

 

[JimLes]

I have this saving each record in tblSeveranceLetters to a word doc using Last Name but it only runs once. I get an error message that the database has been placed in a state by user Admin that prevents it from being opened or locked. Any ideas what I am doing wrong?

Private Sub Severance_DblClick(Cancel As Integer)
Dim currentDbName As String
Dim strList As String
Dim ObjWord As Word.Document
DoCmd.SetWarnings False
strList = Forms![frmSeverance]![TestList]

If strList = "Severance Test" Then
Set ObjWord = GetObject("\\C\Severance.docx", "Word.Document")
ObjWord.Application.Visible = True
ObjWord.MailMerge.OpenDataSource _
Name:=currentDbName, LinkToSource:=True, Connection:="DSN=MS Access Database;" & "DBQ=" & CurrentDb.Name & ";", _
SQLStatement:="SELECT * FROM [tblSeveranceLetters]"

Dim rec, LastRecord As Integer
Dim docNameField, strDocName, savePath As String
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdLastRecord
LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
        If MsgBox(LastRecord & " documents will be created based on your Mail Merge template.", vbOKCancel) = vbOK Then
            savePath = "C:\completed\"
            docNameField = ("Last_Name")
        For rec = ActiveDocument.MailMerge.DataSource.FirstRecord To LastRecord
            ActiveDocument.MailMerge.DataSource.ActiveRecord = rec
            strDocName = ActiveDocument.MailMerge.DataSource.DataFields(docNameField).Value & ".docx"
        With ActiveDocument.MailMerge
            .Destination = wdSendToNewDocument
            .Execute
        End With
            ActiveDocument.SaveAs Filename:=savePath & strDocName
            ActiveDocument.Close False
            ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
        Next rec
        Else
        Exit Sub
        End If
                        
        ObjWord.Close SaveChanges:=False
        DoCmd.SetWarnings True

 

[sxschech]

I haven't done mailmerge so not sure if there are other issues related to that.

Here is a snippet of code that I use at the point where it saves the word doc and then exports as PDF. It looks similar to what you have.

 'Due to fake readonly issue, save as then reopen
'in order to be able to print to pdf
    stPDFName = sSavePath & InsertText & " " & stExtractTitle & ".docx"
    worddoc.SaveAs stPDFName
    worddoc.Close False

    Set worddoc = WordApp.Documents.Open(stPDFName)
    'Print the document as a PDF    
    worddoc.ExportAsFixedFormat Replace(stPDFName, ".docx", ".pdf"), 17