Class: PowerPoint in Category Microsoft PowerPoint : Automation from Total Visual SourceBook

' Example of CPowerPoint
'
' To use this example, create a new module and paste this code into it.
' Then run the procedure by putting the cursor in the procedure and pressing:
'    F5 to run it, or
'    F8 to step through it line-by-line (see the Debug menu for more options)

Private Const mcstrSamplePath As String = "C:\Total Visual SourceBook 2013\Samples\"
Private Const mcstrSampleDB As String = mcstrSamplePath & "SAMPLE.MDB"

Private Const mcstrExample As String = mcstrSamplePath & "Example.pptx"
Private Const mcstrExample2 As String = mcstrSamplePath & "Example2.pptx"

Private Const mcstrFontName As String = "Calibri"

Private Sub Example_CPowerPoint()
  ' Comments: Examples of using the CPowerPoint class to manage Microsoft PowerPoint presentations from VBA and VB6.
  '           This example requires PowerPoint to be installed and opens PowerPoint to create the presentations.
  '           You can watch the presentations being created. It uses data from the Sample.mdb sample database.

  ' Specify the theme to use for the presentation
  Const cstrTheme1 As String = mcstrSamplePath & "Flow.thmx"
  Const cstrTheme2 As String = mcstrSamplePath & "Angles.thmx"

  Dim clsPowerPoint As CPowerPoint
  Dim strMsg As String
  Dim fContinue As Boolean
  Dim fOverwriteTheme As Boolean
  Dim strPresentation As String
  Dim astrNames() As String
  Dim intPresentationCount As Integer
  Dim strTitle As String, strText1 As String, strText2 As String
  Dim intSlide As Integer

  ' Initialize PowerPoint class
  Set clsPowerPoint = New CPowerPoint

  ' Before continuing, we want to be sure that the computer doesn't have an existing instance of Excel running.
  ' This is so our example code doesn't erroneously interact with the wrong instance of Excel and cause problems.
  If clsPowerPoint.IsOpen() Then
    strMsg = "PowerPoint is currently open. To avoid modifying your presentations, close PowerPoint before continuing." & vbCrLf & vbCrLf & "Do you want to continue?"
    fContinue = (MsgBox(strMsg, vbYesNo + vbCritical) = vbYes)
  Else
    ' PowerPoint isn't open, so no need to prompt the user
    fContinue = True
  End If

  If fContinue Then
    ' Ask whether slide styles use or overwrite themes
    fOverwriteTheme = (MsgBox("Overwrite theme settings for slides?", vbQuestion + vbYesNo) = vbYes)

    ' Start PowerPoint
    clsPowerPoint.StartPowerPoint

    ' Create a new Presentation
    clsPowerPoint.NewPresentation

    ' Set the theme template file for the presentation
    clsPowerPoint.SetTemplateTheme cstrTheme1

    ' Minimize PowerPoint during the automation process (disabled so you can see the slides as they are being created)
    'clsPowerPoint.WindowState = ppWindowMinimized
    'Debug.Print "Minimizing PowerPoint"

    ' Create the Title Slide (there can only be one per presentation)
    If fOverwriteTheme Then
      ' Override the theme styles for the title and subtitle
      clsPowerPoint.SetTitleAttributes mcstrFontName, 36, vbMagenta, False, False, False
      clsPowerPoint.SetSubTitleAttributes mcstrFontName, 24, vbRed, False, False, False
      clsPowerPoint.CreateTitleSlideAttributes "PowerPoint Automation", "Code and Examples"
    Else
      ' Simply assign the title and subtitle without changing the styles of the theme
      clsPowerPoint.CreateTitleSlide "PowerPoint Automation", "Code and Examples"
    End If

    ' Create a new slide with just a title
    strTitle = "FMS Total Visual SourceBook"
    If fOverwriteTheme Then
      ' Overwrite the theme settings and set the title
      clsPowerPoint.SetTitleAttributes mcstrFontName, 36, vbBlue, False, False, False
      clsPowerPoint.CreateTitleOnlySlideAttributes strTitle
    Else
      ' Simply set the title
      clsPowerPoint.CreateTitleOnlySlide strTitle
    End If

    ' Create a standard slide with these items
    strTitle = "Grocery List"
    strText1 = "Milk" & vbCrLf & _
               "Bread" & vbCrLf & _
               "Cereal" & vbCrLf & _
               "Coffee"
    If fOverwriteTheme Then
      ' Overwrite the theme settings for the title and items
      clsPowerPoint.SetTitleAttributes mcstrFontName, 72, vbRed, False, False, False
      clsPowerPoint.SetTextAttributes mcstrFontName, 36, vbBlack, False, False, False
      clsPowerPoint.CreateTitleTextSlideAttributes strTitle, strText1
    Else
      ' Simply set the title and items
      clsPowerPoint.CreateTitleTextSlide strTitle, strText1
    End If

    ' Get the slide information (Title Only Slide)
    GetSlideInformation clsPowerPoint, clsPowerPoint.SlidePosition

    ' Create a two column slide
    strTitle = "The 'To-Do' List"
    strText1 = "Work Tasks" & vbCrLf & _
               "Work Item2"
    strText2 = "Home Tasks" & vbCrLf & _
               "Second Home Item"
    If fOverwriteTheme Then
      ' Overwrite the theme settings for the title and items
      clsPowerPoint.SetTitleAttributes mcstrFontName, 36, vbRed, False, False, False
      clsPowerPoint.SetColumn1Attributes mcstrFontName, 22, vbBlack, False, False, False
      clsPowerPoint.SetColumn2Attributes mcstrFontName, 22, vbBlue, False, False, False
      clsPowerPoint.CreateTitle2ColumnSlideAttributes strTitle, strText1, strText2
    Else
      clsPowerPoint.CreateTitle2ColumnSlide strTitle, strText1, strText2
    End If

    ' Get the slide information
    GetSlideInformation clsPowerPoint, clsPowerPoint.SlidePosition

    ' =======================================================================
    ' Create slides based on data retrieved from a database
    Example_CreateSlidesFromDatabase clsPowerPoint
    ' =======================================================================

    ' Move to slide #2
    intSlide = 2
    clsPowerPoint.GotoSlide intSlide
    Debug.Print "The current slide is now set to Slide #" & clsPowerPoint.SlidePosition

    ' Show the properties of slide
    Debug.Print "Slide #" & intSlide & " properties"
    Debug.Print "--------------------------------"
    Debug.Print "Slide Height: " & clsPowerPoint.SlideHeight
    Debug.Print "Slide Width : " & clsPowerPoint.SlideWidth
    Select Case clsPowerPoint.SlideOrientation
      Case oHorizontal
        Debug.Print "Slide Orientation: Horizontal"
      Case oVertical
        Debug.Print "Slide Orientation: Vertical"
    End Select

    ' Set slide's background color
    clsPowerPoint.SetSlideBackgroundColor intSlide, vbCyan

    ' =======================================================================
    ' Duplicate slide #3 (the new slide becomes 4)
    intSlide = 3
    clsPowerPoint.DuplicateSlide intSlide

    intSlide = intSlide + 1
    Debug.Print "Duplicate slide in slide position #" & intSlide

    ' Get the title from the new slide
    strTitle = clsPowerPoint.GetSlideText(intSlide, 1)

    ' Update the title on the new slide
    clsPowerPoint.SetSlideText intSlide, 1, "Duplicated " & strTitle

    ' Move the new slide to the end of the Presentation
    clsPowerPoint.MoveSlide intSlide

    If MsgBox("Do you want to delete the last slide in the presentation?", vbQuestion + vbYesNo) = vbYes Then
      ' Delete the slide we duplicated and moved to the end
      clsPowerPoint.DeleteSlide clsPowerPoint.SlideCount
      Debug.Print "The duplicated slide was deleted"
    End If

    ' =======================================================================

    ' Determine the current slide
    Debug.Print "The current slide position number is: " & clsPowerPoint.SlidePosition

    ' Count the number of slides in the Presentation
    Debug.Print "The number of slides in the Presentation: " & clsPowerPoint.SlideCount

    ' Reset the background settings for slide #2
    clsPowerPoint.ResetSlideBackground 2

    ' Go to last slide
    clsPowerPoint.GotoSlide -1

    ' Preview the current slide Presentation (uncomment to execute)
    'clsPowerPoint.PreviewSlidePresentation

    ' Put a frame around the slides for prints
    clsPowerPoint.FrameSlides = True

    ' Print the current slide to the printer (uncomment to execute)
    'clsPowerPoint.PrintCurrentSlide

    ' Print the entire slide Presentation (uncomment to execute)
    'clsPowerPoint.PrintSlidePresentation , , , , ppPrintOutputOutline

    ' Get current Presentation's name
    strPresentation = clsPowerPoint.ActivePresentation

    If MsgBox("Do you want to show the slide show for the current presentation?", vbQuestion + vbYesNo) = vbYes Then
      ' Launch slide show presentation
      clsPowerPoint.ShowSlideShow

      ' Example of using other slide show options to use built in timings
      'clsPowerPoint.ShowSlideShow ppShowTypeKiosk, True, False, False, ppShowAll, ppSlideShowUseSlideTimings
    End If

    ' =======================================================================

    ' Create another Presentation using a different theme
    clsPowerPoint.NewPresentation
    Debug.Print "A new presentation is added: " & clsPowerPoint.ActivePresentation

    ' Set the theme template file for the presentation
    clsPowerPoint.SetTemplateTheme cstrTheme2

    ' Create a title slide for the new Presentation
    If fOverwriteTheme Then
      clsPowerPoint.SetTitleAttributes mcstrFontName, 36, vbMagenta, False, False, False
      clsPowerPoint.SetSubTitleAttributes mcstrFontName, 24, vbRed, False, False, False
      clsPowerPoint.CreateTitleSlideAttributes "Second Presentation", "Code and Examples"
    Else
      clsPowerPoint.CreateTitleSlide "Second Presentation", "Code and Examples"
    End If

    ' Create second page
    clsPowerPoint.CreateTitleTextSlide "Second Page", strText1

    ' Count the number of Presentations
    Debug.Print "Number of Presentations: " & clsPowerPoint.PresentationCount

    ' Set focus to previous Presentation
    Debug.Print "Current Presentation: " & clsPowerPoint.ActivePresentation

    clsPowerPoint.ActivePresentation = strPresentation
    Debug.Print "Focus set to previous Presentation: " & strPresentation

    ' =======================================================================
    ' Create a third presentation without a theme, set colors and patterns, customize footer
    Example_CreatePresentationNoTheme
    ' =======================================================================

    ' Show a list of the Presentations
    astrNames = clsPowerPoint.GetPresentationList
    Debug.Print
    Debug.Print "Presentation List" & vbCrLf & _
                "-----------------"
    For intPresentationCount = LBound(astrNames) To UBound(astrNames)
      Debug.Print astrNames(intPresentationCount)
    Next intPresentationCount

    clsPowerPoint.WindowState = ppWindowMaximized

    ' Uncomment to execute
    '  clsPowerPoint.ClosePowerPoint

    ' Clean Up
    Set clsPowerPoint = Nothing

  End If
