'Option Explicit
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal _
  lpClassName As String, ByVal lpWindowName As String) As Long
Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) _
As Long
Declare PtrSafe Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As Long
 
Declare PtrSafe Function ChooseColor Lib "comdlg32.dll" _
  Alias "ChooseColorA" ( _
  lpcc As CHOOSECOLOR_TYPE) As Long
 
Private Type CHOOSECOLOR_TYPE
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  rgbResult As Long
  lpCustColors As Long
  flags As Long
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type
 
' Anwender kann alle Farben wählen
Private Const CC_ANYCOLOR = &H100
' Nachrichten können "abgefangen" werden
Private Const CC_ENABLEHOOK = &H10
' Dialogbox Template
Private Const CC_ENABLETEMPLATE = &H20
' Benutzt Template, ignoriert aber den Template-Namen
Private Const CC_ENABLETEMPLATEHANDLE = &H40
' Vollauswahl aller Farben anzeigen
Private Const CC_FULLOPEN = &H2
' Deaktiviert den Button zum Öffnen der Dialogbox-Erweiterung
Private Const CC_PREVENTFULLOPEN = &H4
' Vorgabe einer Standard-Farbe
Private Const CC_RGBINIT = &H1
' Hilfe-Button anzeigen
Private Const CC_SHOWHELP = &H8
' nur Grundfarben auswählbar
Private Const CC_SOLIDCOLOR = &H80

Sub Example_ScreenUpdating()
  ScreenUpdating(FindWindowHandle(Application)) = True 'or False
End Sub
 
Property Let ScreenUpdating(Optional ByVal hWnd As Long, ByVal State As Boolean)
  If Not State Then
    LockWindowUpdate hWnd
  Else
    LockWindowUpdate False
    UpdateWindow hWnd
  End If
End Property
 
 
 
Function FindWindowHandle(ByVal App As Object, Optional ByVal Caption As _
  String) As Long
  If App Is Nothing Then
    FindWindowHandle = FindWindow(vbNullString, Caption)
  Else
    On Error Resume Next
    Select Case App.Name
      Case "Microsoft Access"
        'Caption = App.Name
        FindWindowHandle = FindWindow("OMAIN", Caption)
      Case "Microsoft Excel"
        'Caption = App.Caption
        FindWindowHandle = FindWindow("XLMAIN", Caption)
      Case "Microsoft PowerPoint"
        Select Case Val(Application.Version)
          Case 8
            FindWindowHandle = FindWindow("PP97FrameClass", Caption)
          Case 9 To 12
            'Caption = App.Caption & " - [" & App.ActiveWindow.Caption & "]"
            FindWindowHandle = FindWindow("PP" & Val(Application.Version) & _
              "FrameClass", _
              Caption)
          Case Else
            'Caption = App.Caption
            FindWindowHandle = FindWindow("PPTFrameClass", Caption)
        End Select
      Case "Microsoft Word"
        'Caption = App.ActiveWindow.Caption & " - " & App.Caption
        FindWindowHandle = FindWindow("OPUSAPP", Caption)
      Case "Outlook"
        'Caption = Application.ActiveExplorer.Caption
        FindWindowHandle = FindWindow("rctrl_renwnd32", Caption)
      Case Else
        'Userform
        'Caption = App.Caption
        If Val(Application.Version) >= 9 Then
          FindWindowHandle = FindWindow("ThunderDFrame", Caption)
        Else
          FindWindowHandle = FindWindow("ThunderXFrame", Caption)
        End If
    End Select
  End If
End Function

