Use VBA and Access Tables to Dynamically Populate a Publisher Template

I have a Publisher document that I need to send to a list of clients with information about their work comp rates for the upcoming year. The clients are categorized into several different types depending on a variety of factors which I won't get into here. A standard mail merge won't work because of the complexity of the process and the logic involved. I've omitted the business logic that organizes the clients and work comp rates into various categories.

The code creates a Publisher object, opens a pre-formatted Publisher document/template, iterates through an Access table and populates a table within Publisher from the Access data. A table with just the header already exists in the Publisher template. The code adds table rows and has to format the added rows so they are different from the header.

Once the document is complete, the code converts the Publisher doc to a PDF and closes Publisher without saving. A new document is created for each client in the table. Setting the "savechanges" parameter of the Publisher Open function to "pbDoNotSaveChanges" is critical, because it allows the Publisher template to be reused ad infinitum. Properly closing/cleaning up the Publisher doc and App is also critical. If your code does not properly open, save, and close the Publisher document, you will get all kinds of warnings and prompts from Publisher as the program runs.

The Optional parameter in the buildRatePage() function allowed me to test the function with a single client rather than waiting for an entire batch to run.

The first function below is called when a button is clicked. It calls the buildRatePage() function that does the actual work of building the work comp rate letters. A custom replaceText() function is called to find and replace text in the Publisher template which I've set up to look like merge fields in Word.

The key steps for working with Publisher in VBA are outlined below: 

1) Set a reference to the Microsoft Publisher Object Library in the VBA editor.

2) Set up the variables:
    Dim pubApp As Publisher.Application
    Dim pubDoc As Publisher.Document

3) Instantiate the variables:    
    Set pubApp = CreateObject("Publisher.Application")
    Set pubDoc = pubApp.Open(FileName:=curPath & "\Templates\" & templateName, ReadOnly:=False, addtorecentfiles:=False, savechanges:=pbDoNotSaveChanges)

4) Add, format and populate rows in a pre-existing table in Publisher:    
    Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
    rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
    rowNew.Cells(1).TextRange.Font.Size = 9
    rowNew.Cells(1).TextRange.Text = someValue

5) Save the Publisher document as a PDF:    
    pubDoc.ExportAsFixedFormat pbFixedFormatTypePDF, docPathAndName, pbIntentStandard, False

6) Clean up:
    pubDoc.Close
    pubApp.Quit
    Set pubApp = Nothing

Read on if you would like to see the details of how the program works:

'------------------------------------------------------
Private Sub cmdCreateRPLetters_Click()

    Me.lblLetterProc.Visible = True
    Me.Repaint

    Dim curPath As String
    curPath = CurrentProject.Path
 
    DoCmd.SetWarnings False
    On Error Resume Next
        Kill curPath & "\Letters\*.pdf"
    On Error GoTo 0
 
' Testing
'    Call buildRatePage("UtahOnly", "NoMod", "InsuredNoModTemplate.pub", "12-1315")
'    Call buildRatePage("UtahOnly", "Mod", "InsuredModTemplate.pub", "13-1623")
'    Call buildRatePage("MultiState", "Mod", "InsuredModTemplate.pub", "13-1540")
'    Call buildRatePage("MultiState", "NoMod", "InsuredNoModTemplate.pub", "13-2291")
 
    Call buildRatePage("UtahOnly", "NoMod", "InsuredNoModTemplate.pub")
    Call buildRatePage("UtahOnly", "Mod", "InsuredModTemplate.pub")
    Call buildRatePage("MultiState", "Mod", "InsuredModTemplate.pub")
    Call buildRatePage("MultiState", "NoMod", "InsuredNoModTemplate.pub")
    Call buildRatePage("MultiClient", "Mod", "InsuredModTemplate.pub")
    Call buildRatePage("MultiClient", "NoMod", "InsuredNoModTemplate.pub")
    Call buildRatePage("Idaho", "NoMod", "InsuredNoModTemplate.pub")
    Call buildRatePage("Idaho", "Mod", "InsuredNoModTemplate.pub")

    Me.lblLetterProc.Visible = False
    Me.Repaint
 
    MsgBox "Letters created. The Letters folder will be cleared the next time this program runs. Please save any letters" _
        & " you want to keep to a new location."
 
