Microsoft KB Archive/202088

= PPT2000: Sample VBA Code Add-in for Counting Slide Visits =

Article ID: 202088

Article Last Modified on 10/11/2006

-

APPLIES TO


 * Microsoft PowerPoint 2000 Standard Edition

-



This article was previously published under Q202088



SUMMARY
If you run a kiosk presentation that has many branches and choices that a person browsing it can make, it can be very useful to know which branches and slides have been visited the most and which have been visited the least.

This article contains sample Visual Basic for Applications code and implements an add-in that automates this process. It adds a menu item called Slide Counters to the Tools menu. The function of each counter is explained in the following table.   Counter Name         Function Print Report        Sends the finished report on counted slides to                        the printer. In the code sample, this is the only output produced by the add-in. No output will be                        displayed on the screen.

Reset Counters      Resets the existing counter applied to a slideshow.

Add Counter         Adds the counting functionallity to a presentation.

Run Show with Count Runs the slideshow with the counter functionallity. This is the only way to run the show and keep a                        slide count.



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 </li> On the Debug menu, click Compile VBAProject.</li> On the File menu, click Close and Return to Microsoft PowerPoint.</li> On the File menu, click Save As, name the file SlideCount.ppt and click Save.</li> On the File menu, click Save As. In the Save File as Type list, click PowerPoint Add-In (.ppa) and then click Save.</li> On the File menu, click Close.</li></ol>

Making the add-in available in PowerPoint

 * 1) On the Tools menu, click Add-Ins.
 * 2) Click Add New.
 * 3) Click SlideCount.ppa, and then click OK.

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

<div class="references_section">