Sub Auto_Open()
    Dim oToolbar As CommandBar
    Dim oButton As CommandBarButton
    Dim MyToolbar As String
 
    ' Give the toolbar a name
    MyToolbar = "Progress Addin"
 
    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
          ' The toolbar's already there, so we have nothing to do
          Exit Sub
    End If
 
    On Error GoTo ErrorHandler
 
    ' Now add a button to the new toolbar
    Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
 
    ' And set some of the button's properties
    With oButton
         .DescriptionText = "Add Progress Bar"
          'Tooltip text when mouse if placed over button
         .Caption = "AddDetailedProgressBar"
         'Text if Text in Icon is chosen
         .OnAction = "AddDetailedProgressBar"
          'Runs the Sub Button1() code when clicked
         .Style = msoButtonIcon
          ' Button displays as icon, not text or both
         .FaceId = 35
          '52 is my favorite pig;
          ' chooses icon #52 from the available Office icons
    End With
 
    ' Now add a button to the new toolbar
    Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
 
    ' And set some of the button's properties
    With oButton
         .DescriptionText = "Remove Progress Bar"
          'Tooltip text when mouse if placed over button
         .Caption = "RemoveDetailedProgressBar"
         'Text if Text in Icon is chosen
         .OnAction = "RemoveDetailedProgressBar"
          'Runs the Sub Button1() code when clicked
         .Style = msoButtonIcon
          ' Button displays as icon, not text or both
         .FaceId = 67
          '52 is my favorite pig;
          ' chooses icon #52 from the available Office icons
    End With
 
' Now add a button to the new toolbar
    Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
 
    ' And set some of the button's properties
    With oButton
         .DescriptionText = "Add Section"
          'Tooltip text when mouse if placed over button
         .Caption = "AddSection"
         'Text if Text in Icon is chosen
         .OnAction = "AddSection"
          'Runs the Sub Button1() code when clicked
         .Style = msoButtonIcon
          ' Button displays as icon, not text or both
         .FaceId = 137
          '52 is my favorite pig;
          ' chooses icon #52 from the available Office icons
    End With

' Now add a button to the new toolbar
    Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
 
    ' And set some of the button's properties
    With oButton
         .DescriptionText = "Remove Section"
          'Tooltip text when mouse if placed over button
         .Caption = "RemoveSection"
         'Text if Text in Icon is chosen
         .OnAction = "RemoveSection"
          'Runs the Sub Button1() code when clicked
         .Style = msoButtonIcon
          ' Button displays as icon, not text or both
         .FaceId = 138
          '52 is my favorite pig;
          ' chooses icon #52 from the available Office icons
    End With
 
 
 
' Now add a button to the new toolbar
    Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
 
    ' And set some of the button's properties
    With oButton
         .DescriptionText = "Add Ignore Slide"
          'Tooltip text when mouse if placed over button
         .Caption = "AddIgnoreSlide"
         'Text if Text in Icon is chosen
         .OnAction = "AddIgnoreSlide"
          'Runs the Sub Button1() code when clicked
         .Style = msoButtonIcon
          ' Button displays as icon, not text or both
         .FaceId = 214
          '52 is my favorite pig;
          ' chooses icon #52 from the available Office icons
    End With
 
 
 
    ' Now add a button to the new toolbar
    Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
 
    ' And set some of the button's properties
    With oButton
         .DescriptionText = "Remove Ignore Slide"
          'Tooltip text when mouse if placed over button
         .Caption = "RemoveIgnoreSlide"
         'Text if Text in Icon is chosen
         .OnAction = "RemoveIgnoreSlide"
          'Runs the Sub Button1() code when clicked
         .Style = msoButtonIcon
          ' Button displays as icon, not text or both
         .FaceId = 213
          '52 is my favorite pig;
          ' chooses icon #52 from the available Office icons
    End With
 
 
    ' Now add a button to the new toolbar
    Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
     ' And set some of the button's properties
    With oButton
         .DescriptionText = "Clear Structure"
          'Tooltip text when mouse if placed over button
         .Caption = "Delete old structure"
         'Text if Text in Icon is chosen
         .OnAction = "ClearOldStructure"
          'Runs the Sub Button1() code when clicked
         .Style = msoButtonIcon
          ' Button displays as icon, not text or both
         .FaceId = 215
          '52 is my favorite pig;
          ' chooses icon #52 from the available Office icons
    End With
 
 
        ' Now add a button to the new toolbar
    Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
     ' And set some of the button's properties
    With oButton
         .DescriptionText = "Show Settings Dialog"
          'Tooltip text when mouse if placed over button
         .Caption = "Show Settings"
         'Text if Text in Icon is chosen
         .OnAction = "showSettingDialog"
          'Runs the Sub Button1() code when clicked
         .Style = msoButtonIcon
          ' Button displays as icon, not text or both
         .FaceId = 44
          '52 is my favorite pig;
          ' chooses icon #52 from the available Office icons
    End With
 
 
        ' Now add a button to the new toolbar
    Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
     ' And set some of the button's properties
    With oButton
         .DescriptionText = "Show Info Dialog"
          'Tooltip text when mouse if placed over button
         .Caption = "Show Info"
         'Text if Text in Icon is chosen
         .OnAction = "showInfoDialog"
          'Runs the Sub Button1() code when clicked
         .Style = msoButtonIcon
          ' Button displays as icon, not text or both
         .FaceId = 124
          '52 is my favorite pig;
          ' chooses icon #52 from the available Office icons
    End With
 
    ' Repeat the above for as many more buttons as you need to add
    ' Be sure to change the .OnAction property at least for each new button
 
    ' You can set the toolbar position and visibility here if you like
    ' By default, it'll be visible when created
    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 showSettingDialog()
 
    settingsForm.Show
 
