PowerPoint Run Macro out of SlideShow (Doesnt work in slide mode)

[DrHacker]

I create a Countdown timer at presentation with two macros (One to create the shapes) and separated one to start counting down… but it Works fine if I use VBA Screen pressing F5.

But I can’t do it in Presentation mode, idea is to add/remove it in different slides as need with different countdown timers

Someone can help me to understand why?

Code at Module Called "Functions"

'*** Define VBA Code Variables to use based on Office Version (x86 / x64) START ***
Option Explicit

#If VBA7 Then

Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long

#Else ' Excel 2007 or earlier

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
Public Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String,ByVal lpWindowName As String) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Public Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long

#End If

'*** Define VBA Code Variables to use based on Office Version (x86 / x64) END ***

Sub NewTimerSeconds()

Dim sld As Slide
Dim shp As Shape

Dim TimShp As Shape
Dim Timer As String
Dim TmrSecs As Integer
Dim OriginalTimer As Integer

    Set sld = Application.ActiveWindow.View.Slide

For Each shp In Application.ActiveWindow.View.Slide.Shapes

Debug.Print shp.Name

If shp.Name = "Timer" Then

shp.Delete
Application.ActiveWindow.View.Slide.Shapes("OriginalTimer").Delete

End If

    Next shp

    Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, Left:=50, Top:=50, Width:=28.78, Height:=9.35) 'Width:=18.71 (Size for Seconds)

Set TimShp = sld.Shapes.AddShape(Type:=msoShapeRectangle, Left:=-50, Top:=-50, Width:=0, Height:=0) 'Original Timer Shape
TimShp.Name = "OriginalTimer"
TimShp.Visible = msoTrue

With shp

.TextEffect.FontSize = 6
.TextEffect.FontBold = msoCTrue
.TextEffect.Alignment = msoTextEffectAlignmentCentered

.TextFrame.TextRange.Font.Shadow = msoCTrue

.Line.Weight = 0.75

With .Fill

.BackColor.RGB = RGB(31, 78, 121)
.ForeColor.RGB = RGB(51, 63, 80)
.OneColorGradient msoGradientHorizontal, 1, 1

.GradientStops.Insert RGB(96, 131, 203), 0
                .GradientStops.Insert RGB(62, 112, 202), 0.5

                .GradientStops(2).Color = RGB(46, 97, 186)
.GradientStops(2).Position = 1

'.Transparency = 0.8

End With

.Name = "Timer"

    End With

    TmrSecs = InputBox("Introduce duration of your timer in seconds", "Timer Setup", 1) 'Countdown in seconds

    TimShp.TextFrame.TextRange.Text = TmrSecs

End Sub

Sub TimerCountDown()

Dim sld As Slide
Dim shp As Shape

Dim TimShp As Shape
Dim Timer As String
Dim TmrSecs As Integer
Dim OriginalTimer As Integer

    Set sld = Application.ActiveWindow.View.Slide

For Each shp In Application.ActiveWindow.View.Slide.Shapes

Debug.Print shp.Name

If shp.Name = "OriginalTimer" Then

GoTo ActivateCountDown

End If

    Next shp

Exit Sub

ActivateCountDown:

            Set shp = ActiveWindow.View.Slide.Shapes("OriginalTimer")

TmrSecs = shp.TextFrame.TextRange.Text

            Set shp = ActiveWindow.View.Slide.Shapes("Timer")

            With shp

                Do While (TmrSecs > -1)

                Sleep 1000

                TmrSecs = TmrSecs - 1

                .TextFrame.TextRange = CStr(TmrSecs + 1) 'Format(Now,"hh:mm:ss")

                DoEvents

                Loop

                If shp.TextFrame.TextRange = 0 Then

                     With shp.Fill

                        .BackColor.RGB = RGB(0, 0, 0)
.ForeColor.RGB = RGB(192, 0, 0)
                        .OneColorGradient msoGradientHorizontal, 1, 1

                            .GradientStops.Insert RGB(192, 0, 0), 0
                            .GradientStops.Insert RGB(192, 0, 0), 0.5

                            .GradientStops(2).Color = RGB(192, 0, 0)
                            .GradientStops(2).Position = 1

                        '.Transparency = 0.8

                     End With

                shp.TextFrame.TextRange = "End"

                End If

            End With

End Sub