'############################################################
'#
'#
'#      |*-----------------------------------*|
'#      ||       POWERPOINT MACROS           ||
'#      |*-----------------------------------*|
'#                      Last modified: 24/04/06
'#                 by Andrew Noske
'#           (http://www.andrewnoske.com/)
'#
'#
'# INSTRUCTIONS (HOW TO USE THESE MACROS):
'#
'#  1) Open MS Word, then go:
'#      Tools >> Macro >> Visual Basic Editor  (or press Alt+F11)
'#  2) On the right hand side, right click "Normal", then click:
'#      Insert >> Module.
'#  3) Cut-and-paste the entire text contents of this file into the
'#     new "module".
'#     *OR*    If you save this as a .bas file you can right
'#             click "Normal" and click "Inport File" and locate
'#             this file  (in place of steps 2 and 3)
'#  4) Minimize the Visual Basic window, and in Word go:
'#      Tools >> Macro >> Macros (or press Alt-F8)
'#  5) Here you can hopefully see new macros have been added.
'#  6) From this menu you can run them, edit them etc.... so
'#      have a play around, and see how they work.
'#
'#  Next time you want to use one of these Macros, press Alt+F8
'#  and double click the one you want.  :)
'#
'#
'# WHAT ARE MACROS?:
'#
'#  Macros are little scripts written in Visual Basic, which you can
'#  record or write yourself to help automate repeative tasks in
'#  the common MS Office applications.
'#
'#  Macros are great, because, you'll often find yourself performing
'#  the same sequences of operations again and again in computing,
'#  and Macros can save you time, but letting you press a short-cut,
'#  then executing these steps for you.
'#
'#  Visual Basic is a babish language, and often won't work the way
'#  you want, but it's worth learning a BIT, just for the sake
'#  of learning how to use Macros. Macros can potentially save you
'#  HOURS and hours (expecially Excel Macros I've found), and I
'#  recommend all computer students learn a little about them.
'#  Identifying what task you should use macros for is half the challenge.
'#
'#
'# WHAT IS THIS FILE FOR:
'#
'#  This file contains some simple Macros for Microsoft PowerPoint
'#  I wrote for a few common tasks I've encountered:
'#  generating a progress bar (to show users how long the talk goes) and
'#  deleting all audio (useful if you want to delete narration)
'#  I MAY ADD MORE LATER - can't think of anything else yet
'#
'#  Even if you don't use these Macros they might help you understand
'#  how to write your own Macros (although usually it's easier
'#  to select the record Macro option) for all those common tasks
'#  you have to repeat.
'#
'############################################################


'-------------------------------------------
Sub BAR_GenerateProgressBar()
'
' Generates a progress bar showing how far through the presentation you are.
' NOTE: To change the color of the bar, or its size and position you will have to edit the code.
'
    Const BAR_X = 5
    Const BAR_Y = 5
    Const BAR_WIDTH = 100
    Const BAR_HEIGHT = 10
    Const BAR_BORDER = 2
    
    Dim width, numSlides As Integer
    
    BAR_DeleteProgressBar     'Delete last generated progress bar
    
    '## GET USER INPUT
    numSlides = InputBox("Enter number of slides or enter '0' for all slides", "INPUT")
    On Error GoTo noinput
noinput:
    If Err <> 0 Then
       MsgBox "You must enter a valid number > 0!"
       Exit Sub
    End If
    
    If numSlides = 0 Then
        numSlides = ActivePresentation.slideS.Count
    End If
    
    '## ADD PROGRESS BAR TO ALL SLIDE
    For Each oSlide In ActivePresentation.slideS        ' Iterate through each slide in the presentation
        
        oSlide.Select
        
        If (CInt(oSlide.slideNumber) > CInt(numSlides)) Then
            Exit Sub
        End If
        
        '## DRAW BACKGROUND RECTANGLE:
        ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, BAR_X, BAR_Y, BAR_WIDTH + BAR_BORDER * 2, BAR_HEIGHT + BAR_BORDER * 2).Select
        With ActiveWindow.Selection.ShapeRange
            .Fill.ForeColor.RGB = RGB(0, 0, 0)
            .Fill.Visible = msoTrue
            .Fill.Solid
        End With
        
        width = (oSlide.slideNumber / numSlides) * BAR_WIDTH
        
        '## DRAW BAR FOREGROUND RECTANGLE:
        ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, BAR_X + BAR_BORDER, BAR_Y + BAR_BORDER, width, BAR_HEIGHT).Select
        With ActiveWindow.Selection.ShapeRange
            .Fill.ForeColor.RGB = RGB(255, 255, 255)
            .Fill.Visible = msoTrue
            .Fill.Solid
        End With
        
    Next oSlide
    
    MsgBox ("Finished")
    