End Sub

Private Sub Example_CreateSlidesFromDatabase(clsPowerPoint As CPowerPoint)
  ' Comments: Create slides from data in the database
  ' Params  : clsPowerPoint     PowerPoint class object

  Const cstrQuery As String = "qryPowerPointDemo"

  Dim dbs As DAO.Database
  Dim rstCompany As DAO.Recordset
  Dim rstOrder As DAO.Recordset
  Dim strOrder As String

  Set dbs = DBEngine.OpenDatabase(mcstrSampleDB)

  ' Get the list of unique company names from the query
  Set rstCompany = dbs.OpenRecordset("SELECT DISTINCT [CompanyName] FROM [" & cstrQuery & "]")

  If Not rstCompany.EOF Then
    ' Set title slide attributes which are used by the new slides created here
    clsPowerPoint.SetTitleAttributes mcstrFontName, 36, vbGrayText, True, True, True

    ' For each company, create a separate slide for its list of orders
    Do While Not rstCompany.EOF
      strOrder = ""
      clsPowerPoint.SetTextAttributes mcstrFontName, 24, vbBlue, False, False, False

      ' Create the text to show the order ID and date
      Set rstOrder = dbs.OpenRecordset("SELECT [OrderID], [OrderDate] FROM [" & cstrQuery & "] WHERE CompanyName = '" & rstCompany![CompanyName] & "'")
      Do While Not rstOrder.EOF
        strOrder = strOrder & rstOrder![OrderID] & ": " & Format$(rstOrder![OrderDate], "Medium Date") & vbCrLf
        rstOrder.MoveNext
      Loop
      rstOrder.Close
      Set rstOrder = Nothing

      ' Create the slide with the data
      clsPowerPoint.CreateTitleTextSlide rstCompany![CompanyName], strOrder
      rstCompany.MoveNext
    Loop

  End If

  ' Clean up
  rstCompany.Close
  Set rstCompany = Nothing

  dbs.Close
  Set dbs = Nothing
