PPT2000: Sample VBA Code Add-in for Counting Slide Visits (202088)

MORE INFORMATION

Microsoft provides programming examples for illustration only, without warranty either expressed or implied. This includes, but is not limited to, the implied warranties of merchantability or fitness for a particular purpose. This article assumes that you are familiar with the programming language that is being demonstrated and with the tools that are used to create and to debug procedures. Microsoft support engineers can help explain the functionality of a particular procedure, but they will not modify these examples to provide added functionality or construct procedures to meet your specific requirements. NOTE: The following macro examples work only in PowerPoint. Visual Basic for Applications macros are not supported by the Microsoft PowerPoint Viewer. For additional information, click the following article number to view the article in the Microsoft Knowledge Base:

Tracking Hits using Custom Properties

This add-in allows you to set up a presentation so that you can track how many times each slide has been visited, reset the counters, print a report with the slide hit counts, run the Slide Show, and track the hits on each slide.

NOTE: This add-in works only in PowerPoint 2000 or later. It is not meant to be used with web-based documents and does not run in PowerPoint Viewer.

Creating the Add-in

To create the add-in, follow these steps:

Create or open a presentation in PowerPoint.
On the Tools menu, point to Macro, and then click Visual Basic Editor.
On the Insert menu, click Class Module. A module called "Class1" will be inserted into your project.

In the Class1 module window, type the following lines of code:

Public WithEvents appEvent As Application
'
' The public property presName is used to make sure that
' the counter is not turned off when a branched presentation
' ends.
'
Public presName As String

Private Sub appEvent_SlideShowEnd(ByVal Pres As Presentation)
'
' Check to make sure the starting presentation is the same
' as the presentation just ending.
'
   If Pres.Name = presName Then
'
' Call to Module1, invoking the sub procedure endShowCount,
' which turns off events.
'
      Module1.endShowCount
      presName = ""
   Else
'
' Restart the main slide show. Always end the branched show first
' before going on to another show. There will be a brief flicker on the
' desktop when this transition occurs. You can modify this subprocedure
' by following the example in article Q222709 in the Microsoft Knowledge  
' Base. For more information, see the "References" section of this article.
'
      Presentations(presName).SlideShowWindow.Activate
   End If
End Sub

Private Sub appevent_SlideShowNextSlide(ByVal Wn As SlideShowWindow)
'
' Using On Error Resume Next allows this event handler to ignore
' presentations for which counters have not been enabled.
'
   On Error Resume Next
   Dim custName As String
'
' Get the name of the slide from the Wn object.
'
   custName = Wn.View.Slide.Name
'
' Increment the counter for the slide by one.
'
   ActivePresentation.CustomDocumentProperties(custName) = _
     ActivePresentation.CustomDocumentProperties(custName) + 1
End Sub

On the Insert menu, click Module.

Type the following Visual Basic for Applications code in the module:

Dim aEvent As New Class1

Sub Auto_Open()
'
' Define two comand bar controls, a pop-up menu and a command
' bar button.
'
   Dim NewControl As CommandBarPopup
   Dim menuControl As CommandBarButton
'
' Define an object reference to a command bar.
'
   Dim ToolsMenu As CommandBars
'
' Set the variable to the CommandBars object.
'
   Set ToolsMenu = Application.CommandBars
'
' Create the menu item. By default, it will be placed at the bottom of
' the Tools menu. Set the caption and enable the button.
'
   Set NewControl = ToolsMenu("Tools").Controls.Add(msoControlPopup)
   NewControl.Caption = "Slide Coutnters"
   NewControl.Enabled = True
'
' Set the optional ToolTip text for the control.
'
   NewControl.TooltipText = "Adds Hit counters to your presentation."
'
' Make the control visible.
'
   NewControl.Visible = True