End Sub
 
Sub showInfoDialog()
 
    helpForm.Show
 
End Sub
 
 
 
Sub AddSection()
    On Error Resume Next
    Dim presentation As Object
    Dim s As PowerPoint.Shape
    presentation = Application.ActivePresentation
 
    Set s = Application.ActiveWindow.Selection.SlideRange.Shapes.AddShape( _
      msoShapeRectangle, 10, 10, 10, 10)
    s.Name = "section"
    s.Visible = False
 
    Application.ActiveWindow.Selection.SlideRange.Comments.Add 0, 0, "", "", _
      "Section"
 
 
End Sub
 
Sub AddIgnoreSlide()
    On Error Resume Next
    Dim presentation As Object
    Dim s As PowerPoint.Shape
    presentation = Application.ActivePresentation
 
    Application.ActiveWindow.Selection.SlideRange.NotesPage.Tags.Add "Ignore", _
      "True"
    Set s = Application.ActiveWindow.Selection.SlideRange.Shapes.AddShape( _
    msoShapeRectangle, 10, 10, 10, 10)
    s.Name = "ignore"
    s.Visible = False
 
    Application.ActiveWindow.Selection.SlideRange.Comments.Add 0, 0, "", "", _
      "Ignore"
End Sub
 
 
Sub RemoveSection()
    On Error Resume Next
    Dim currentSlide As slide
    'Dim currSlideNum As Integer
 
    'currSlideNum = ActiveWindow.View.Slide.SlideIndex
    'Set currentSlide = ActiveWindow.Selection.SlideRange.Item(currSlideNum)
    'Set currentSlide = ActivePresentation.Slides(currSlideNum)
 
 
    Set currentSlide = ActivePresentation.Slides(ActiveWindow.View.slide.Name)
 
 
 
    With currentSlide
        .Shapes("section").Delete
        .Comments.Item(1).Delete
    End With
End Sub
 
Sub RemoveIgnoreSlide()
   On Error Resume Next
    Dim currentSlide As slide
 
    Set currentSlide = ActivePresentation.Slides(ActiveWindow.View.slide.Name)
 
    With currentSlide
        .Shapes("ignore").Delete
        .Comments.Item(1).Delete
    End With
End Sub

Sub AddDetailedProgressBar()
 
    ScreenUpdating(FindWindowHandle(Application)) = False
    RemoveDetailedProgressBar
 
 
    On Error Resume Next
    Dim presentation As PowerPoint.presentation
    Dim s As PowerPoint.Shape
    Set presentation = Application.ActivePresentation
    Dim counter As Integer: counter = 0
    Dim slide As slide
 
 
    Dim X As Integer: X = 0
    Dim initialTop As Integer: initialTop = 0
    Dim initialLeft As Integer: initialLeft = 0
    Dim bulletCounter As Integer: bulletCounter = 0
    Dim Count As Integer: Count = 0
 
 
    Dim sectionCounter As Integer: sectionCounter = 0
    Dim slidesPerSection As Integer: slidesPerSection = 0
    Dim numberOfSections As Integer: numberOfSections = 0
    Dim sectionLength As Variant: sectionLength = 0
 
    Dim mySections() As Integer
    Dim sectionSlides() As Integer
    ReDim Preserve mySections(0 To 1)
    ReDim Preserve sectionSlides(0 To 1)
 
 
    ' Determine structure of slide set
    With presentation
        For X = 1 To .Slides.Count
            Dim notHidden As Boolean
            notHidden = Not .Slides(X).SlideShowTransition.Hidden
 
            Dim notIgnored As Boolean
 
 
            If .Slides(X).NotesPage.Tags.Count = 0 Then
                notIgnored = True
            Else
                notIgnored = False
            End If
 
 
 
            If notHidden And notIgnored Then
                'get slide numbers
                ReDim Preserve sectionSlides(0 To (UBound(sectionSlides) + 1))
 
                sectionSlides(counter) = .Slides(X).slideNumber
 
 
                counter = counter + 1
                If IsNull(.Slides(X).Shapes("section")) Then
                    mySections(sectionCounter) = mySections(sectionCounter) + 1
                Else
                    ReDim Preserve mySections(0 To (UBound(mySections) + 1))
                    sectionCounter = sectionCounter + 1
                    mySections(sectionCounter) = 1
                End If
 
            End If
        Next X
    End With

