' Progress Dots
' Version 0.1
'
' (C) Copyright 2007 Edward Lopr
'
' This macro adds a toolbar to PowerPoint that can be used to create a
' "progress bar" for your presentation.  A series of dots is drawn across
' the top border, corresponding to slides; and these dots change color
' as you advance through the presentation.  The dots can be grouped into
' "sections," to indicate the overall structure of your talk.  E.g., the
' generated progress bar could look something like this:
'
'         Intro     Topic 1        Topic 2      Conclusions
'        # # # #    # # * *    * * * * * * * * *    * *
'
' The toolbar includes four buttons:
'
'   - Create: opens an options dialogue to customize the progress bar;
'     and then draws the progress bar on each slide.  (This can be slow
'     for large powerpoint presentations.)
'
'   - Refresh: redraws the progress bar.  You will need to use this
'     after adding or removing slides, or section labels.
'
'   - Delete: removes the progress bar from each slide.
'
'   - Section: adds a section label to the current slide.  All slides
'     from the current slide to the next slide that you asssign a
'     section label to are considered to be part of the same section,
'     and will be displayed in a group.  E.g., in the example above,
'     four slides are marked with section labels: the first is marked
'     with "Intro," the fifth with "Topic 1," the ninth with "Topic 2,"
'     and the eighteenth with "Conclusions."
'
' This is the first program I've written in Visual Basic, so the code may
' not be as clean as it should be.
'
'                                License:
' =========================================================================
' Permission is hereby granted, free of charge, to any person obtaining
' a copy of this software and any associated documentation files (the
' "Software"), to deal in the Software without restriction, including
' without limitation the rights to use, copy, modify, merge, publish,
' distribute, sublicense, and/or sell copies of the Software, and to
' permit persons to whom the Software is furnished to do so, subject to
' the following conditions:
'
' The above copyright notice and this permission notice shall be included
' in all copies or substantial portions of the Software.
'
' The software is provided "as is", without warranty of any kind, express
' or implied, including but not limited to the warranties of
' merchantability, fitness for a particular purpose and noninfringement.
' In no event shall the authors or copyright holders be liable for any
' claim, damages or other liability, whether in an action of contract, tort
' or otherwise, arising from, out of or in connection with the software or
' the use or other dealings in the software.
' =========================================================================

Option Explicit

Public OptionsOk As Boolean

Type ColorType
    Red As Integer
    Green As Integer
    Blue As Integer
End Type

Type ProgressDotsOptions
    LeftMargin As Double
    RightMargin As Double
    yMargin As Double
    textHeight As Double
    dotSize As Double
    SectionGap As Double  ' = secMargin/dotMargin
    seenDotColor As ColorType
    unseenDotColor As ColorType
    seenTextColor As ColorType
    unseenTextColor As ColorType
    fontName As String
End Type

' We don't support more than 100 sections.
Type ProgressDotsSectionInfo
    startSlide As Long
    numSections As Long
    sectTitles(100) As String
    sectStart(100) As Long
End Type
Function SerializeColor(c As ColorType) As String
    SerializeColor = CStr(c.Red) & ":" & CStr(c.Green) & ":" & CStr(c.Blue)
End Function

Function DeserializeColor(s As String) As ColorType
    Dim words() As String
    words() = Split(s, ":")
    DeserializeColor.Red = CInt(words(0))
    DeserializeColor.Green = CInt(words(1))
    DeserializeColor.Blue = CInt(words(2))
End Function

Function ColorToRGB(c As ColorType) As Long
    ColorToRGB = RGB(c.Red, c.Green, c.Blue)
End Function

Function SerializeProgressOptions(theOptions As ProgressDotsOptions) As String
    With theOptions:
        SerializeProgressOptions = "version3 " & _
            .LeftMargin & " " & .RightMargin & " " & .yMargin & " " & _
            .textHeight & " " & .dotSize & " " & .SectionGap & " " & _
            SerializeColor(.seenDotColor) & " " & _
            SerializeColor(.unseenDotColor) & " " & _
            SerializeColor(.seenTextColor) & " " & _
            SerializeColor(.unseenTextColor) & " " & _
            Replace(.fontName, " ", "#")
    End With
End Function