'
' On the new pop-up menu create a new menu item. Set the style to
' caption, add the caption to the control, enable and make the control
' visible. Set the button to run the ReportHits subprocedure, and 
' clear the button for the next control.
'
   Set menuControl = NewControl.CommandBar.Controls.Add(msoControlButton)
   menuControl.Style = msoButtonCaption
   menuControl.Caption = "Print Report"
   menuControl.Enabled = True
   menuControl.Visible = True
   menuControl.OnAction = "ReportHits"
   Set menuControl = Nothing
'
' On the new pop-up menu create a new menu item. Set the style to
' caption, add the caption to the control, enable and make the control
' visible. Set the button to run the ResetCount subprocedure, and
' clear the button for the next control.
'
   Set menuControl = NewControl.CommandBar.Controls.Add(msoControlButton)
   menuControl.Style = msoButtonCaption
   menuControl.Caption = "Reset Counters"
   menuControl.Enabled = True
   menuControl.Visible = True
   menuControl.OnAction = "ResetCount"
   Set menuControl = Nothing
'
' On the new pop-up menu create a new menu item. Set the style to
' caption, add the caption to the control, enable and make the control
' visible. Set the button to run the SetupCounters subprocedure, and
' clear the button for the next control.
'
   Set menuControl = NewControl.CommandBar.Controls.Add(msoControlButton)
   menuControl.Style = msoButtonCaption
   menuControl.Caption = "Add Counter"
   menuControl.Enabled = True
   menuControl.Visible = True
   menuControl.OnAction = "SetupCounters"
   Set menuControl = Nothing
'
' On the new pop-up menu create a new menu item. Set the style to
' caption, add the caption to the control, enable and make the control
' visible. Set the button to run the RunShowCount subprocedure, and
' clear the button for the next control.
'
   Set menuControl = NewControl.CommandBar.Controls.Add(msoControlButton)
   menuControl.Style = msoButtonCaption
   menuControl.Caption = "Run Show With Count"
   menuControl.Enabled = True
   menuControl.Visible = True
   menuControl.OnAction = "RunShowCount"
   Set menuControl = Nothing
'
' Clear the NewControl and ToolsMenu objects.
'
   Set NewControl = Nothing
   Set ToolsMenu = Nothing
End Sub

Sub Auto_Close()

   Dim oControl As CommandBarControl
   Dim ToolsMenu As CommandBars
'
' Get an object reference to a command bar.
'
   Set ToolsMenu = Application.CommandBars
'
' Loop through the commands on the Tools menu.
'
   For Each oControl In ToolsMenu("Tools").Controls
'
' Check to see whether the command exists.
'
      If oControl.Caption = "Slide Coutnters" Then
'
' Remove the command from the menu.
'
         oControl.Delete
      End If
   Next oControl
End Sub


Sub ResetCount()
'
' Skip over slides that do have a counter assigned to them and 
' continue resetting those that do.
'
   On Error Resume Next
   Dim i As Long
   Dim custName As String
   Dim errorTitle As String
'
' Check to see if a presentation is open.
'
   If PowerPoint.Presentations.Count <> 0 Then
'
' Loop through the custom properties, setting the value for each
' to zero.
'
      With ActivePresentation
         For i = 1 To .Slides.Count
'
' Set custName to the actual slide name.
'
            custName = .Slides(i).Name
'
' Set the custom property to 0.
'
            .CustomDocumentProperties(custName) = 0
'
' Check to see if an error has occurred. This will happen if
' a new slide has been added to the presentation that has not been
' properly set up.
'
            If Err.Number = 5 Then
'
' Test to ensure that there are shapes on the slide.
'
               If .Slides(i).Shapes.Count <> 0 Then
'
' If there are shapes on the slide, test to see if the first shape
' has a text frame. This is usually the Title placeholder, though
' if you have added shapes and other objects to the slide and have
' sent them to the back, the object furthest back will be shape number 
' one. If it does have text, add that text to custName.
'
                  If .Slides(i).Shapes(1).HasTextFrame Then
                     custName = custName & ": " & _
                       .Slides(i).Shapes(1).TextFrame.TextRange.Text
                  End If
               End If