End Sub


'-------------------------------------------
Sub BAR_DeleteProgressBar()
'
' Deletes progress bar generated by "BAR_GenerateProgressBar".
' WARNING: Works by delete shapes inside the area where the bar is generated.
'
    Const BAR_X = 5
    Const BAR_Y = 5
    Const BAR_WIDTH = 100
    Const BAR_HEIGHT = 10
    Const BAR_BORDER = 2
    
    Dim numDeleted As Integer
    numDeleted = 0
    
    For Each oSlide In ActivePresentation.slideS        ' For each slide in presentation: delete shape inside bar area
        FUNCT_DeleteAnyShapesInsideBoxFromSlideN oSlide.slideNumber, BAR_X - BAR_BORDER, BAR_Y - BAR_BORDER, (BAR_X + BAR_WIDTH + (2 * BAR_BORDER)), (BAR_Y + BAR_HEIGHT + (2 * BAR_BORDER))
        FUNCT_DeleteAnyShapesInsideBoxFromSlideN oSlide.slideNumber, BAR_X - BAR_BORDER, BAR_Y - BAR_BORDER, (BAR_X + BAR_WIDTH + (2 * BAR_BORDER)), (BAR_Y + BAR_HEIGHT + (2 * BAR_BORDER))
    Next oSlide
    
End Sub


'-------------------------------------------
Sub MISC_GenerateTableOfContents()
'
' Creates list of titles (excluding first slide) and outputs these in a new text box.
' Use this to generate a table of contents.
' NOTE: Works by identifying text elements with < 60 characters, and therefore won't be 100% accurate
'
    Dim titlesStr As String     'Used to keep "list" of titles
    Dim numTitles, numChars As Integer
    numTitles = 0
    titlesStr = ""
    
    '## FOR ALL SLIDES:
    For Each oSlide In ActivePresentation.slideS        ' Iterate through each slide in the presentation
        
        '## SKIP FIRST SLIDE
        If (oSlide.slideNumber = 1) Then
            GoTo NextSlide
        End If
        
        '## FOR ALL SHAPES IN SLIDE
        For Each oShape In oSlide.Shapes
            
            'MsgBox ("oShape.Type=" + CStr(oShape.Type))
            If (oShape.Type = Office.msoPlaceholder) And (oShape.HasTextFrame) Then
                
                numChars = oShape.TextFrame.TextRange.Characters.Count
                'MsgBox (CStr(numChars))
                
                If (numChars <= 60) Then    'If it looks like a title: add this text to the list
                    titlesStr = titlesStr + oShape.TextFrame.TextRange.text + Chr$(CharCode:=13)
                    numTitles = numTitles + 1
                    Exit For
                End If
            End If
            
        Next oShape
        
NextSlide:
        slideNum = slideNum + 1
        
    Next oSlide
    
    
    '## CREATE NEW TEXT BOX AND OUTPUT LIST OF TITLES
    FUNCT_MakeNewTextBox 20, 20, 240, 30, titlesStr, "Arial", 8
    MsgBox (CStr(numTitles) + " titles found")
    
End Sub