'load from settings
    Dim left As Integer: left = CInt(GetSetting(appname:="PogressBar", _
      Section:="PosPogressBar", Key:="leftPos"))
    Dim top As Integer: top = presentation.PageSetup.SlideHeight - CInt( _
    GetSetting(appname:="PogressBar", Section:="PosPogressBar", Key:="topPos"))
    Dim sizeOfBullet As Integer: sizeOfBullet = CInt(GetSetting( _
    appname:="PogressBar", Section:="PosPogressBar", Key:="sizeOfBullet"))
    Dim spaceBetweenBullets As Integer: spaceBetweenBullets = CInt(GetSetting( _
    appname:="PogressBar", Section:="PosPogressBar", _
    Key:="spaceBetweenBullets"))
    Dim maxleft As Integer: maxleft = CInt(GetSetting(appname:="PogressBar", _
    Section:="PosPogressBar", Key:="wraparound"))
    Dim wraparoundoffset As Integer: wraparoundoffset = CInt(GetSetting( _
    appname:="PogressBar", Section:="PosPogressBar", Key:="wraparoundlimit"))
    Dim colorRed As Integer: colorRed = CInt(GetSetting(appname:="PogressBar", _
    Section:="PosPogressBar", Key:="colorRed"))
    Dim colorYellow As Integer: colorYellow = CInt(GetSetting( _
    appname:="PogressBar", Section:="PosPogressBar", Key:="colorYellow"))
    Dim colorBlue As Integer: colorBlue = CInt(GetSetting( _
    appname:="PogressBar", Section:="PosPogressBar", Key:="colorBlue"))
    Dim vertical As Boolean: vertical = CBool(GetSetting(appname:="PogressBar", _
    Section:="PosPogressBar", Key:="OptionVertical"))
 
 
 
    'init if fields are null
    If IsNull(left) Then
        left = 20
    End If
 
    'init if fields are null
    If IsNull(maxleft) Then
        left = 500
    End If
 
    If IsNull(top) Then
        top = 50
    End If
 
    If IsNull(sizeOfBullet) Then
        sizeOfBullet = 6
    End If
 
    If IsNull(spaceBetweenBullets) Then
        spaceBetweenBullets = 8
    End If
 
    'init if fields are null
    If IsNull(wraparoundoffset) Then
        wraparoundoffset = 2 * sizeOfBullet
    End If
 
    initialLeft = left
    initialTop = top
 
 
 
    With presentation
        Dim currentSlideNumber As Integer: currentSlideNumber = 0
 
        For Each slide In .Slides
 
            'bullet counter needed to do wrap arround
            bulletCounter = 0
            left = initialLeft
            top = initialTop
 
            Dim slideNumber As Integer: slideNumber = 0
 
            'Dim notHidden As Boolean: notHidden = 
            ' Slide.SlideShowTransition.Hidden = 
            ' Microsoft.Office.Core.MsoTriState.msoFalse
            notHidden = Not slide.SlideShowTransition.Hidden
            'Dim notIgnored As Boolean
 
            notIgnored = True
 
            If slide.NotesPage.Tags.Count = 0 Then
                notIgnored = True
            Else
                notIgnored = False
            End If
 
            If notHidden And notIgnored Then
 
                For Each sectionLength In mySections
 
                    If vertical Then
                        If top > maxleft Then
                            left = left + wraparoundoffset
                            top = initialLeft
                        End If
                    Else
                        If left > maxleft Then
                            top = top + wraparoundoffset
                            left = initialLeft
                        End If
                    End If

  For Count = 1 To sectionLength
                        bulletCounter = bulletCounter + 1
                        Set s = slide.Shapes.AddShape(msoShapeOval, left, top, _
                          sizeOfBullet, sizeOfBullet)
                        s.Name = "PB_" & CStr(slideNumber)
 
                         If currentSlideNumber = slideNumber Then
                            s.Fill.ForeColor.RGB = RGB(colorRed, colorYellow, _
                              colorBlue)
                            s.Line.ForeColor.RGB = RGB(colorRed, colorYellow, _
                            colorBlue)
                        Else
                            s.Fill.ForeColor.RGB = RGB(220, 220, 220)
                            s.Line.ForeColor.RGB = RGB(150, 150, 150)
                        End If
                        With s.ActionSettings(ppMouseClick)
                            .Action = ppActionNamedSlideShow
                            With .Hyperlink
                                '.Address = 
                                ' Me.Application.ActivePresentation.FullName
                                .SubAddress = CStr(sectionSlides(slideNumber))
                                .Follow
                            End With
                        End With
                        slideNumber = slideNumber + 1
                        If vertical Then
                            top = top + spaceBetweenBullets
                        Else
                            left = left + spaceBetweenBullets
                        End If
                    Next Count
 
                    If vertical Then
                        top = top + spaceBetweenBullets
                    Else
                        left = left + spaceBetweenBullets
                    End If
 
 
                Next sectionLength
                'slide.Shapes("PB").Delete()
                currentSlideNumber = currentSlideNumber + 1
            End If
        Next
    End With
 
    ScreenUpdating(FindWindowHandle(Application)) = True
 