Function DeserializeProgressOptions(s As String) As ProgressDotsOptions
    ' Split the string into words
    Dim words() As String
    words() = Split(s)

    ' Use those words to populate theOptions.
    Dim theOptions As ProgressDotsOptions
    If words(0) <> "version3" Then
        theOptions = getDefaultOptions()
    Else
        theOptions.LeftMargin = CDbl(words(1))
        theOptions.RightMargin = CDbl(words(2))
        theOptions.yMargin = CDbl(words(3))
        theOptions.textHeight = CDbl(words(4))
        theOptions.dotSize = CDbl(words(5))
        theOptions.SectionGap = CDbl(words(6))
        theOptions.seenDotColor = DeserializeColor(words(7))
        theOptions.unseenDotColor = DeserializeColor(words(8))
        theOptions.seenTextColor = DeserializeColor(words(9))
        theOptions.unseenTextColor = DeserializeColor(words(10))
        theOptions.fontName = Replace(words(11), "#", " ")
    End If

    ' Return it
    DeserializeProgressOptions = theOptions

End Function

Function getDefaultOptions() As ProgressDotsOptions

With getDefaultOptions:
    .LeftMargin = 50
    .RightMargin = 50
    .yMargin = 5
    .textHeight = 12
    .dotSize = 7.8
    .seenDotColor.Red = 0
    .seenDotColor.Green = 128
    .seenDotColor.Blue = 128
    .unseenDotColor.Red = 186
    .unseenDotColor.Green = 223
    .unseenDotColor.Blue = 226
    .seenTextColor.Red = 0
    .seenTextColor.Green = 128
    .seenTextColor.Blue = 128
    .unseenTextColor.Red = 186
    .unseenTextColor.Green = 223
    .unseenTextColor.Blue = 226
    .SectionGap = 8
    .fontName = "arial"
End With
    End Function

Sub Auto_Open()
    Dim TOOLBAR_STYLE, DEBUG_TOOLBAR
    TOOLBAR_STYLE = msoButtonIconAndCaption
    DEBUG_TOOLBAR = True

    Dim oToolbar As CommandBar
    Dim oSetSectionButton As CommandBarButton
    Dim oAddProgressButton As CommandBarButton
    Dim oDelProgressButton As CommandBarButton
    Dim oRefreshButton As CommandBarButton
    Dim oOptionsButton As CommandBarButton
    Dim MyToolbar As String

    ' Give the toolbar a name
    MyToolbar = "Progress Dots"

    On Error Resume Next
    ' so that it doesn't stop on the next line if the toolbar's already there

    ' Create the toolbar; PowerPoint will error if it already exists
    Set oToolbar = CommandBars.Add(name:=MyToolbar, _
        Position:=msoBarFloating, Temporary:=True)
    If Err.Number <> 0 Then
        If DEBUG_TOOLBAR Then
            CommandBars(MyToolbar).Delete
        End If
        ' The toolbar's already there, so we have nothing to do
        Exit Sub
    End If

    On Error GoTo ErrorHandler

    Set oSetSectionButton = oToolbar.Controls.Add(Type:=msoControlButton)
    With oSetSectionButton
         .DescriptionText = "Begin progress bar section"
         .Caption = "Section"
         .OnAction = "SetSection"
         .Style = TOOLBAR_STYLE
         .FaceId = 598
    End With

     Set oAddProgressButton = oToolbar.Controls.Add(Type:=msoControlButton)
     With oAddProgressButton
         .DescriptionText = "Add a progress bar"
         .Caption = "Create"
         .OnAction = "AddProgressBar"
         .Style = TOOLBAR_STYLE
         .FaceId = 213
    End With

    Set oDelProgressButton = oToolbar.Controls.Add(Type:=msoControlButton)
    With oDelProgressButton
         .DescriptionText = "Remove the progress bar"
         .Caption = "Delete"
         .OnAction = "DelProgressBar"
         .Style = TOOLBAR_STYLE
         .FaceId = 214
    End With

    Set oRefreshButton = oToolbar.Controls.Add(Type:=msoControlButton)
    With oRefreshButton
         .DescriptionText = "Refresh progress bar"
         .Caption = "Refresh"
         .OnAction = "RefreshProgressBar"
         .Style = TOOLBAR_STYLE
         .FaceId = 1020
    End With

    oToolbar.Top = 150
    oToolbar.Left = 150
    oToolbar.Visible = True