'-------------------------------------------
Sub MISC_ShowSlideTimesInTextboxes()
'
' Creates times in format: "00:30 -> 13:00" (time this slide -> cumulative time)
' and outputs to text box at the top of each slide, and again as a list on the first page.
'
    Const TIMEBOX_X = 25
    Const TIMEBOX_Y = -25
    Const TIMEBOX_WIDTH = 280
    Const TIMEBOX_HEIGHT = 25
    
    Dim timeOutputStr, allTimesOutStr As String     'Used to keep "list" of titles
    Dim numTitles As Integer
    Dim slideSecs, slideM, slideS, totSecs, totM, totS As Integer
    
    numTitles = 0
    slideSecs = 0
    totSecs = 0
    
    '## FOR ALL SLIDES:
    For Each oSlide In ActivePresentation.slideS        ' Iterate through each slide in the presentation
        
        '## GET SLIDE TIMING, UPDATE TOTAL TIME AND CALCULATE TIMES
        oSlide.Select
        slideSecs = ActiveWindow.Selection.SlideRange.SlideShowTransition.AdvanceTime
        totSecs = totSecs + slideSecs
        
        '## GENERATE TIME STRING
        slideM = MATH_Floor(slideSecs / 60)
        slideS = CInt(slideSecs - (slideM * 60))
        totM = MATH_Floor(totSecs / 60)
        totS = CInt(totSecs - (totM * 60))
        timeOutputStr = MATH_PadTwoDigits(slideM) + ":" + MATH_PadTwoDigits(slideS) + " -> " + MATH_PadTwoDigits(totM) + ":" + MATH_PadTwoDigits(totS)
        'FUNCT_SetSlideNotesText (timeOutputStr + Chr(13) + Chr(13)), oSlide.slideNumber
        allTimesOutStr = allTimesOutStr + CStr(oSlide.slideNumber) + "    " + MATH_PadTwoDigits(slideM) + ":" + MATH_PadTwoDigits(slideS) + "   " + MATH_PadTwoDigits(totM) + ":" + MATH_PadTwoDigits(totS) + Chr(13)
        
        '## OUTPUT TIME STRING TO TIMEBOX (TEXTBOX)
        FUNCT_DeleteMatchingShapesFromSlideN oSlide.slideNumber, TIMEBOX_X, TIMEBOX_Y, TIMEBOX_WIDTH, TIMEBOX_HEIGHT      ' If matching textbox exits: delete it
        FUNCT_MakeNewTextBox TIMEBOX_X, TIMEBOX_Y, TIMEBOX_WIDTH, TIMEBOX_HEIGHT, ByVal timeOutputStr, "Arial", 14
        
    Next oSlide
    
    '## ON FIRST SLIDE CREATE NEW TEXT BOX AND OUTPUT ALL TIMES
    ActivePresentation.slideS.Range(Array(1)).Select
    FUNCT_MakeNewTextBox 20, 20, 300, 30, allTimesOutStr, "Arial", 10
    ActiveWindow.Selection.Unselect
    
    MsgBox ("Total time:   " + totM + " mins " + MATH_PadTwoDigits(totS) + " secs" + Chr(13) _
          + "Total slides: " + CStr(ActivePresentation.slideS.Count) + Chr(13) _
          + "Average time per slide: " + CStr(Math.Round(CInt(totSecs) / CInt(ActivePresentation.slideS.Count), 1)) + " secs")
    
    
End Sub

'-------------------------------------------
Sub MISC_DeleteSlideTimesTextboxes()
'
' Deletes all textboxes generated by "MISC_ShowSlideTimesInTextbox"
' WARNING: Works by delete shapes inside the area where the textboxes are generated.
'
    Const TIMEBOX_X = 25
    Const TIMEBOX_Y = -25
    Const TIMEBOX_WIDTH = 280
    Const TIMEBOX_HEIGHT = 25
    
    '## FOR ALL SLIDES:
    For Each oSlide In ActivePresentation.slideS        ' Iterate through each slide in the presentation
        FUNCT_DeleteMatchingShapesFromSlideN oSlide.slideNumber, TIMEBOX_X, TIMEBOX_Y, TIMEBOX_WIDTH, TIMEBOX_HEIGHT
    Next oSlide
End Sub