End Sub
 
 
Sub RemoveDetailedProgressBar()
 
    Dim presentation As PowerPoint.presentation
    Set presentation = Application.ActivePresentation
    Dim X As Integer: X = 0
 
    Dim slide As slide
 
    With presentation
        For Each slide In .Slides
            For X = 0 To slide.Shapes.Count
                On Error Resume Next
                'Debug.Print slide.Shapes.Count
                Debug.Print slide.Shapes(X).Name
                slide.Shapes("PB_" & CStr(X)).Delete
            Next
        Next
    End With
End Sub

Sub ClearOldStructure()
 
    Dim presentation As PowerPoint.presentation
    Set presentation = Application.ActivePresentation
 
    Dim slide As slide
 
    With presentation
        For Each slide In .Slides
            On Error Resume Next
            With slide
                .Shapes("ignore").Delete
                .Comments.Item(1).Delete
                .Shapes("section").Delete
                .Comments.Item(1).Delete
            End With
 
            For X = 0 To slide.Shapes.Count
                On Error Resume Next
                slide.Shapes("PB_" & CStr(X)).Delete
            Next
        Next
    End With
End Sub
 
Sub ShowFaceIDs()
    Dim NewToolbar As CommandBar
    Dim NewButton As CommandBarButton
    Dim i As Integer, IDStart As Integer, IDStop As Integer
 
'   Delete existing FaceIds toolbar if it exists
    On Error Resume Next
    Application.CommandBars("FaceIds").Delete
    On Error GoTo 0
 
'   Add an empty toolbar
    Set NewToolbar = Application.CommandBars.Add _
        (Name:="FaceIds", temporary:=True)
    NewToolbar.Visible = True
 
'   Change the following values to see different FaceIDs
    IDStart = 1
    IDStop = 250
 
    For i = IDStart To IDStop
        'Set NewButton = NewToolbar.Add(Type:=msoControlButton, Id:=2950)
        Set NewButton = NewToolbar.Controls.Add(Type:=msoControlButton)
        NewButton.FaceId = i
        NewButton.Caption = "FaceID = " & i
    Next i
    NewToolbar.Width = 600
End Sub

Dim left As Integer
left = CInt(GetSetting(appname:="PogressBar", Section:="PosPogressBar", _
Key:="leftPos", Default:= "1000"))