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
No comments:
Post a Comment