NormalExit:
    Exit Sub   ' so it doesn't go on to run the errorhandler code
ErrorHandler:
     'Just in case there is an error
     MsgBox Err.Number & vbCrLf & Err.Description
     Resume NormalExit:
End Sub

Sub SetSection()
    Dim curSlide As slide
    Dim strTitle As String

    ' Get the current slide.
    Set curSlide = Application.ActiveWindow.View.slide

    ' Ask for a tilte
    strTitle = InputBox("Enter a title for the section " & _
        "starting on slide " & curSlide.SlideNumber & ".", _
        "Progress Dots: Section Title", _
        curSlide.Tags.Item("progress dots title"))

    ' Store the title as a tag.
    Call curSlide.Tags.Add("progress dots title", strTitle)

End Sub

Sub optionsToForm(theOptions As ProgressDotsOptions)
    Dim sectNum As Long
    Dim sectionInfo As ProgressDotsSectionInfo

    ' Display the spacing parameters
    OptionsForm.LeftMargin.Text = CStr(theOptions.LeftMargin)
    OptionsForm.RightMargin.Text = CStr(theOptions.RightMargin)
    OptionsForm.TopMargin.Text = CStr(theOptions.yMargin)
    OptionsForm.SectionGap.Value = 10 * theOptions.SectionGap
    OptionsOk = False

    ' Display a combobox for the font.
    OptionsForm.fontName.Clear
    Call OptionsForm.fontName.AddItem("Times New Roman")
    Call OptionsForm.fontName.AddItem("Arial")
    Call OptionsForm.fontName.AddItem("Courier")
    OptionsForm.fontName.Value = theOptions.fontName
    OptionsForm.fontSize.Value = CStr(theOptions.textHeight)

    ' Display the colors
    OptionsForm.dotSeenR.Value = theOptions.seenDotColor.Red
    OptionsForm.dotSeenG.Value = theOptions.seenDotColor.Green
    OptionsForm.dotSeenB.Value = theOptions.seenDotColor.Blue
    OptionsForm.dotUnseenR.Value = theOptions.unseenDotColor.Red
    OptionsForm.dotUnseenG.Value = theOptions.unseenDotColor.Green
    OptionsForm.dotUnseenB.Value = theOptions.unseenDotColor.Blue
    OptionsForm.textSeenR.Value = theOptions.seenTextColor.Red
    OptionsForm.textSeenG.Value = theOptions.seenTextColor.Green
    OptionsForm.textSeenB.Value = theOptions.seenTextColor.Blue
    OptionsForm.textUnseenR.Value = theOptions.unseenTextColor.Red
    OptionsForm.textUnseenG.Value = theOptions.unseenTextColor.Green
    OptionsForm.textUnseenB.Value = theOptions.unseenTextColor.Blue
    OptionsForm.dotSize.Value = theOptions.dotSize * 5

    ' Display the list of sections.
    sectionInfo = findSections()
    OptionsForm.SectionList.Clear
    For sectNum = 1 To sectionInfo.numSections
        Call OptionsForm.SectionList.AddItem( _
        CStr(sectionInfo.sectStart(sectNum)) & ": " & _
        sectionInfo.sectTitles(sectNum))
    Next sectNum

End Sub