End Sub

'-----------------------------------------------------
Private Sub buildRatePage(clientType As String, modType As String, templateName As String, Optional parentID As String)

    Dim sql As String
    Dim db As DAO.Database
    Set db = CurrentDb
    Dim rs As DAO.Recordset
    Dim rs2 As DAO.Recordset
    DoCmd.SetWarnings False


    Dim pubApp As Publisher.Application
    Dim pubDoc As Publisher.Document
    Dim curPath As String
    curPath = CurrentProject.Path
    If Nz(parentID, "") <> "" Then
        pID = " and parent_id = '" & parentID & "'"
    Else
        pID = ""
    End If
 

    sql = "SELECT DISTINCT parent_id, insured_name, type, mod_type FROM Rate_Page_Letters WHERE type = '" & clientType & "' and mod_type = '" & modType & "'" & pID
    Set rs = db.OpenRecordset(sql)

    Do While Not rs.EOF
 
        If modType = "Mod" Then
            sql = "SELECT DISTINCT * FROM Rate_Page_Letters WHERE parent_id = '" & rs!parent_id & "' and type = '" _
            & rs!Type & "' and mod_type = '" & rs!mod_type & "' and mod2 <> 1"
        Else
            sql = "SELECT DISTINCT * FROM Rate_Page_Letters WHERE parent_id = '" & rs!parent_id & "' and type = '" & rs!Type & "' and mod_type = '" & rs!mod_type & "'"
        End If

        Set rs2 = db.OpenRecordset(sql)
     
        Set pubApp = CreateObject("Publisher.Application")
        Set pubDoc = pubApp.Open(FileName:=curPath & "\Templates\" & templateName, ReadOnly:=False, addtorecentfiles:=False, savechanges:=pbDoNotSaveChanges)

        Do While Not rs2.EOF

            Call replaceText("<<InsuredName>>", rs2!insured_name, pubDoc)
            Call replaceText("<<PolicyNumber1>>", polNum, pubDoc)

            ' Populate the Publisher document
            If templateName = "InsuredModTemplate.pub" Then
                Call replaceText("<<Emod>>", rs2!mod2, pubDoc)
                Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
                rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
                rowNew.Cells(1).TextRange.Font.Size = 9
                rowNew.Cells(1).TextRange.Text = rs2!comp_code
                rowNew.Cells(2).TextRange.Font.Name = "Montserrat"
                rowNew.Cells(2).TextRange.Font.Size = 9
                rowNew.Cells(2).TextRange.Text = rs2!code_desc
                rowNew.Cells(3).TextRange.Font.Name = "Montserrat"
                rowNew.Cells(3).TextRange.Font.Size = 9
                rowNew.Cells(3).TextRange.Text = rs2!cur_yr_final_rate
                rowNew.Cells(4).TextRange.Font.Name = "Montserrat"
                rowNew.Cells(4).TextRange.Font.Size = 9
                rowNew.Cells(4).TextRange.Text = rs2!cur_yr_mod_rate
            Else
                Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
                rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
                rowNew.Cells(1).TextRange.Font.Size = 9
                rowNew.Cells(1).TextRange.Text = rs2!comp_code
                rowNew.Cells(2).TextRange.Font.Name = "Montserrat"
                rowNew.Cells(2).TextRange.Font.Size = 9
                rowNew.Cells(2).TextRange.Text = rs2!code_desc
                rowNew.Cells(3).TextRange.Font.Name = "Montserrat"
                rowNew.Cells(3).TextRange.Font.Size = 9
                rowNew.Cells(3).TextRange.Text = rs2!cur_yr_final_rate
            End If
         
            rs2.MoveNext
        Loop
     
        'Terrorism insurance rows at the end of the table
        Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
        rowNew.Cells(1).Merge MergeTo:=rowNew.Cells(2)
        rowNew.Cells(2).TextRange.Font.Name = "Montserrat"
        rowNew.Cells(2).TextRange.Font.Size = 7
        rowNew.Cells(2).TextRange.Text = "Terrorism Risk Insurance Act of 2002:"
        rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
        rowNew.Cells(1).TextRange.Font.Size = 7
        rowNew.Cells(1).TextRange.Text = ".01%"
     
        Set rowNew = pubDoc.Pages(1).Shapes(1).Table.Rows.Add
        rowNew.Cells(1).TextRange.Font.Name = "Montserrat"
        rowNew.Cells(1).TextRange.Font.Size = 7
        rowNew.Cells(1).TextRange.Text = "Domestic Terrorism, Earthquakes, and Catastrophic Industrial Accidents: "
        rowNew.Cells(2).TextRange.Font.Name = "Montserrat"
        rowNew.Cells(2).TextRange.Font.Size = 7
        rowNew.Cells(2).TextRange.Text = ".01%"

        rs2.Close
     
        'Save as PDF
        docName = curPath & "\Letters\" & clientType & "_" & modType & "-" & replace(cleantext(rs!insured_name), "/", "") & ".pdf"
        pubDoc.ExportAsFixedFormat pbFixedFormatTypePDF, docName, pbIntentStandard, False

        pubDoc.Close
        pubApp.Quit
        Set pubApp = Nothing
     
        rs.MoveNext
    Loop
    rs.Close
 
End Sub

'-----------------------------------------------
Private Sub replaceText(match As String, replace As String, ByRef pubDoc As Publisher.Document)
    With pubDoc.Find
    .Clear
    .FindText = match
    .ReplaceWithText = replace
    .ReplaceScope = pbReplaceScopeOne
    .Execute
    End With
End Sub




Auto-populate a text box using a query

I have a small data warehouse I've built in MS Access 2016. I load new data in the warehouse every month, and I want to dynamically show users of the data warehouse the date range available for reports.

I created a label that says the following: "*Data loaded for January 1, 2016 through the end of".

Next, I created a textbox named txtMaxDate. I gave the textbox a transparent border and a font that matches the label above. I placed the textbox right after the label.

In the onLoad event of the form, I wrote the following code:

Private Sub Form_Load()
    Dim sql As String
    Dim rs As DAO.Recordset
    Dim db As DAO.Database
    Dim maxLoadDate As Date
    Dim theYear As String
    Dim theMonth As String
    Set db = CurrentDb
    sql = "SELECT MAX(PayYearMonth) as MaxDate FROM tblPaySummary"
    Set rs = db.OpenRecordset(sql)

    rs.MoveFirst
    maxLoadDate = rs!MaxDate
   
    theYear = year(maxLoadDate)
    theMonth = MonthName(month(maxLoadDate))
    Me.txtMaxDate.Value = theMonth & " " & theYear
End Sub

The code gets the most recent date from the database and displays the date in the text box.

VBA Function to Remove Non-Alphanumeric Characters

Occasionally, you'll run into data that has been entered with inadvertent carriage returns or other non-alphanumeric characters. Sometimes, these invisible characters can cause mysterious errors in your code. The solution is to use a function to remove any superfluous characters from the data.

The following function removes everything except for the characters indicated between the brackets. You can tweak the accepted character set as needed. The function works by looping through each character in the string and testing each character to see if it matches one of the characters listed between the square brackets.

Function cleanText(strText As String) As String

    Dim valid as String
    Dim test As String
    valid = ""
    test = ""

    For i = 1 To Len(strText)
        test = Mid(strText, i, 1)
        'Only allow characters and spaces, not carriage returns or any other code
        If test Like "[A-Z,a-z,0-9, ,.,/,~,@,#,$,%,^,&,*,(,),_,-,+,= ]" Then
            valid = valid & test
        End If
    Next i
 
    'Return the valid characters
    cleanText = valid

End Function

The cleanText function uses the Visual Basic (VBA) "Like" operator. The Like operator is similar to using Regular Expressions and also has some similarities to the SQL Like operator. You can read more about the VBA Like operator on this page.

VBA Regular Expression Phone Number Validator

This phone number validator validates numbers with or without dashes and with or without dots between the segments.


Public Function validatePhoneNo(phoneno As String) As Boolean

    If phoneno <> "" Then
        Dim re As RegExp
        Dim matches As MatchCollection
        Set re = New RegExp
        re.IgnoreCase = True
        re.Global = True
        re.Pattern = "^\(?\d{3}-?\.?\)?\s?\d{3}-?\.?\d{4}$"
        Set matches = re.Execute(phoneno)
        If matches.Count <> 1 Then
            validatePhoneNo = False
            Exit Function
        End If
    Else
        validatePhoneNo = False
        Exit Function
    End If
 
    validatePhoneNo = True
 
End Function

Use VBA to Automatically Set Dates in Form Fields

In this case, I have a report that requires a Begin Date and an End Date.

To make things easier for the user, I pre-fill the date fields with the date range most commonly used in the report. I use the Form_Load() event to automatically set the dates in the form fields.

Private Sub Form_Load()
    Me.txtBegDt.Value = "1/1/" & Year(Date)
    Me.txtEndDt.Value = Date
End Sub


The first line sets the Begin Date (txtBegDt) field to January 1 of the current year. The second line sets the End Date (txtEndDt) to the current date. Easy as that!

Shortcut to Open the VBA Editor

Using keyboard shortcuts saves a lot of time for things you do frequently. I use this shortcut every time I need to open the VBA editor in an Office Program:

Alt + F11

That's it. Practice using this shortcut a few times until it becomes second nature.

Use Query Definitions to Create Dynamic Queries and Reports

The Begin and End dates in this query come from text boxes formatted as dates. The client list comes from a multi-select list box. The "qClaims" query is associated with the Claims Report. The query definition is fed a dynamic SQL statement built from the values selected by the user. The query definition makes it easy to generate a report from a dynamic query.

  

 If Nz(Me.txtBegDt.Value, "") = "" Then

        MsgBox "Please select a begin date."

        Exit Sub

    End If

    If Nz(Me.txtEndDt.Value, "") = "" Then

        MsgBox "Please select an end date."

        Exit Sub

    End If

    

    DoCmd.Close acQuery, "qClaims", acSaveNo

    DoCmd.Close acReport, "Claims Report"

    

    Dim strList as String
    Dim strsql As String

    Dim qdf As DAO.QueryDef

    Set db = CurrentDb

    

    Set qdf = db.QueryDefs("qClaims")

    

    strList = ""

    

    If Me.lstClients.ItemsSelected.Count > 0 Then

        For Each client In Me.lstClients.ItemsSelected

            strList = strList & "'" & Me.lstClients.ItemData(client) & "',"

        Next client

        strList = CStr(Trim(Left(strList, Len(strList) - 1)))   ' Remove trailing comma

        strList = " AND i.client_id IN (" & strList & ")"

    Else

        strList = ""

    End If

    strsql = "SELECT i.client_id, i.client_name, i.fname, i.lname, i.ssn," _
    & " i.sep_reason, c.charge_qu, c.charge_yr, c.charge_amount" _

    & " FROM tCharges c RIGHT JOIN tSeparation_Info i ON c.sep_ID = i.id" _

    & " WHERE i.mail_date BETWEEN #" & [Forms]![Claims Report]![txtBegDt] _

    & "# And #" & [Forms]![Claims Report]![txtEndDt] & "# " & strList _

    & " ORDER BY i.client_name"

            

    qdf.sql = strsql   ' Set the sql of the query definition

    

    DoCmd.OpenReport "Claims Report", acViewReport

    

    Set db = Nothing

    Set qdf = Nothing