Dim db As DAO.Database
Dim rs As DAO.Recordset[green]
'Dim Fields As DAO.Field[/green]
Dim ppObj As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim iFound As Integer
Dim cl As Cell
Dim rw As Row
Dim r As Integer
Dim c As Integer
Dim lLastProject As Long
lLastProject = 0[green]
'On Error GoTo err_cmdOLEPowerPoint
' Open up a recordset on the Employees table.[/green]
Set db = CurrentDb
Set rs = db.OpenRecordset("query11", dbOpenDynaset)[green]
'quProjectsInProgress: ClName-0 ProjectID-1 Department-2 CrewLead-3 PcentComplete-4
' Open up an instance of Powerpoint.[/green]
Set ppObj = New PowerPoint.Application
Set ppPres = ppObj.Presentations.Add
rs.MoveLast
iFound = rs.RecordCount
r = 2
rs.MoveFirst[green]
'Setup the set of slides and populate them with data from the set of records.[/green]
With ppPres
With .Slides.Add(rs.AbsolutePosition + 1, ppLayoutTitle)
With .Shapes _
.AddTable(iFound, 5, 0, 0, 0, 0)[green]
'.AddTable(Rows, Columns, Left, Top, Width, Height)
'.AddTable(iFound, 5, 10, 10, 288, 216)[/green]
With .Table[green]
'Format the first Row
'Color the first row[/green]
For Each cl In .Rows(1).Cells
cl.Shape.Fill.ForeColor.RGB = RGB(50, 125, 0)
Next cl[green]
'Size the columns.[/green]
.Columns(1).Width = 200
.Columns(2).Width = 75
.Columns(3).Width = 150
.Columns(4).Width = 125
.Columns(5).Width = 75[green]
'Populate the Header row[/green]
.Cell(1, 1).Shape.TextFrame.TextRange.Text = "Client"
.Cell(1, 2).Shape.TextFrame.TextRange.Text = "Project"
.Cell(1, 3).Shape.TextFrame.TextRange.Text = "Dept."
.Cell(1, 4).Shape.TextFrame.TextRange.Text = "Lead"
.Cell(1, 5).Shape.TextFrame.TextRange.Text = "% Done"
End With
[green]
'Populate the data rows.[/green]
With .Table
While Not rs.EOF
For c = 1 To 5
If r > iFound Then Exit For
Select Case c
Case 1, 2[green]
'If rs.Fields(1) <> lLastProject Then[/green]
.Cell(r, c).Shape.TextFrame.TextRange.Text = rs.Fields(c - 1)
[green] 'End If[/green]
Case Else
.Cell(r, c).Shape.TextFrame.TextRange.Text = rs.Fields(c - 1)
End Select
Next [green]'c column[/green]
lLastProject = rs.Fields(1)
rs.MoveNext
r = r + 1
Wend
End With
End With[green]
'.SlideShowTransition.EntryEffect = ppEffectBlindsVertical[/green]
End With
End With