'
' Show a warning message. This will not halt the macro, but it will
' remind the user to run "Add Counters" again.
'
'
               MsgBox "The slide, " & custName & " has not been setup." _
                 & vbNewLine & _
                 "Please run Add Counter from the Slide Counters menu.", _
                 vbExclamation
               Err.Clear
            End If
         Next i
      End With
'
' Display a confirmation message.
'
      MsgBox "The Counters have been reset.", vbExclamation
   Else
'
' If there are no presentations open, display this message:
'
      MsgBox "You do not have a presentation open!", vbExclamation
   End If
End Sub

Sub SetupCounters()
'
' Test for existing custom document properties. If one exists, then no
' new property is created. If one doesn't, then a new property for
' that slide is created.
'
' Also, clear out counters for slides that no longer exist in the
' presentation.
'
   On Error Resume Next
   Dim i As Long
   Dim lDummy As Long
   Dim oDummySlide As Slide
   Dim strName As String
'
' Check to see if a presentation is open.
'
   If PowerPoint.Presentations.Count <> 0 Then
'
' Loop through the presentation, creating a custom property for
' each individual slide in the presentation. Name each
' property with the actual slide name. Unless you rename a slide
' via a macro, it will never change.
'
      With ActivePresentation
         For i = 1 To .Slides.Count
'
' Set strName equal to the current slide, then use that
' to set lDummy equal to the value in the custom properties.
' If there is no custom property that corresponds to the
' slide name, an error is displayed.
'
            strName = .Slides(i).Name
            lDummy = .CustomDocumentProperties(strName)
            If Err.Number = 5 Then
'
' Create the new custom property, set it to be a number and
' initialize to zero. Clear the error flag.
'
               .CustomDocumentProperties.Add Name:=strName, _
                 LinkToContent:=False, Type:=msoPropertyTypeFloat, Value:=0
               Err.Clear
            End If
         Next i
'
' Loop through the custom properties and verify each one.
'
         For i = 1 To .CustomDocumentProperties.Count
'
' Set oDummySlide to the name in the custom properties to 
' verify that a slide exists for the counter. If one does
' not, then the counter is deleted from the custom properties.
'
            Set oDummySlide = .Slides(.CustomDocumentProperties(i).Name)
            If Err.Number = -2147188160 Then
               .CustomDocumentProperties(i).Delete
               Err.Clear
            End If
         Next i
      End With
'
' Display a confirmation message.
'
      MsgBox "The counters for the presentation have been created and" & _
        vbNewLine & "old counters have been removed." & vbNewLine & _
        vbNewLine & "If you add or delete slides from this presentation," _
        & vbNewLine & "run this command again to update the counters.", _
        vbInformation
   Else
'
' If there are no presentations open, display this message:
'
      MsgBox "You do not have a presentation open!", vbExclamation
   End If
End Sub

Sub ReportHits()
   On Error Resume Next
   Dim i As Long
   Dim lCount As Long
   Dim lReport As Long
   Dim lColumn As Long
   Dim lHits As Long
   Dim strBase As String
   Dim custName As String
'
' Check to see if a presentation is open.
'
   If PowerPoint.Presentations.Count <> 0 Then
'
' Initialize strBase and lReport. The variable lreport is used
' to keep track of how many slides are created to print the report.
'
      strBase = ""
      lReport = 1
      With ActivePresentation
'
' Set lCount to the number of slides in the presentation.
' Next create a new slide at the end of the presentation using the
' two column layout. Add a title, and set lColumn to 2.
'
         lCount = .Slides.Count
         .Slides.Add lCount + lReport, ppLayoutTwoColumnText
         .Slides(lCount + lReport).Shapes(1).TextFrame.TextRange.Text = _
           "Slide Hit Report"
         lColumn = 2
'
' Loop through the presentation, and build the text string that gets 
' put into a text frame, create new slides when the frame gets full,
' print the report slides, and then delete them.
'
         For i = 1 To lCount
