Public Sub CreatePPT()
' On Error GoTo ErrHere
Dim db As Database
Dim rsMigzarim As Recordset
Dim rs As Recordset
Dim pptObj As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As Slide
Dim lngX As Long
Dim lngY As Long
Dim lngShapeID As Long
Set db = CurrentDb()
Set rs = db.OpenRecordset("SELECT * From [SumStatusGius] ORDER BY [Table1]", dbOpenDynaset)
Set rsMigzarim = db.OpenRecordset("SELECT [FieldName] From [Table2] ORDER BY [SortID]", dbOpenDynaset)
Set pptObj = New PowerPoint.Application
Set pptPres = pptObj.Presentations.Add
lngX = 1
lngY = 1
lngShapeID = 2
With pptPres
With .Slides.Add(pptPres.Slides.Count + 1, ppLayoutTitle)
.Shapes.AddTable 23, 20, 230, 60
lngShapeID = lngShapeID + 1
With .Shapes(lngShapeID).Table
.Columns(1).Width = 60
.Columns(2).Width = 34
.Columns(3).Width = 34
.Columns(4).Width = 34
.Columns(5).Width = 34
.Columns(6).Width = 34
.Columns(7).Width = 34
.Columns(8).Width = 34
.Columns(9).Width = 34
.Columns(10).Width = 34
.Columns(11).Width = 34
.Columns(12).Width = 34
.Columns(13).Width = 34
.Columns(14).Width = 34
.Columns(15).Width = 34
.Columns(16).Width = 34
.Columns(17).Width = 34
.Columns(18).Width = 34
.Columns(19).Width = 34
.Columns(20).Width = 34
lngX = 1
lngY = 1
rsMigzarim.MoveFirst
While Not rsMigzarim.EOF
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = rsMigzarim.Fields("Migzar").Value
rsMigzarim.MoveNext
Wend
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = "Name"
While Not rs.EOF
lngX = 1
lngY = lngY + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = rs.Fields("FieldName").Value
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("11").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("12").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("13").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("14").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("15").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("16").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("17").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("21").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("22").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("23").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("31").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("32").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("33").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("41").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("51").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("61").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("62").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("63").Value, "")
lngX = lngX + 1
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Text = Nz(rs.Fields("FieldSum").Value, "")
lngX = lngX + 1
rs.MoveNext
Wend
[COLOR=darkred]' -- Format cells
For lngY = 1 To 23
For lngX = 1 To 20
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Characters.Font.Size = 9
.Cell(lngY, lngX).Shape.TextFrame.TextRange.Characters.Font.Bold = msoFalse
Next lngX
Next lngY
[/COLOR]
End With
End With
End With
ExitHere:
MsgBox "end"
Exit Sub
ErrHere:
MsgBox Err.Number & " - " & Err.Description
Resume ExitHere
End Sub