VBA - Create Power Point 2010 Presentation

Option Compare Database
Option Explicit

Public Sub Create_PowerPoint_Presentation()
      ' This code is based on Power Point 97 objects running in Excel 97
      ' However, it can be valid using Access to start Excel and grab the charts too.
      ' This code in Excel requires a [B]Tools - Reference [/B] and setting to Excel AND to Microsoft PowerPoint to check the object reference.
      ' My hope is to update this to Access 2010 soon and re-post it
      ' ---- >  Please feel free to re-use this code, and add your own comments [U]THEN Share your code back with us[/U] 
      ' Because this module relies on late binding, it is
      ' necessary to declare constants to be used with PowerPoint.
      
      ' **********  NOTES to Access 2010 Powerpoint 2010
      ' This will run from MS Access - however, at the point of code where the copy/paste of
      ' Excel chart takes place, it will fail. Use the debugger to step down
      ' Instructions are provided to those running it from MS Access on how to skip down
      
          Const ppLayoutTitle As Integer = 1
          Const ppLayoutText As Integer = 2
          Const ppLayoutTitleOnly As Integer = 11
          Const ppEffectFlyFromTop As Integer = 3330
          Const ppEffectBoxIn As Integer = 3074
          Const ppSlideShowUseSlideTimings As Integer = 2
          Const ppEffectRandom As Integer = 513
          Const ppWindowMaximized As Integer = 3
          Const ppEffectCheckerboardDown As Integer = 1026
          Const ppAdvanceOnTime As Integer = 2
          Const ppAnimateByWord As Integer = 1
          Const ppAnimateByFirstLevel As Integer = 1
          Const ppEffectBoxOut As Integer = 3073
           
      ' Variable Declarations:
          Dim Pres1 As Object
          Dim Slide1 As Object
          Dim Shape1 As Object
          Dim Shape2 As Object
          Dim Shape3 As Object
          Dim Shape4 As Object
          Dim Shape5 As Object
          Dim Picture1 As Object
          Dim SlideNum As Integer
          Dim x As Variant
          Dim PPTApp As Object
      ' The routine starts by using CreateObject to get
      ' an object that points to PowerPoint.
10        Set PPTApp = CreateObject("PowerPoint.Application")
           
      ' The PowerPoint window is then maximized and a
      ' new presentation is added.
20        With PPTApp
30            .Visible = True ' this can be set to false now, then to true when build is finished.
40            .WindowState = ppWindowMaximized
50            Set Pres1 = PPTApp.Presentations.Add
60        End With
           
      ' The first slide is added -- the title slide.
70            Set Slide1 = Pres1.Slides.Add(1, ppLayoutTitleOnly)
80            Pres1.SlideMaster.Background.Fill.PresetTextured _
                  msoTextureFishFossil
               
      ' Then various properties of the first shape
      ' on the title slide are set.
90        With Slide1
100           With .Shapes(1)
110               .Top = 120
120               With .TextFrame.TextRange
130                   .Text = "Setagaya Cycle" & Chr(13) & _
                          "Annual Sales Report"
140                   .Font.Size = 54
150               End With
160               With .AnimationSettings
170                   .EntryEffect = ppEffectCheckerboardDown
180                   .AdvanceMode = ppAdvanceOnTime
190               End With
200           End With
               
      ' Three graphic objects representing a bicycle are added to
      ' the slide. The objects are assigned one-color shades
      ' and random build effects.
210           With Slide1.Shapes
220               Set Shape1 = .AddShape(msoShapeOval, _
                          100, 300, 200, 200)
230               With Shape1.Fill
240                   .ForeColor.RGB = RGB(255, 0, 0)
250                   .BackColor.RGB = RGB(255, 255, 255)
260                   .OneColorGradient msoGradientHorizontal, 1, 1
270               End With
280               With Shape1.AnimationSettings
290                   .EntryEffect = ppEffectRandom
300                   .AdvanceMode = ppAdvanceOnTime
310               End With
320               Set Shape2 = .AddShape(msoShapeOval, _
                          400, 300, 200, 200)
330               With Shape2.Fill
340                   .ForeColor.RGB = RGB(0, 255, 0)
350                   .BackColor.RGB = RGB(255, 255, 255)
360                   .OneColorGradient msoGradientHorizontal, 1, 1
370               End With
380               With Shape2.AnimationSettings
390                   .EntryEffect = ppEffectRandom
400                   .AdvanceMode = ppAdvanceOnTime
410               End With
420               Set Shape3 = .AddShape(msoShapeParallelogram, _
                      Shape1.Left + (Shape1.Width * 0.5), _
                      Shape1.Top + (Shape1.Height * 0.33), _
                      (Shape2.Left + (Shape2.Width * 0.5)) - _
                      (Shape1.Left + (Shape1.Width * 0.5)), _
                      Shape1.Height * 0.25)
430               With Shape3.Fill
440                   .ForeColor.RGB = RGB(0, 0, 255)
450                   .BackColor.RGB = RGB(255, 255, 255)
460                   .OneColorGradient msoGradientHorizontal, 1, 1
470               End With
480               With Shape3.AnimationSettings
490                   .EntryEffect = ppEffectRandom
500                   .AdvanceMode = ppAdvanceOnTime
510               End With
520           End With
               
      ' Before moving to the second slide, the first slide
      ' is assigned an advance time of 1 second and a random entry effect.