'-------------------------------------------
Sub MISC_CompileAllNotesIntoSingeTextbox()
'
' Compiles all slide notes (under the slides) and outputs them in a new text box on the first slide.
'
    Dim allNotes As String     'Used to keep "list" of notes
    allNotes = ""
    
    '## FOR ALL SLIDES:
    For Each oSlide In ActivePresentation.slideS        ' Iterate through each slide in the presentation
        '## GET NOTES:
        oSlide.Select
        allNotes = allNotes + FUNCT_GetSlideNotesText(oSlide.slideNumber) + Chr(13) + "#" + Chr(13)
    Next oSlide
    
    '## CREATE NEW TEXT BOX AND OUTPUT LIST OF TITLES
    ActivePresentation.slideS.Range(Array(1)).Select    ' Select first slide
    
    FUNCT_MakeNewTextBox 20, 20, 480, 30, allNotes, "Arial", 6
    
End Sub


'-------------------------------------------
Sub MISC_PasteAllNotesIntoSingeTextbox()
'
' Copies all slide notes, including formatting, and pastes them in a new slide at the start.
' Similar to "MISC_CompileAllNotesIntoSingeTextbox", except uses copy and paste so that
' text formatting is preserved.
'
    Dim allNotes, notes As String     'Used to keep "list" of notes
    Dim notesLen, notesTotLen As Integer
    notesTotLen = 0
    allNotes = ""
    
    '## CREATE NEW SLIDE TO PASTE NOTES INTO:
    Dim NewSlide As Slide
    Set NewSlide = ActivePresentation.slideS.Add(1, ppLayoutTitle)      ' Add a new slide to the presentation.
    ActivePresentation.slideS.Range(Array(1)).Select    ' Select first slide
    NewSlide.Shapes.Title.TextFrame.TextRange.text = "NOTES:"
    
    '## CHANGE FORMATTING NOTES RECTANGLE:
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Select  ' Is the rectangle just under the notes
    ActiveWindow.Selection.TextRange.text = ""    ' Add contents
    ActiveWindow.Selection.TextRange.font.Size = 6
    ActiveWindow.Selection.TextRange.font.NameAscii = "Arial"
    ActiveWindow.Selection.TextRange.ParagraphFormat.Alignment = ppAlignLeft
    
    '## FOR ALL SLIDES: COPY NOTES INTO NOTES RECTANGLE
    For Each oSlide In ActivePresentation.slideS        ' Iterate through each slide in the presentation
        
        oSlide.Select
        FUNCT_CopySlideNotes (oSlide.slideNumber) ' Copy notes
        
        ActivePresentation.slideS.Range(Array(1)).Select
        ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Select
        ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").TextFrame.TextRange.Characters(1, 0).Select
        ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.InsertAfter.Paste
        ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.InsertAfter.text = Chr(13) + "#" + Chr(13)
    Next oSlide
    
    '## CHANGE FORMATTING NOTES RECTANGLE:
    ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Select  ' Is the rectangle just under the notes
    ActiveWindow.Selection.TextRange.font.Size = 6
    ActiveWindow.Selection.TextRange.font.NameAscii = "Arial"
    ActiveWindow.Selection.TextRange.ParagraphFormat.Alignment = ppAlignLeft
    
    
End Sub


'-------------------------------------------
Sub MISC_DeleteAllAudio()
'
' Deletes all audio from your document - useful when you have recorded narration and want to delete it all.
'
    Dim numDeleted As Integer
    numDeleted = 0
    
    '## FOR ALL SLIDES:
    For Each oSlide In ActivePresentation.slideS        ' Iterate through each slide in the presentation
        
        For Each oShape In oSlide.Shapes
            
            'MsgBox ("oShape.Type=" + CStr(oShape.Type))
            If (oShape.Type = Office.msoMedia) Then        'Office.msoPlaceholder = text
                oShape.Delete
                numDeleted = numDeleted + 1
                Exit For
            End If
            
        Next oShape
        
    Next oSlide
    
    MsgBox ("Finished... number of deleted objects = " + CStr(numDeleted))
    
End Sub








'-------------------------------------------
'
' Note the declaration as Object instead of explicitly using Slide;
' since I am passing, slides, notes, Slide/Notes/Handouts master



