Export an Access query or table directly to PowerPoint

This function exports an Access query or table to Powerpoint. Note that you will have to set the appropriate Powerpoint reference in your VBA References. The function uses automation to create a new PowerPoint presentation, and exports the query as a number of tables on an equal number of slides. The column names are taken as the headers for the table, and the last table's number of rows will be automatically adjusted to hold the exact amount of rows available in the query.

Sub Query2PowerPoint(qry As String, Optional rowsPerPage As Integer = 10, Optional Title As String = "")
    On Error GoTo Query2PowerPoint_Err
    
    Dim pptSlide As Slide
    Dim pptShape As shape
    Dim pptPres As PowerPoint.Presentation
    Dim iRow As Integer
    Dim iColumn As Integer
    Dim oShapeInsideTable As shape
    Dim pptObj As PowerPoint.Application
    Dim rs As Recordset
    Dim nrRows As Integer
    
    Set db = CurrentDb
    Set qdf = db.QueryDefs(qry)
    For Each prm In qdf.Parameters
        prm.value = Eval(prm.Name)
    Next
    Set rs = qdf.OpenRecordset(dbOpenSnapshot)
    
    If rs.RecordCount = 0 Then
        MsgBox "No records available."
        Exit Sub
    End If
    
    DoCmd.Hourglass (True)
    columnsPerPage = rs.Fields.Count
    
    Set pptObj = New PowerPoint.Application
    Set pptPres = pptObj.Presentations.Add
    
    
    'pptObj.Visible = True
    
    iRow = 0
    While Not rs.EOF
        If iRow Mod rowsPerPage = 0 Then
            With pptPres
                'Set pptSlide = .Slides.Add(.Slides.Count + 1, ppLayoutBlank)
                Set pptSlide = .Slides.Add(.Slides.Count + 1, ppLayoutTitleOnly)
            End With
            With pptSlide.Shapes
                .Title.TextFrame.TextRange.Text = Title
                nrRows = Min(rs.RecordCount - rs.AbsolutePosition, rowsPerPage)
                Set pptShape = .AddTable(NumRows:=nrRows + 1, _
                                 NumColumns:=columnsPerPage, _
                                 Left:=30, _
                                 Top:=120, _
                                 Width:=660, _
                                 Height:=1)
            End With
            
            fieldNo = 0
            For Each fld In rs.Fields
                With pptShape.table.Cell((iRow Mod rowsPerPage) + 1, fieldNo + 1).shape.TextFrame.TextRange
                    .Text = fld.Name
                    With .Font
                        .Name = "Arial"
                        .Bold = True
                        .Size = "12"
                        .Color = vbWhite
                    End With
                    
                End With
                With pptShape.table.Cell((iRow Mod rowsPerPage) + 1, fieldNo + 1).shape
                    ' fill parameters
                    .Fill.Visible = msoTrue
                    .Fill.Solid
                    .Fill.ForeColor.RGB = RGB(0, 99, 195)
                    .Fill.Transparency = 0#
                End With
                fieldNo = fieldNo + 1
            Next fld
            
        End If
        
        With pptShape.table
              For iColumn = 1 To .Columns.Count
                   With .Cell((iRow Mod rowsPerPage) + 2, iColumn).shape.TextFrame.TextRange
                       .Text = Nz(rs.Fields(iColumn - 1), " ")
                      With .Font
                         .Name = "Arial"
                         .Size = "8"
                     End With
                 End With
             Next iColumn
        End With
        
        rs.MoveNext
        iRow = iRow + 1
    Wend

    pptObj.Visible = True
    
Query2PowerPoint_Exit:
    DoCmd.Hourglass (False)
    Exit Sub

Query2PowerPoint_Err:
    DoCmd.Hourglass (False)
    MsgBox Err.Description
    Resume Query2PowerPoint_Exit
    
End Sub

Permalink