Function optionsFromForm() As ProgressDotsOptions
    optionsFromForm = getDefaultOptions()
    ' Copy the user input back to the options structure.
    optionsFromForm.LeftMargin = CDbl(OptionsForm.LeftMargin.Text)
    optionsFromForm.RightMargin = CDbl(OptionsForm.RightMargin.Text)
    optionsFromForm.yMargin = CDbl(OptionsForm.TopMargin.Text)
    optionsFromForm.SectionGap = OptionsForm.SectionGap.Value * 0.1
    optionsFromForm.fontName = OptionsForm.fontName.Value
    optionsFromForm.textHeight = CInt(OptionsForm.fontSize.Value)
    optionsFromForm.seenDotColor.Red = CInt(OptionsForm.dotSeenR.Value)
    optionsFromForm.seenDotColor.Green = CInt(OptionsForm.dotSeenG.Value)
    optionsFromForm.seenDotColor.Blue = CInt(OptionsForm.dotSeenB.Value)
    optionsFromForm.unseenDotColor.Red = CInt(OptionsForm.dotUnseenR.Value)
    optionsFromForm.unseenDotColor.Green = CInt(OptionsForm.dotUnseenG.Value)
    optionsFromForm.unseenDotColor.Blue = CInt(OptionsForm.dotUnseenB.Value)
    optionsFromForm.seenTextColor.Red = CInt(OptionsForm.textSeenR.Value)
    optionsFromForm.seenTextColor.Green = CInt(OptionsForm.textSeenG.Value)
    optionsFromForm.seenTextColor.Blue = CInt(OptionsForm.textSeenB.Value)
    optionsFromForm.unseenTextColor.Red = CInt(OptionsForm.textUnseenR.Value)
    optionsFromForm.unseenTextColor.Green = CInt(OptionsForm.textUnseenG.Value)
    optionsFromForm.unseenTextColor.Blue = CInt(OptionsForm.textUnseenB.Value)
    optionsFromForm.dotSize = OptionsForm.dotSize.Value * 0.2
End Function

Sub customizeOptions()
    Dim s As String
    Dim theOptions As ProgressDotsOptions
    Dim thePresentation As Presentation

    ' Load the options.
    Set thePresentation = ActivePresentation
    s = thePresentation.Tags.Item("__progress-dots-config__")
    If s = "" Then s = SerializeProgressOptions(getDefaultOptions())
    theOptions = DeserializeProgressOptions(s)

    ' Copy them to the form
    Call optionsToForm(theOptions)

    ' Show the form.
    OptionsForm.Show

    ' Save the options
    If OptionsOk Then
        theOptions = optionsFromForm()
        Debug.Print "Saving options..."
        s = SerializeProgressOptions(theOptions)
        Call thePresentation.Tags.Add("__progress-dots-config__", s)
    End If
End Sub



Sub AddProgressBar()
    ' make sure there's something to do.
    If ActivePresentation.Slides.Count = 1 Then
        MsgBox ("Add some more slides first")
        Exit Sub
    End If
    ' Set options.
    Call customizeOptions
    ' If everything went well, draw the progress bar.
    If OptionsOk Then
        Call RefreshProgressBar
    End If
End Sub


Sub RefreshProgressBar()
    Dim s As String
    Dim theOptions As ProgressDotsOptions

    If ActivePresentation.Slides.Count = 1 Then
        MsgBox ("Add some more slides first")
        Exit Sub
    End If

    ' Load the options.
    s = ActivePresentation.Tags.Item("__progress-dots-config__")
    If s = "" Then s = SerializeProgressOptions(getDefaultOptions())
    theOptions = DeserializeProgressOptions(s)

    ' Update the progress bar.
    Call DelProgressBar
    Call MakeProgressBar(theOptions)
End Sub

Function findSections() As ProgressDotsSectionInfo
    Dim slideNum, sectionNum As Long
    Dim curTitle As String

    ' Initialize the 0th group.
    findSections.sectTitles(0) = ""
    findSections.sectStart(0) = 1

    ' Scan for section titles.
    sectionNum = 0
    Debug.Print "Scanning for sections..."
    For slideNum = 1 To ActivePresentation.Slides.Count
        curTitle = ActivePresentation.Slides(slideNum).Tags.Item("progress dots title")
        If (curTitle <> "") Then
            sectionNum = sectionNum + 1
            findSections.sectTitles(sectionNum) = curTitle
            findSections.sectStart(sectionNum) = slideNum
            If sectionNum = 1 Then findSections.startSlide = slideNum
        End If
    Next slideNum

    ' If no sections were found, make a single "fake" section
    If sectionNum = 0 And ActivePresentation.Slides.Count > 1 Then
        sectionNum = 1
        findSections.sectTitles(1) = ""
        findSections.sectStart(1) = 2
        findSections.startSlide = 2
    End If

    ' Record the end slide as the "next" section start -- this makes
    ' calculations easier.
    findSections.sectStart(sectionNum + 1) = _
        ActivePresentation.Slides.Count + 1

    ' Return the information we found.
    findSections.numSections = sectionNum