Function FUNCT_DeleteAnyShapesInsideBoxFromSlideN(slideNumber As Integer, x_min As Integer, y_min As Integer, x_max As Integer, y_max As Integer) As Boolean
    Dim Sl As Slide
    Set Sl = ActivePresentation.slideS(slideNumber)
    
    For Each oShape In Sl.Shapes
        If (oShape.Left >= x_min) And (oShape.Top >= y_min) And _
                (oShape.Left + oShape.width <= x_max) And (oShape.Top + oShape.height <= y_max) Then
            oShape.Delete
        End If
    Next oShape
    
End Function

Function FUNCT_DeleteMatchingShapesFromSlideN(slideNumber As Integer, x_corner As Integer, y_corner As Integer, x_width As Integer, y_height As Integer) As Boolean
    Dim Sl As Slide
    Set Sl = ActivePresentation.slideS(slideNumber)
    
    For Each oShape In Sl.Shapes
        If (oShape.Left = x_corner) And (oShape.Top = y_corner) And _
                (oShape.width = x_width) And (oShape.height = y_height) Then
            oShape.Delete
            Exit For    ' %% Can remove
        End If
    Next oShape
    
End Function

Function FUNCT_DeleteShapeIfCornerInsideBox(oShape As Shape, min_x As Integer, max_x As Integer, min_y As Integer, max_y As Integer) As Boolean
    If (oShape.Left >= min_x) And (oShape.Left <= max_x) _
            And (oShape.Top >= min_y) And (oShape.Top <= max_y) Then
        oShape.Delete
    End If
End Function

Function FUNCT_MakeNewTextBox(x As Integer, y As Integer, width As Integer, height As Integer, _
                        ByVal text As String, font As String, fontSize As String)
    
    ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal, x, y, width, height).Select
    ActiveWindow.Selection.TextRange.text = text    ' Add contents
    ActiveWindow.Selection.TextRange.font.Size = fontSize
    ActiveWindow.Selection.TextRange.font.NameAscii = font
    ActiveWindow.Selection.TextRange.ParagraphFormat.Alignment = ppAlignLeft
End Function

'-------------------------------------------

Function FUNCT_SetSlideNotesText(addText As String, slideNumber As Integer)
    Dim Sl As Slide
    Dim Sh As Shape
    Set Sl = ActivePresentation.slideS(slideNumber)
    If Sl.NotesPage.Shapes.Count > 0 Then
        For Each Sh In Sl.NotesPage.Shapes
            If Sh.HasTextFrame Then
                Sh.TextFrame.TextRange.text = addText
                Exit For
            End If
        Next Sh
    End If
End Function

Function FUNCT_GetSlideNotesText(slideNumber As Integer) As String
    Dim Sl As Slide
    Dim Sh As Shape
    Dim text As String
    
    Set Sl = ActivePresentation.slideS(slideNumber)
    'If Sl.NotesPage.Shapes.Count > 0 Then
    For Each Sh In Sl.NotesPage.Shapes
        If Sh.HasTextFrame Then
            text = Sh.TextFrame.TextRange.text
            Exit For
        End If
    Next Sh
    'End If
    
    FUNCT_GetSlideNotesText = text
End Function

Function FUNCT_CopySlideNotes(slideNumber As Integer)
    Dim Sl As Slide
    Dim Sh As Shape
    Dim textLen As Integer
    Set Sl = ActivePresentation.slideS(slideNumber)
    For Each Sh In Sl.NotesPage.Shapes
        If Sh.HasTextFrame Then
            'MsgBox Sh.Id
            Sh.TextFrame.TextRange.Copy
            Exit For
        End If
    Next Sh
End Function

'-------------------------------------------

Function MATH_Floor(num As Double) As Integer
    MATH_Floor = CInt(num - 0.49999999999999)
End Function


Function MATH_PadTwoDigits(ByVal num As Integer) As String
    If (num < 10) Then
        MATH_PadTwoDigits = "0" + CStr(num)
    Else
        MATH_PadTwoDigits = CStr(num)
    End If
End Function