End Sub

Private Sub Example_CreatePresentationNoTheme()
  ' Comments: Create a presentation without a theme, set colors and patterns, customize footer

  Dim clsPowerPoint As CPowerPoint

  Set clsPowerPoint = New CPowerPoint

  If clsPowerPoint.StartPowerPoint() Then
    clsPowerPoint.NewPresentation

    ' Add a slide to the Presentation
    ' Create a slide with attributes
    clsPowerPoint.SetTitleAttributes mcstrFontName, 72, vbRed, False, False, False
    clsPowerPoint.SetTextAttributes mcstrFontName, 36, vbBlack, False, False, False
    clsPowerPoint.CreateTitleTextSlideAttributes "Grocery List", "Milk" & vbCrLf & "Bread" & vbCrLf & "Cereal" & vbCrLf & "Coffee"

    ' Save the 3rd Presentation
    clsPowerPoint.SavePresentationAs mcstrExample, ppSaveAsDefault

    ' Close the presentation
    clsPowerPoint.ClosePresentation
    Debug.Print "Close 3rd Presentation (current)"

    ' Open 3rd Presentation (just previously closed)
    clsPowerPoint.OpenPresentation mcstrExample, False, True, True

    ' Change the title on the first page
    clsPowerPoint.SetSlideText 1, 1, "New Grocery List"

    ' Set slide's background color
    clsPowerPoint.SetSlideBackgroundColor 1, vbYellow

    ' Create another slide
    clsPowerPoint.CreateTitleTextSlide "Second Slide", "Item 1" & vbCrLf & "Item 2"

    ' Set slide's background pattern and color
    clsPowerPoint.SetSlideBackgroundPattern 2, msoPatternWeave
    clsPowerPoint.SetSlideBackgroundColor 2, vbCyan

    ' Save the Presentation
    clsPowerPoint.SavePresentation

    ' Set footer and slide number values
    Example_SetFooter clsPowerPoint, True

    ' Save Presentation as a new name: " & mcstrExample2
    clsPowerPoint.SavePresentationAs mcstrExample2, ppSaveAsDefault
  End If
  Set clsPowerPoint = Nothing