End Function


Sub MakeProgressBar(theOptions As ProgressDotsOptions)
    Dim sectinfo As ProgressDotsSectionInfo
    Dim slideNum As Long

    ' Scan for sections.
    sectinfo = findSections()

    ' If we didn't find any sections, there's nothing more to do.
    If sectinfo.numSections = 0 Then
        MsgBox ("Add some more slides first!")
        Exit Sub
    End If

    ' Loop through slides, and draw a progress bar on each one.
    Debug.Print "Drawing Progress bars..."
    For slideNum = sectinfo.startSlide To ActivePresentation.Slides.Count
        Debug.Print "  Slide " & slideNum
        Call DrawProgressBarOnSlide(slideNum, sectinfo, _
                theOptions, "__progress-dots__")
    Next slideNum
End Sub

Sub DrawProgressBarOnSlide(slideNum As Long, _
        sectinfo As ProgressDotsSectionInfo, _
        theOptions As ProgressDotsOptions, _
        shapeTag As String)
    Dim x, labelWidth, labelLeft, sectionMargin, dotMargin As Double
    Dim numDotsInSection, dotNum, sectNum, numDots As Long
    Dim dot, sectTitle As Shape
    Dim slideWidth, gapSize As Double
    Dim firstShape As Long

    ' Record the index of the first shape we'll be creating.  We'll use this
    ' later to select the whole range of shapes & group them.
    firstShape = ActivePresentation.Slides(slideNum).Shapes.Count + 1

    ' Calculate dotMargin & sectionMargin, which are used to layout the
    ' dots & section titles.
    numDots = ActivePresentation.Slides.Count - sectinfo.startSlide + 1
    slideWidth = ActivePresentation.PageSetup.slideWidth
    gapSize = (slideWidth - theOptions.LeftMargin - theOptions.RightMargin _
                     - theOptions.dotSize * numDots)
    If sectinfo.numSections = 1 Or numDots = sectinfo.numSections Then
        If sectinfo.numSections = 1 And numDots = sectinfo.numSections Then
            dotMargin = 0
            sectionMargin = 0
        Else
            dotMargin = gapSize / (numDots - 1)
            sectionMargin = dotMargin
        End If
    Else
        sectionMargin = gapSize / _
            ((numDots - sectinfo.numSections) / theOptions.SectionGap + _
               (sectinfo.numSections - 1))
        dotMargin = sectionMargin / theOptions.SectionGap
    End If

    x = theOptions.LeftMargin   ' our current x position.
    sectNum = 1                 ' our current section num

    ' Loop through the slides, and draw a dot for each one.
    For dotNum = sectinfo.startSlide To ActivePresentation.Slides.Count

        ' Draw the dot.
        Set dot = ActivePresentation.Slides(slideNum).Shapes.AddShape( _
            msoShapeOval, x, _
            theOptions.yMargin + theOptions.textHeight + 2, _
            theOptions.dotSize, theOptions.dotSize)
        Call dot.Tags.Add(shapeTag, "yes")
        ' Color the dot.
        If dotNum <= slideNum Then
            dot.Fill.ForeColor.RGB = ColorToRGB(theOptions.seenDotColor)
            dot.Line.ForeColor.RGB = ColorToRGB(theOptions.seenDotColor)
        Else
            dot.Fill.ForeColor.RGB = ColorToRGB(theOptions.unseenDotColor)
            dot.Line.ForeColor.RGB = ColorToRGB(theOptions.unseenDotColor)
        End If

        ' If this dot starts a section, then draw the section title.
        If sectinfo.sectStart(sectNum) = dotNum Then
            numDotsInSection = (sectinfo.sectStart(sectNum + 1) - dotNum)
            labelWidth = numDotsInSection * theOptions.dotSize + _
                         (numDotsInSection - 1) * dotMargin
            labelLeft = x
            ' Add some extra space
            labelWidth = labelWidth + 400
            labelLeft = labelLeft - 200
            ' But don't fall off either edge.
            If labelLeft < 0 Then
                labelWidth = labelWidth + labelLeft * 2
                labelLeft = 0
            End If
            If labelWidth + labelLeft > slideWidth Then
                labelWidth = labelWidth + (slideWidth - labelLeft - labelWidth) * 2
                labelLeft = slideWidth - labelWidth
            End If

            Set sectTitle = ActivePresentation.Slides(slideNum). _
               Shapes.AddTextbox(msoTextOrientationHorizontal, _
               labelLeft, theOptions.yMargin, labelWidth, _
               theOptions.textHeight + 10)
            Call sectTitle.Tags.Add(shapeTag, "yes")
            ' Style the section title.
            With sectTitle.TextFrame
                .TextRange.Text = sectinfo.sectTitles(sectNum)
                .TextRange.Font.Size = theOptions.textHeight
                .TextRange.Font.name = theOptions.fontName
                .HorizontalAnchor = msoAnchorCenter
                .MarginBottom = 0
                .MarginTop = 0
                .MarginLeft = 0
                .MarginRight = 0
                If dotNum <= slideNum Then
                    .TextRange.Font.Color = ColorToRGB(theOptions.seenTextColor)
                Else
                    .TextRange.Font.Color = ColorToRGB(theOptions.unseenTextColor)
                End If
            End With

            ' Update our section counter
            sectNum = sectNum + 1
        End If

        ' Update our x position.
        If sectinfo.sectStart(sectNum) = dotNum + 1 Then
            x = x + sectionMargin + theOptions.dotSize
        Else
            x = x + dotMargin + theOptions.dotSize
        End If

    Next dotNum

    ' Group all the new shapes.
    Dim numShapes, i As Long
    Dim oShapeArray() As Long
    Dim oGroupShape As Shape
    numShapes = ActivePresentation.Slides(slideNum).Shapes.Count - firstShape + 1
    If numShapes > 1 Then
        ReDim oShapeArray(numShapes)
        For i = 0 To numShapes - 1
            oShapeArray(i) = firstShape + i
        Next i
        Set oGroupShape = ActivePresentation.Slides(slideNum). _
                            Shapes.Range(oShapeArray).Group
        Call oGroupShape.Tags.Add(shapeTag, "yes")
    End If
    ' Testing:
    'Dim oShapeArray(500) As Long
    'Dim iShapeCount As Integer

    'Dim z As ShapeRange
    'Dim ss As slide
    'Set ss = ActivePresentation.Slides(slideNum)
    'Set z = ss.Shapes.Range(oShapeArray)
    'z.Group

    ' Group it all together, and deselect it.
    'If Application.ActiveWindow.Selection.ShapeRange.Count > 1 Then
    '    oGroupShape = Application.ActiveWindow.Selection.ShapeRange.Group
    '    Call oGroupShape.Tags.Add(shapeTag, "yes")
    'End If
    'Application.ActiveWindow.Selection.Unselect