530           With .SlideShowTransition
540               .AdvanceOnTime = True
550               .AdvanceTime = 1
560               .EntryEffect = ppEffectRandom
570           End With
580       End With

      ' The second slide is added and activated.
590       SlideNum = Pres1.Slides.Count + 1
600       Set Slide1 = Pres1.Slides.Add(SlideNum, ppLayoutText)
610       PPTApp.ActiveWindow.View.GotoSlide SlideNum
           
      ' As a text slide, the second slide contains two shapes
      ' that can hold text. Text strings are assigned to both.
      ' The second slide object holds bulleted points. A
      ' continuous text string with line-feed characters--chr(13)--
      ' is assigned to the shape and used to create the bulleted points.
620       With Slide1
630           .Background.Fill.PresetTextured msoTextureBouquet
640           .Shapes(1).TextFrame.TextRange.Text = _
                  "Revenue Growth by Region"
650           With .Shapes(2)
660               .TextFrame.TextRange.Text = "North" & Chr(13) & _
                          "Sales are getting Stronger every day." & _
                          Chr(13) & "South" & Chr(13) & _
                          "Revenue is at a record high." & _
                          Chr(13) & "East" & Chr(13) & _
                          "We can't grow any faster." & _
                          Chr(13) & "West" & Chr(13) & _
                          "If only we could get Rx to work longer hours."

      ' Through use of IndentLevel, even lines are indented.
670               For x = 1 To 8
680                   If x Mod 2 = 0 Then
690                       .TextFrame.TextRange.Lines(x, 1).IndentLevel = 2
700                   Else
710                       .TextFrame.TextRange.Lines(x, 1).IndentLevel = 1
720                   End If
730                Next
740               .Left = 100
                   
      ' A character fly-from-top build effect is then assigned
      ' to the shape.
750               With .AnimationSettings
760                   .EntryEffect = ppEffectFlyFromTop
770                   .TextUnitEffect = ppAnimateByWord
780                   .TextLevelEffect = ppAnimateByFirstLevel
790                   .AdvanceMode = ppAdvanceOnTime
800               End With
810           End With
               
      ' And lastly, advance time and entry effects are set
      ' for the second slide.
820           With .SlideShowTransition
830               .AdvanceOnTime = True
840               .AdvanceTime = 1
850               .EntryEffect = ppEffectRandom
860           End With
870       End With
           
      ' The third slide is added to the presentation and activated.
880       SlideNum = Pres1.Slides.Count + 1
890       Set Slide1 = Pres1.Slides.Add(SlideNum, ppLayoutTitleOnly)
900       PPTApp.ActiveWindow.View.GotoSlide SlideNum
910       With Slide1
920           .Shapes(1).TextFrame.TextRange.Text = _
                  "Quarterly Sales Summary"
930           With .SlideShowTransition
940               .AdvanceOnTime = True
950               .AdvanceTime = 1
960               .EntryEffect = ppEffectRandom
970           End With
980       End With
           
      ' After setting various effects for the slide, a worksheet
      ' is copied from Sheet1 and pasted into the slide. The routine
      ' then adjusts the size of the embedded Excel worksheet object
      ' and assigns build effects.
      ' *********** NOTE if running from MS Access, the Sheet1 doesn't exist *******
      ' This is the part that would copy an Excel chart and paste it into the PowerPoint
      ' ****  RUNNING FROM MS ACCESS - Move debug pointer to line 1260 and skip the Excel chart copy paste
990       Worksheets("Sheet1").Range("SalesTable").Copy
1000      PPTApp.ActiveWindow.View.Paste
1010      Set Shape4 = Slide1.Shapes(2)
1020      With Shape4
1030          .Top = .Top * 0.6
1040          .Left = .Left * 0.4
1050          .Width = .Width * 1.2
1060          .Height = .Height * 1.2
1070          With .AnimationSettings
1080              .EntryEffect = ppEffectBoxOut
1090              .AdvanceMode = ppAdvanceOnTime
1100          End With
1110      End With
           
      ' Likewise, a chart is copied and pasted into the slide.
1120      Worksheets("Sheet1").ChartObjects("SalesChart").Copy
1130      PPTApp.ActiveWindow.View.Paste
1140      Set Shape5 = Slide1.Shapes(3)
1150      With Shape5
1160          .Top = Shape4.Top + Shape4.Height + 20
1170          .Left = Shape4.Left
1180          .Width = Shape4.Width
1190          .Height = .Height * 1.2
1200          With .AnimationSettings
1210              .EntryEffect = ppEffectBoxIn
1220              .AdvanceMode = ppAdvanceOnTime
1230          End With
1240      End With
           
      ' When all slides are built, the first slide is
      ' activated, various parameters of the SlideShowSettings
      ' object are set, and the Run method is called
      ' on the SlideShowSettings object to start the show.
1250      PPTApp.ActiveWindow.View.GotoSlide 1
        ' if PPTApp.visible was set to False, Now is the time to set it back to true (see line 30 above)
1260      With Pres1.SlideShowSettings
1270          .StartingSlide = 1
1280          .EndingSlide = 3
1290          .AdvanceMode = ppSlideShowUseSlideTimings
1300          .Run
1310      End With
            ' Once the PPT runs - click on the Power Point to make it continue playing
End Sub
' In addition, a Save As routine can be added to keep the powerpoint on file