'
' Set custName to the current slide name.
'
            custName = .Slides(i).Name
'
' Using custName, set lHits to the value stored in the custom
' property. If the property does not exist, set custName to
' a short message and lHits to 0.
'
            lHits = .CustomDocumentProperties(custName)
            If Err.Number = 5 Then
               custName = "No counter for " & custName
               lHits = 0
               Err.Clear
            End If
'
' Append the slide name and the hits for that slide to
' strBase.
'
            strBase = strBase & custName & ": " & Str(lHits) & vbCrLf
'
' if i is evenly divisible by 28, the slide is full. Empty strBase
' into the second column. Create a new slide, set the title.
'
            If i Mod 28 = 0 Then
'
' Set the second column of the Two Column layout slide to the contents
' of srtBase. The variable lColumn is the shape index position for the
' second column.
'
               .Slides(lCount + _
                lReport).Shapes(lColumn).TextFrame.TextRange.Text = strBase
'
' Increment lReport, so that the full range of new slides can be
' printed out.
'
               lReport = lReport + 1
               .Slides.Add lCount + lReport, ppLayoutTwoColumnText
               .Slides(lCount + _
                 lReport).Shapes(1).TextFrame.TextRange.Text = _
                 "Slide Hit Report Continued"
'
' Set lColumn to the value 2. This is the shape index position of the first
' column of the Two Column slide layout. Clear strBase for the next 
' column's worth of text.
'
               lColumn = 2
               strBase = ""
            Else
'
' If i is evenly divisble by 14, then there is enough text for
' the first column. Empty strBase into the first column, then
' set lColumn to the index position of the second column on the
' slide and clear srtBase.
'
               If i Mod 14 = 0 Then
                  .Slides(lCount + _
                    lReport).Shapes(lColumn).TextFrame.TextRange.Text = _
                    strBase
                  lColumn = 3
                  strBase = ""
               End If
            End If
         Next i
'
' When the last slide in the presentation is handled, empty strBase
' into the appropriate column on the last slide of the report.
'
         .Slides(lCount + _
           lReport).Shapes(lColumn).TextFrame.TextRange.Text = strBase
'
' Print out the report slides, from the first report slide to the
' last report slide in Pure Black and White mode.
'
         With .PrintOptions
            .RangeType = ppPrintSlideRange
            .Ranges.ClearAll
            .Ranges.Add lCount + 1, lCount + lReport
            .PrintColorType = ppPrintPureBlackAndWhite
         End With
'
' Print the range of slides, then clear the print range.
'
         .PrintOut
         .PrintOptions.Ranges.ClearAll
'
' Loop through the last slides of the presentation, starting from
' the last slide and work backwards, deleting each slide as it goes.
'
         For i = lReport To 1 Step -1
            .Slides(lCount + i).Delete
         Next i
      End With
   Else
'
' If there are no presentations open, display this message:
'
      MsgBox "You do not have a presentation open!", vbExclamation
   End If
End Sub

Sub RunShowCount()
'
' Set the class module property presName to the active presentation,
' start event handling, and finally run the show.
'
   aEvent.presName = ActivePresentation.Name
   Set aEvent.appEvent = Application
   ActivePresentation.SlideShowSettings.Run
End Sub

Sub endShowCount()
'
' Turn off event handling.
'
   Set aEvent.appEvent = Nothing
End Sub

On the Debug menu, click Compile VBAProject.
On the File menu, click Close and Return to Microsoft PowerPoint.
On the File menu, click Save As, name the file SlideCount.ppt and click Save.
On the File menu, click Save As. In the Save File as Type list, click PowerPoint Add-In (.ppa) and then click Save.
On the File menu, click Close.

Making the add-in available in PowerPoint

On the Tools menu, click Add-Ins.
Click Add New.
Click SlideCount.ppa, and then click OK.

The Slide Counters add-in should now be available on the Tools menu in PowerPoint.