End Sub


Sub DelProgressBar()
    Dim slideNum As Long
    Debug.Print "Deleting old progress bar..."
    For slideNum = 1 To ActivePresentation.Slides.Count
        Call DelProgressBarOnSlide(slideNum, "__progress-dots__")
    Next slideNum
End Sub

Sub DelProgressBarOnSlide(slideNum As Long, shapeTag As String)
    Dim shapeNum As Long
    shapeNum = 1
    Do While shapeNum <= ActivePresentation.Slides(slideNum).Shapes.Count
        If ActivePresentation.Slides(slideNum).Shapes(shapeNum). _
                    Tags.Item(shapeTag) = "yes" Then
            ActivePresentation.Slides(slideNum).Shapes(shapeNum).Delete
        Else
            shapeNum = shapeNum + 1
        End If
    Loop
End Sub



Sub PreviewProgressBar(theOptions As ProgressDotsOptions)
    Dim curSlide As slide
    Dim sectinfo As ProgressDotsSectionInfo


    Set curSlide = Application.ActiveWindow.View.slide
    sectinfo = findSections()

    ' Delete any progress bar on this slide.
    Call DelProgressBarOnSlide(curSlide.SlideNumber, "__progress-dots__")

    ' Draw the new one.
    Call DrawProgressBarOnSlide(curSlide.SlideNumber, sectinfo, theOptions, _
            "__progress-dots__")
End Sub