End Sub

Private Sub Example_SetFooter(clsPowerPoint As CPowerPoint, fAutomatic As Boolean)
  ' Comments: Set footer and slide number values
  ' Params  : clsPowerPoint     PowerPoint class object
  '           fAutomatic        True for automatic dates, False for explicit date

  ' Turn on the footer slide number
  clsPowerPoint.SlideNumberOn = True

  ' Change the starting slide number
  clsPowerPoint.FirstSlideNumber = 10
  Debug.Print "First slide is set to: " & clsPowerPoint.FirstSlideNumber

  ' Turn on footer text
  clsPowerPoint.SlideFooterTextOn = True

  ' Set the footer text
  clsPowerPoint.SlideFooterText = "FMS Total Visual SourceBook"

  ' Set the footer date
  clsPowerPoint.SlideFooterDateOn = True
  clsPowerPoint.SlideFooterDateUseFormat = fAutomatic
  If fAutomatic Then
    ' Set footer date (auto)
    clsPowerPoint.SlideFooterDateFormat = ppDateTimeddddMMMMddyyyy
  Else
    ' Set footer date (manual)
    clsPowerPoint.SlideFooterDateText = Format(#10/13/2014#, "Medium Date")
  End If

End Sub

Private Sub GetSlideInformation(clsPowerPoint As CPowerPoint, ByVal intSlideNumber As Integer)
  ' Comments: Display information for a slide in the Immediate Window
  ' Params  : clsPowerPoint     PowerPoint class object
  '           intSlideNumber    Slide number

  Dim strTitle As String
  Dim strTextItems As String
  Dim strSubTitle As String
  Dim strColumn1 As String
  Dim strColumn2 As String

  Select Case clsPowerPoint.LayoutType
    Case EnumLayoutTypes.ltLayoutText
      Call clsPowerPoint.ExtractTitleTextSlide(intSlideNumber, strTitle, strTextItems)
      Debug.Print "Slide Layout...: Text" & vbCrLf & _
                  "Title..........: " & strTitle & vbCrLf & _
                  "Text Items.....: " & strTextItems & vbCrLf & vbCrLf

    Case EnumLayoutTypes.ltLayoutTitle
      Call clsPowerPoint.ExtractTitleSlide(intSlideNumber, strTitle, strSubTitle)
      Debug.Print "Slide Layout...: Title" & vbCrLf & _
                  "Title..........: " & strTitle & vbCrLf & _
                  "Subtitle.......: " & strSubTitle & vbCrLf & vbCrLf

    Case EnumLayoutTypes.ltLayoutTwoColumnText
      Call clsPowerPoint.ExtractTitle2ColumnSlide(intSlideNumber, strTitle, strColumn1, strColumn2)
      Debug.Print "Slide Layout...: 2-Column Text" & vbCrLf & _
                  "Title..........: " & strTitle & vbCrLf & _
                  "Column 1.......: " & strColumn1 & _
                  "Column 2.......: " & strColumn2 & vbCrLf & vbCrLf

    Case EnumLayoutTypes.ltLayoutTitleOnly
      Call clsPowerPoint.ExtractTitleOnlySlide(intSlideNumber, strTitle)
      Debug.Print "Layout.........: Title Only" & vbCrLf & _
                  "Title..........: " & strTitle & vbCrLf & vbCrLf

  End Select

End Sub

The source code in Total Visual Sourcebook includes modules and classes for Microsoft Access, Visual Basic 6 (VB6), and Visual Basic for Applications (VBA) developers. Easily add this professionally written, tested, and documented royalty-free code into your applications to simplify your application development efforts.

Total Visual SourceBook is written for the needs of a developer using a source code library covering the many challenges you face. Countless developers over the years have told us they learned some or much of their development skills and tricks from our code. You can too!

Additional Resources

• List of All Modules in Total Visual SourceBook
• List of All Code Categories in Total Visual SourceBook
• Sample Module Code from Total Visual SourceBook (Example of Date, Time and Age Calculations)