Connect to SQL Server with VBA for Pass Through Queries

I recently built a program that connects to a remote SQL Server database. I discovered that the cursor type makes a huge difference in how fast the program runs. Initially, I used the adOpenStatic cursor. In some cases, the program took over 30 seconds to run seven simple queries and to render the results to some text boxes on an Access form. I changed the cursor type to adOpenForwardOnly, and the program took less than a second to run from then on. I have a "cleantext" function that scrubs the value entered by the user before it is used in the queries. Below is a simplified version of the code:

 Dim cnx As ADODB.Connection
Set cnx = New ADODB.Connection
Dim serverName As String
Dim databaseName As String
Dim userId As String
Dim pwd As String
Dim strSQL as string
     
' DATABASE CONNECTION
serverName = "TheServerName"
databaseName = "TheDatabaseName"
userId = "TheUserId"
pwd = "ThePassword"
Set cnx = New ADODB.Connection
cnx.Open "Driver={SQL Server};Server=" & serverName & ";Database=" & databaseName & ";Uid=" & userId & ";Pwd=" & pwd & ";"
    
Dim rsADO As ADODB.Recordset
Set rsADO = New ADODB.Recordset

strSQL="SELECT a.field1, a.field2, a.field3" & _
 " FROM someTable a" & _
 " WHERE a.field1 = '" & cleantext(me.txtId.value) & "'"

rsADO.Open strSQL, cnx, adOpenForwardOnly
Do While Not rsADO.EOF
  strDisplay = strDisplay & rsADO!field2 & " | " & rsADO!field3 &     vbCrLf
rsADO.MoveNext
Loop
rsADO.Close

' Display the values in a scrollable text box
Me.txtHDHPosJobCodes.Value = strDisplay 
strDisplay = ""

'CLOSE THE REMOTE DATABASE CONNECTION
Set rsADO = Nothing
cnx.Close
Set cnx = Nothing

Save an Excel file as a PDF using VBA

In this example, I'm opening an Excel workbook from another Office program (such as Access) and saving the workbook as a PDF:

    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlWS As Excel.Worksheet        

    Set xlApp = CreateObject("Excel.Application")
    Set xlWB = xlApp.Workbooks.Open("template.xlsx", , False)
    Set xlWS = xlWB.Sheets(1)
    xlWS.Activate          

    With xlWS
        filePathAndName = curPath & "\Reports\ReportName.pdf"
             
        .PageSetup.FitToPagesTall = 1
        .PageSetup.FitToPagesWide = 1

        .ExportAsFixedFormat _
        Type:=xlTypePDF, _
        FileName:=filePathAndName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    End With

    xlWB.Close
    Set xlWB = Nothing
    Set xlWS = Nothing
    xlApp.Quit
    Set xlApp = Nothing

Format cell borders in Excel using VBA

This example creates a header row with a heavy, black border and a light blue background.

        With xlWS.Range("A1:A100")
            .Interior.Color = RGB(194, 220, 255)
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeRight).Weight = xlThick
            .Borders(xlEdgeRight).Color = RGB(255, 255, 255)
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlThick
            .Borders(xlEdgeLeft).Color = RGB(255, 255, 255)
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeTop).Weight = xlThick
            .Borders(xlEdgeRight).Color = RGB(255, 255, 255)
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).Weight = xlThick
            .Borders(xlEdgeBottom).Color = RGB(255, 255, 255)
        End With

Format cell text in Excel using VBA

    Dim wsName As String
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlWS As Excel.Worksheet        

    Set xlApp = CreateObject("Excel.Application")
    Set xlWB = xlApp.Workbooks.Open(curPath & "\Template\template.xlsx", , False)
    Set xlWS = xlWB.Sheets(1)
    xlWS.Activate        

    With xlWS.Cells(row, col)
        .Font.Name = "Cambria"
        .Font.Bold = True
        .Font.Size = 14
        .Value = "Total Compensation Statement"
        .VerticalAlignment = xlVAlignTop
        .HorizontalAlignment = xlCenterAcrossSelection
    End With

Use VBA to create a chart in Excel

    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlWS As Excel.Worksheet

    Set xlWS = xlWB.Sheets(1)
    xlWB.Sheets("Sheet1").Activate

    Dim chartObj As ChartObject
    Set chartObj = xlWS.ChartObjects.Add _
        (Left:=242, Width:=245, Top:=260, Height:=240)
    chartObj.Chart.SetSourceData Source:=xlWB.Sheets("Sheet2").Range("A1:C2")
    chartObj.Chart.ChartType = xl3DPie
    chartObj.Chart.Elevation = 45
    chartObj.Chart.ChartArea.Border.LineStyle = xlDash
    chartObj.Chart.ChartArea.Border.LineStyle = xlNone

    chartObj.Chart.SeriesCollection(1).ApplyDataLabels
    chartObj.Chart.SeriesCollection(1).DataLabels.ShowPercentage = True
    chartObj.Chart.SeriesCollection(1).DataLabels.ShowValue = False
    chartObj.Chart.SeriesCollection(1).DataLabels.ShowCategoryName = True
    chartObj.Chart.SeriesCollection(1).DataLabels.Font.Size = 8
    chartObj.Chart.SeriesCollection(1).DataLabels.Font.Name = "Cambria"
    chartObj.Chart.SeriesCollection(1).DataLabels.Font.Bold = False
    chartObj.Chart.SeriesCollection(1).DataLabels.ShowLegendKey = -1
    chartObj.Chart.SeriesCollection(1).DataLabels.Position = xlLabelPositionBestFit
    chartObj.Chart.SetElement (msoElementLegendNone)

    xlWB.SaveAs (curPath & "\Reports\ReportName.xlsx")

    xlWB.Close
    Set xlWB = Nothing
    Set xlApp = Nothing

Use VBA to work with Microsoft Publisher

First, set a reference to the Microsoft Publisher Object Library in the VBA editor.

Create Publisher object variables:
    Dim pubApp As Publisher.Application
    Dim pubDoc As Publisher.Document

Open a Publisher document to use as a template:    
    Set pubApp = CreateObject("Publisher.Application")
    Set pubDoc = pubApp.Open(FileName:=curPath & "\Templates\" _
    & templateName, ReadOnly:=False, addtorecentfiles:=False, _
    savechanges:=pbDoNotSaveChanges)

Find and replace text in Publisher:

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

Call replaceText("<<Street>>", theStreet, pubDoc)

Add a table to a Publisher document:
pubDoc.Pages(1).Shapes.AddTable(NumRows:=5, _ NumColumns:=5, Left:=72, Top:=300, Width:=400, Height:=100) .Table.Columns(3).Cells(3).Fill.ForeColor.RGB = RGB _ (Red:=255, Green:=0, Blue:=0)

Add, format and populate rows in a Publisher table:    
Dim rowNew as Row
    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

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

Clean up Publisher objects:
    pubDoc.Close
    pubApp.Quit
    Set pubApp = Nothing

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