Click here to Skip to main content
15,867,308 members
Articles / VBA

Make a Countdown Timer Add-in for Powerpoint - Part 1

Rate me:
Please Sign up or sign in to vote.
5.00/5 (5 votes)
31 Oct 2022CPOL9 min read 16.7K   311   8   3
A walkthrough to create a count down timer Add-in for Powerpoint
In this post, you will see how to use VBA to create a count down timer add-in for Powerpoint.

Download

Introduction

The article shows you how to use VBA to create a Count Down Timer Addin for Powerpoint and all the knowledge related to such a task. In the next article (Part 2), I am going to show you how to use C# to make a VSTO addin for the same counter down timer.

Below are a list of targets I want to achieve with this Addin:

  1. Insert the relavant VBA codes via a click of Ribbon Button.
  2. Insert a count down timer on any slide via a click of Ribbon Button.
  3. The count down duration and TextEffect are editable.
  4. In Slide show mode, click on the timer - it will start to count down, when count down timer reaches 0, an alarming sound will be triggered (configurable and muteable), but the count down will continue to negative value until the user clicks again on the timer or slide show ends.

Background

The original idea of count down timer came from a YouTube tutorial by Karina Adcock. She shared a very neat solution in her video ("How to make a countdown timer in Powerpoint using VBA?"). Thanks to Karina for her great sharing.

I tried to enhance the features basing on Karina Adcock's solution, then I found that it was not so easy to make a decent add-in with all the features I listed in the Introduction section.

I felt that it may be useful to share what I have learnt here.

Using the Code

  1. Use the CountDownTimerInstaller.pptm to install and unsintall the Addin.

    Image 1

  2. Open your own PPT or create a new PPT and save it as pptm format, then find the CountDown Tab on Ribbon, click "Install CountDown" to insert VBA code into current PPT.

    Image 2

  3. Click on "Add Timer" to insert the CountDown shapes on current slide, a dialog box will pop up for you to configure the duration, sound effect and text effect, click OK.

    Image 3

  4. The CountDown Timer is now successfully installed on the current slide, to test the effect, simply turn on the "Slide Show" mode and click on the timer, it will start to count down, click again or end the "Slide Show", it will stop.

    Image 4

  5. In case you don't see the CountDown Tab mentioned above, please select the Developer Tab and click on Powerpoint Add-in button to open the Add-in manager dialog box. You shall see the CountDownAddin in the availlable Add-ins box, simply tick it to load this Add-in, then click the Close button.

    Image 5

  6. In case you don't see the Developer Tab also, from menu bar please select the File\Options to open the Powerpoint Options dialog box, then click on Customize Ribbon Tab. You shall see the Developer node on the right pane, simply tick it to load this Add-in, then click the Ok button to close the Options dialogbox.

    Image 6

Below are some code snippets which maybe of interest to you:

1. Basic Function of the CountDown Timer

First, let's look into the original code from Karina Adcock:

VBA
'
' Here is the code snippet shared by Karina Adcock
'
Sub CountDown()
  Dim future As Date
  future = DateAdd("n", 2, Now())
  Do Until future < Now()
	DoEvents
	ActivePresentation.Slides(1).Shapes("rectangle").TextFrame.TextRange = _
                                               Format(future - Now(), "nn:ss")
  Loop
End Sub

To make the CountDown method more flexible and suitable for any slide in your PPT, we can't hardcode the slide number. It's the same for the count down duration.

VBA
'
' Revision 1
'
Sub CountDown()
  Dim future As Date
  Dim sSlideNumber as Integer: sSlideNumber = _
                   Application.ActiveWindow.View.Slide.SlideNumber
  future = DateAdd("n", 2, Now())
  Do Until future < Now()
	DoEvents
	ActivePresentation.Slides(sSlideNumber).Shapes_
    ("rectangle").TextFrame.TextRange = Format(future - Now(), "nn:ss")
  Loop
End Sub 

After testing, you will find that the "revision 1" won't work, because the below statement "Application.ActiveWindow.View.Slide.SlideNumber" will exit the subroutine immediately. Hence, I go for revision 2 as shown below:

VBA
'
' Revision 2
'
Sub CountDown()
  Dim future As Date
  Dim sSlideNumber as Integer: sSlideNumber = _
      ActivePresentation.Windows(1).View.Slide.slidenumber
  future = DateAdd("n", 2, Now())
  Do Until future < Now()
	DoEvents
	ActivePresentation.Slides(sSlideNumber).Shapes_
          ("rectangle").TextFrame.TextRange = Format(future - Now(), "nn:ss")
  Loop
End Sub 

Revision 2 works fine. But the index number "1" is hardcoded in Windows(1) and shape name "rectangle" is also hardcoded. It's not a foolproof solution yet, that's why I go for revision 3.

VBA
'
' Revision 3
'
Sub CountDown(oShape As Shape)
  Dim future As Date
  future = DateAdd("n", 2, Now())
  Do Until future < Now()
	DoEvents
	oShape.TextFrame.TextRange = Format(future - Now(), "nn:ss")
  Loop
End Sub 

This is a neater solution, as we don't care about the slide number and shape name. And further more, now it also works for multiple CountDown Timers on the same slide.

Note: How to use the above codes?

  1. Open your own PPT or create a new one, then save it as pptm format.
  2. Press Alt+F11 to open the VBE (VBA Editor), insert a Module, paste code snippet from revision 3.
  3. Press Alt+F11 again to switch back to PPT, insert a rectangle shape on the current slide.
  4. Select the rectangle shape, then insert "Action", on pop up dialog box, click on "Run Macro", choose "CountDown", click OK.

    Image 7

  5. Turn on "Slide Show" mode, click on the timer, the count down will start. That's all!

2. To Enhance the Features of the CountDown Timer

Basically, we want to configure the duration, sound effect and text effect.

  1. Duration: We need to find a place to store the duration value (in minutes), every shape has a AlternativeText property which is a good candidate to store our value.
  2. Sound Effect: When timer counts to zero, we need some alarming sound to alert the presenter, let's insert a bomb symbol beside the timer and also use its AlternativeText property to store the sound effect selection.
    1. Sound Effect Source: we can use the Windows sound effect files which are stored in "C:\Windows\Media" folder (midi and wav)
    2. How to play the sound asynchronously? Use the below Windows API.
      VBA
      #If VBA7 Then
          Private Declare PtrSafe Function mciSendString Lib _
          "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, _
          ByVal lpstrReturnString As String, ByVal uReturnLength As Long, _
          ByVal hwndCallback As Long) As Long
      #Else
          Private Declare Function mciSendString Lib "winmm.dll" _
          Alias "mciSendStringA" (ByVal lpstrCommand As String, _
          ByVal lpstrReturnString As String, ByVal uReturnLength As Long, _
          ByVal hwndCallback As Long) As Long
      #End If
    3. To save the file loading time and have a smoother sound playing experience, we can use the below codes to preload the media file. Before loading the existing sound effect, it will stop the previous playing sound if there is any. The codec type "MPEGVideo" can be used to play midi, wav and mp3 file.
      VBA
      '---------------------------------------------------------
      ' Load or Reload "Media File"
      '---------------------------------------------------------
      Sub ReloadMediaFile(Optional ByVal sMediaFileName As String = "flourish.mid")
          mciSendString "close media", 0, 0, 0&
          mciSendString "open ""C:\Windows\Media\" & _
          sMediaFileName & """ type MPEGVideo alias media", 0, 0, 0&
      End Sub        
    4. To start playing the media asynchronously and repeatedly, you can use the below codes:
      VBA
      Sub StartPlayingMediaFile()
          mciSendString "play media repeat", 0, 0, 0&
      End Sub        
    5. To stop playing the media, you can use the below codes:
      VBA
      Sub StartPlayingMediaFile()
          mciSendString "close media", 0, 0, 0&
      End Sub        
    6. To help user find the suitable sound effect, when user selects a different sound, that sound will be played, click OK button to stop the sound and confirm the selection.

      Image 8

  3. Text Effect: We use Wordart to Enhance the Visual Effect of the Timer, the Text Effect is stored in the oShape.TextEffect.PresetTextEffect property. There are 40 Text Effects for Wordart. To help a user select the right effect, we need to show how it may look like for each selection.

    Image 9

    How to Implement It?

    1. We can use the below code to insert all the 40 word art text effects in one slide:
      VBA
      Sub InsertWordArt_AllPresetTextEffects()
          'msoTextEffect7, "Arial Black", FontSize:=100, FontBold:=msoTrue
          'PresetTextEffect = 0 - 49
          Const nFontSize As Integer = 42     '54
          Const nLineSpace As Integer = 10
          Const nX0 As Integer = 50
          Const nXOffset As Integer = 180
          Const sFontName As String = "Amasis MT Pro Black"
          Const sText As String = "05:"
          Dim newWordArt As Shape
          Dim nSlideNo As Integer
          nSlideNo = Application.ActiveWindow.View.Slide.SlideNumber
          Dim i As Integer
          For i = 0 To 9
              Set newWordArt = ActivePresentation.Slides(nSlideNo).
                               Shapes.AddTextEffect(PresetTextEffect:=i, _
              Text:=sText & Format(i, "00"), _
              FontName:=sFontName, FontSize:=nFontSize, 
                        FontBold:=msoFalse, FontItalic:=msoFalse, _
              Left:=nX0, Top:=(nFontSize + nLineSpace) * i)
          Next
          
          For i = 10 To 19
              Set newWordArt = ActivePresentation.Slides(nSlideNo).
                               Shapes.AddTextEffect(PresetTextEffect:=i, _
              Text:=sText & Format(i, "00"), _
              FontName:=sFontName, FontSize:=nFontSize, FontBold:=msoFalse, 
                        FontItalic:=msoFalse, _
              Left:=nX0 + nXOffset, Top:=(nFontSize + nLineSpace) * (i - 10))
          Next
          
          For i = 20 To 29
              Set newWordArt = ActivePresentation.Slides(nSlideNo).
                               Shapes.AddTextEffect(PresetTextEffect:=i, _
              Text:=sText & Format(i, "00"), _
              FontName:=sFontName, FontSize:=nFontSize, 
                       FontBold:=msoFalse, FontItalic:=msoFalse, _
              Left:=nX0 + nXOffset * 2, Top:=(nFontSize + nLineSpace) * (i - 20))
          Next
          
          For i = 30 To 39
              If i < 50 Then
                  Set newWordArt = ActivePresentation.Slides
                  (nSlideNo).Shapes.AddTextEffect(PresetTextEffect:=i, _
                  Text:=sText & Format(i, "00"), _
                  FontName:=sFontName, FontSize:=nFontSize, 
                            FontBold:=msoFalse, FontItalic:=msoFalse, _
                  Left:=nX0 + nXOffset * 3, 
                       Top:=(nFontSize + nLineSpace) * (i - 30))
              Else
                  Exit For
              End If
          Next
          
          For i = 40 To 49
              If i < 50 Then
                  Set newWordArt = ActivePresentation.Slides
                  (nSlideNo).Shapes.AddTextEffect(PresetTextEffect:=i, _
                  Text:=sText & Format(i, "00"), _
                  FontName:=sFontName, FontSize:=nFontSize, 
                           FontBold:=msoFalse, FontItalic:=msoFalse, _
                  Left:=nX0 + nXOffset * 4, 
                  Top:=(nFontSize + nLineSpace) * (i - 40))
              Else
                  Exit For
              End If
          Next
          Exit Sub
          
          newWordArt.Select
          With ActiveWindow.Selection
              .ShapeRange.IncrementLeft 129#
              .ShapeRange.IncrementTop 179.25
              .ShapeRange.IncrementRotation -24.39
              .ShapeRange.IncrementLeft -48.75
              .ShapeRange.IncrementTop -68.25
              .ShapeRange.ScaleWidth 1.12, msoFalse, msoScaleFromBottomRight
              .ShapeRange.IncrementLeft 34.5
              .ShapeRange.IncrementTop 0.75
              .ShapeRange.ScaleHeight 1.36, msoFalse, msoScaleFromTopLeft
              .ShapeRange.ScaleHeight 1.04, msoFalse, msoScaleFromBottomRight
              .ShapeRange.ScaleHeight 1.07, msoFalse, msoScaleFromBottomRight
              .ShapeRange.ScaleWidth 1.01, msoFalse, msoScaleFromTopLeft
              .ShapeRange.IncrementLeft -24#
              .ShapeRange.IncrementTop 1.5
              .ShapeRange.Line.Weight = 3#
              .ShapeRange.Line.DashStyle = msoLineSolid
              .ShapeRange.Line.Style = msoLineSingle
              .ShapeRange.Line.Transparency = 0#
              .ShapeRange.Line.Visible = msoTrue
              '.ShapeRange.Line.ForeColor.SchemeColor = 48
              .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
              .ShapeRange.Line.Weight = 3#
              .ShapeRange.Line.DashStyle = msoLineSolid
              .ShapeRange.Line.Style = msoLineSingle
              .ShapeRange.Line.Transparency = 0#
              .ShapeRange.Line.Visible = msoTrue
              '.ShapeRange.Line.ForeColor.SchemeColor = 48
              .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
              .ShapeRange.Fill.Visible = msoFalse
              .ShapeRange.Fill.Solid
              '.ShapeRange.Fill.Transparency = 0#
              .ShapeRange.Fill.Transparency = 0.5
          End With
      End Sub        
    2. Please refer to the below image for detail:

      Image 10

    3. Let's use an online split tool to split the above image into 40 equal smaller images.
      Split Image | Online and Free | Aspose.PDF
    4. Insert 40 ImageControl into frmDuration user form and group them in a frame control.

      Image 11

    5. Resize the user form to hide the frame control, when user selects a different text effect, simply assign the image from the 40 ImageControl.
      VBA
      Private Sub cboTextEffect_Change()
      
          Dim nIdx As Integer: nIdx = Int(cboTextEffect.Text)
          nTextEffectIdx = nIdx
          Dim oImage As Image
          Set oImage = Me.Controls("Image" & nIdx)
          ImageControl.Picture = oImage.Picture
      End Sub        
  4. Below is the frmDuration which hosts the configuration of "Duration", "Sound Effect" and "Text Effect".

    Image 12

  5. Let's use "Time Emoji" symbol to show an animated effect of count down timer.
    1. To show the Emoji, we need to know its unicode, open a PPT slide, insert a shape, then insert a Symbol, select the "Segoe UI Emoji" and look for the time symbol as per below:

      Image 13

    2. However, the above Unicode(1F550) is in UTF32 format, in order to use it, we need to convert it into UFT16 format.
    3. How to convert? Let's follow the example shared by "Anurag S Sharma" in the below link:
      Is it possible to convert UTF32 text to UTF16 using only Windows API?
      C++
      unsigned int convertUTF32ToUTF16
      (unsigned int cUTF32, unsigned int &h, unsigned int &l)
      {
          if (cUTF32 < 0x10000)
          {
              h = 0;
              l = cUTF32;
              return cUTF32;
          }
          unsigned int t = cUTF32 - 0x10000;
          h = (((t<<12)>>22) + 0xD800);
          l = (((t<<22)>>22) + 0xDC00);
          unsigned int ret = ((h<<16) | ( l & 0x0000FFFF));
          return ret;
      }		
    4. Let's convert the above C++ code into VBA. Because VBA does not support shift operation, here we have to use a VBA version of shift operation. The credits of function shl & shr go to the below blog:
      Bit Shifting Function in Excel VBA
      VBA
      Funtion TestConversionFromUTF32ToUTF16()
      	Debug.Print GetUTF16StringFromUTF32(&H1F550&)
      End Function
      
      Function GetUTF16StringFromUTF32(ByVal UTF32 As Long) As String
          'UTF32 = &H1F550
          Dim UTF16H As Long, UTF16L As Long
          ConvertUTF32ToUTF16 UTF32, UTF16H, UTF16L
          GetUTF16StringFromUTF32 = UTF16H & ", " & UTF16L
      End Function
      
      Sub ConvertUTF32ToUTF16(ByVal UTF32 As Long, _
          ByRef UTF16H As Long, ByRef UTF16L As Long)
          If UTF32 < &H10000 Then
              UTF16H = 0
              UTF16L = UTF32
          Else
              Dim temp As Long
              temp = UTF32 - &H10000
              UTF16H = shr(shl(temp, 12), 22) + &HD800&
              UTF16L = shr(shl(temp, 22), 22) + &HDC00&
          End If
      End Sub
      
      Public Function shr(ByVal Value As Long, ByVal Shift As Byte) As Long
          Dim i As Byte
          shr = Value
          If Shift > 0 Then
              shr = Int(shr / (2 ^ Shift))
          End If
      End Function
      
      Public Function shl(ByVal Value As Long, ByVal Shift As Byte) As Long
          shl = Value
          If Shift > 0 Then
              Dim i As Byte
              Dim m As Long
              For i = 1 To Shift
                  m = shl And &H40000000
                  shl = (shl And &H3FFFFFFF) * 2
                  If m <> 0 Then
                      shl = shl Or &H80000000
                  End If
              Next i
          End If
      End Function		
    5. Let's run TestConversionFromUTF32ToUTF16, the result is (55357, 56656). So the "One Clock" Symbol can be represented by chrw(55357)+chrw(56656). When the CountDown is ticking, we can change the symbol from 12 o'clock to 11 o'clock and so on.

Points of Interest

After completing all the features of the CountDown Timer, there are still some extra work needed.

Below are some interesting code snippets I used:

  1. How to customize the ribbon of pptm & ppam file?
    Image 14
    Please look into below tool shared by Fernando Andreu:
    Fernando Andreu: Office Ribbonx editor
  2. To customize the ribbon for CountDown add-in ppam with below XML:
    Image 15
    XML
    <customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
      <ribbon startFromScratch="false">
        <tabs>
          <tab id="countDownTab" label="CountDown Tab">
            <group id="countDownGroup" label="CountDown Group">
    	    <button id="btnInstall" label="Install CountDown" image="ClockInstall" size="large" onAction="OnInstall" screentip="Install CountDown" supertip="Install VBA Module and User Form into your own PPT slides to support the count down timer function" />
    	    <button id="btnUninstall" label="Uninstall CountDown" image="ClockUninstall" size="large" onAction="OnUninstall" screentip="Uninstall CountDown" supertip="Remove VBA Module and User Form from your own PPT slide" />
    	    <button id="btnAddTimer" label="Add Timer" image="AddClock" size="large" onAction="OnAddTimer" screentip="Add CountDown Timer" supertip="Insert a new CountDown Timer into your own PPT slide, to test it you need enter 'Slide Show' mode, click once to start the count down, click again to stop it." />
    	    <button id="btnDelTimer" label="Del Timer" image="DelClock" size="large" onAction="OnDelTimer" screentip="Del CountDown Timer" supertip="Remove a selected CountDown Timer on your PPT slide." />
    	    <button id="btnEditTimer" label="Edit Timer" image="EditClock" size="large" onAction="OnEditTimer" screentip="Edit CountDown Timer" supertip="Edit a selected CountDown Timer on your PPT slide, you can change its preset duration and text effect sytle." />
    		<button idMso="AddInManager"  size="large" />		
    		<button idMso="VisualBasic"  size="large" />
    		<button idMso="MacroPlay"  size="large" />		
    	    <button id="btnAboutBox" label="About Box" image="AboutBox" size="large" onAction="OnAboutBox" />
            </group>
          </tab>
        </tabs>
      </ribbon>
    </customUI>       
  3. To customize the ribbon for installer pptm with below XML:
    Image 16
    XML
    <customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
      <ribbon startFromScratch="true">
        <tabs>
          <tab id="countDownAddinTab" label="CountDown Addin Installer">
            <group id="countDownGroup" label="CountDown Group">
    	    	<button id="btnInstall" label="Install Addin" image="ClockInstall" size="large" onAction="OnInstall" screentip="Install CountDown Addin" supertip="Install Addin in PPT Application, it will add a new 'CountDown Tab' in the Ribbon Bar." />
    	    	<button id="btnUninstall" label="Uninstall Addin" image="ClockUninstall" size="large" onAction="OnUninstall" screentip="Uninstall CountDown Addin" supertip="Uninstall Addin in PPT Application, it will remove the 'CountDown Tab' in the Ribbon Bar." />	
    	    	<button id="btnAboutBox" label="About Box" image="AboutBox" size="large" onAction="OnAboutBox" />
            </group>
          </tab>
        </tabs>
      </ribbon>
    </customUI>
  4. Install & uninstall the CountDown Addin: to register & un-register PPT Addin: We can use the below DOS Command REG:

    Image 17

    For Registry Key, please refer to the below screen shot:

    Image 18

    Now we know the Registry key related to registration and un-registration of an PPT Addin, to make sure such operation will be effective immediately, we have to exit PPT application and restart it again, hence we will need the delay-execution technology again. Below are actual codes for the "Register & Un-register" task:

    VBA
    Sub DelayRegAddin(Optional ByVal sAddinName As String = "CountDownAddin", _
        Optional ByVal nSeconds As Integer = 1)
        Dim sAddRegPath As String, sAddRegAutoload As String
        sAddRegPath = "REG ADD HKCU\SOFTWARE\Microsoft\Office\" & _
        Application.Version & "\PowerPoint\AddIns\" & sAddinName & _
        " /v Path /t REG_SZ /d " & sAddinName & ".ppam"
        sAddRegAutoload = "REG ADD HKCU\SOFTWARE\Microsoft\Office\" & _
        Application.Version & "\PowerPoint\AddIns\" & sAddinName & _
        " /v AutoLoad /t REG_DWORD /d 00000001"
        RunShellWithArgument "cmd.exe", "/C choice /C Y /N /D Y /T " & _
        nSeconds & " & " & sAddRegPath & " & " & sAddRegAutoload
    End Sub
    
    Sub DelayUnregAddin(Optional ByVal sAddinName As String = "CountDownAddin", _
        Optional ByVal nSeconds As Integer = 1)
        Dim sDelAddinRegKey As String
        sDelAddinRegKey = "REG DELETE HKCU\SOFTWARE\Microsoft\Office\" & _
        Application.Version & "\PowerPoint\AddIns\" & sAddinName & " /F"
        RunShellWithArgument "cmd.exe", "/C choice /C Y /N /D Y /T " & _
        nSeconds & " & " & sDelAddinRegKey
    End Sub    
  5. Delete the add-in file after unregistering the add-in: To completely uninstall an addin, we need to delete it. However, when we are still in the PPT application, this operation will fail. Hence, we need to trigger an action to be executed even after we have exited from PPT application. Below is the approach I used in this installer:
    1. Launch a Shell Process with arguments:
      VBA
      Public Sub RunShellWithArgument(ByVal sProgramName As String, _
                                      ByVal sArgument As String)
          Call Shell("""" & sProgramName & """ """ & sArgument & """", vbHide)
      End Sub
    2. Use DOS Command in Shell Process to do a delay execution:
      VBA
      Sub DelayExecDosCmd(sDosCmd As String, Optional ByVal nSeconds As Integer = 1)
          RunShellWithArgument "cmd.exe", _
          "/C choice /C Y /N /D Y /T " & nSeconds & " & " & sDosCmd
      End Sub
    3. With the above functions, now we can do delay deletion of addin file:
      VBA
      Sub DelayDeleteAddin_
      (ByVal sAddinFullPath As String, ByVal nSeconds As Integer)
          RunShellWithArgument "cmd.exe", "/C choice /C Y /N /D Y /T " _
          & nSeconds & " & Del " + sAddinFullPath
      End Sub            
    4. I have mentioned above that we have to exit from a PPT application to do the delay started operation, however, Application.Quit will run into error sometimes. To exit PPT inside the VBA without error prompt, we can use below the Windows APIs, thanks to John_w for sharing: John_w: Using Windows APIs to close a window.
      VBA
      #If VBA7 Then
          Private Declare PtrSafe Function FindWindow Lib "user32" _
          Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
          ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
          Private Declare PtrSafe Function SendMessage Lib "user32" _
          Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
          ByVal wParam As Long, lParam As Long) As Long
      #Else
          Private Declare Function FindWindow Lib "user32" _
          Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
          ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
          Private Declare Function SendMessage Lib "user32" _
          Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
          ByVal wParam As Long, lParam As Long) As Long
      #End If
      Sub QuitPPT()
          Dim hWnd As Long
          hWnd = FindWindow(0, hWnd, "PPTFrameClass", vbNullString)
          If hWnd <> 0 Then
              SendMessage hWnd, WM_SYSCOMMAND, SC_CLOSE, 0
          End If
      End Sub          
  6. To check whether this code is running in the addin mode:
    VBA
    Public bRunningAsAddin As Boolean
    
    ' It will only be triggered in Addin
    Sub Auto_Open()
        bRunningAsAddin = True
    End Sub
  7. VBA in PPT to call function in Addin:

    "CountDown" is a sub inserted in the PPT, and "CountDownEx" is a sub defined in the Addin.

    VBA
    Public Sub CountDown(oShape As Shape)
        Application.Run "CountDownEx", oShape
    End Sub
  8. Encode and Decode Base64 string:
    VBA
    Function EncodeToBase64(ByVal sPlainString As String) As String
        EncodeToBase64 = GetBase64FromBytes(GetBytesFromString(sPlainString))
    End Function
    
    Function DecodeFromBase64(ByVal sBase64String As String) As String
        DecodeFromBase64 = GetStringFromBytes(GetBytesFromBase64(sBase64String))
    End Function
    
    Public Function GetBase64FromBytes(vPlainBytes() As Byte) As String
        Dim oXML2 As MSXML2.DOMDocument60
        Dim oNode As MSXML2.IXMLDOMElement
        '-------------------------------
        Set oXML2 = New MSXML2.DOMDocument60
        Set oNode = oXML2.createElement("b64")
        '-------------------------------
        oNode.dataType = "bin.base64"
        oNode.nodeTypedValue = vPlainBytes
        '-------------------------------
        GetBase64FromBytes = Replace(oNode.Text, vbLf, vbCrLf)
        '-------------------------------
        Set oNode = Nothing
        Set oXML2 = Nothing
    End Function
    
    Public Function GetBytesFromBase64(sBase64String As String) As Byte()
        Dim oXML2 As MSXML2.DOMDocument60
        Dim oNode As MSXML2.IXMLDOMElement
        '-------------------------------
        Set oXML2 = New MSXML2.DOMDocument60
        Set oNode = oXML2.createElement("b64")
        '-------------------------------
        oNode.dataType = "bin.base64"
        oNode.Text = sBase64String
        '-------------------------------
        GetBytesFromBase64 = oNode.nodeTypedValue
        '-------------------------------
        Set oNode = Nothing
        Set oXML2 = Nothing
    End Function
    
    Function GetBytesFromString(ByVal sString As String) As Byte()
        GetBytesFromString = StrConv(sString, vbFromUnicode)
    End Function
    
    Function GetStringFromBytes(bytes() As Byte) As String
        GetStringFromBytes = StrConv(bytes, vbUnicode)
    End Function
  9. CountDown Module stored in string:
    VBA
    Public Function GetModCountDownBytes() As Byte()
        Dim sBase64Variable As String: sBase64Variable = ""
        sBase64Variable = sBase64Variable & _
            "JycgKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioq" _
             & vbCrLf & _
            "KioqKioqKioNCicnIENvcHlyaWdodCBbMjAyMl0gIFtXYXluZSBKaW5dDQonJyAqKioqKioq" _
             & vbCrLf & _
            "KioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKioqKg0K" _
             & vbCrLf & _
            "JycgQ291bnREb3duOiBtb2RDb3VudERvd24NCicnIDxBdXRob3I+V2F5bmUgSmluPC9BdXRo" _
             & vbCrLf & _
            "b3I+DQonJyA8c3VtbWFyeT4NCicnIFRoaXMgVXRpbGl0eSBpcyBmb3IgdXNlciB0byBhZGQg" _
             & vbCrLf & _
            "IkNvdW50RG93biBUaW1lcnMiIGluIFBQVCBzbGlkZXMuDQonJyBJdCBhbGxvd3MgdXNlcnMg" _
             & vbCrLf & _
            "dG8gYWRkIGFueSBudW1iZXIgb2YgdGltZXJzIHdpdGggZGlmZmVyZW50IHByZXNldCBkdXJh" _
             & vbCrLf & _
            "dGlvbi4NCicnIEhvdyB0byB1c2U6DQonJyAxLiBGaW5kICJDb3VudERvd24gVGFiIiwgdGhl" _
             & vbCrLf & _
            "biBjbGljayBvbiAiSW5zdGFsbCBDb3VudERvd24iDQonJyAyLiBTZWxlY3QgYSBzbGlkZSBh" _
             & vbCrLf & _
            "bmQgY2xpY2sgb24gIkFkZCBUaW1lciINCicnIDMuIFRvIGNoYW5nZSB0aGUgcHJlc2V0IGR1" _
             & vbCrLf & _
            "cmF0aW9uICYgVGV4dEVmZmVjdCwgc2VsZWN0IGEgVGltZXIgb24gYSBzbGlkZSwgdGhlbiBj" _
             & vbCrLf & _
            "bGljayBvbiAiRWRpdCBUaW1lciINCicnIDQuIFRvIGRlbGV0ZSBhIHRpbWVyLCBzZWxlY3Qg" _
             & vbCrLf & _
            "YSBUaW1lciBvbiBhIHNsaWRlLCB0aGVuIGNsaWNrIG9uICJEZWwgVGltZXIiDQonJyA8L3N1" _
             & vbCrLf & _
            "bW1hcnk+DQonJw0KJycgPFJldmlzaW9uSGlzdG9yeT4NCicnIC0tLS0tLS0tLS0tLS0tLS0t" _
             & vbCrLf & _
            "LS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0t" _
             & vbCrLf & _
            "LS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tDQonJyBEYXRlKGRkL21tL3l5eXkpICAgIE5h" _
             & vbCrLf & _
            "bWUgICAgICAgICBEZXNjcmlwdGlvbiBvZiBDaGFuZ2VzDQonJyAtLS0tLS0tLS0tLS0tLS0t" _
             & vbCrLf & _
            "LS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0t" _
             & vbCrLf & _
            "LS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLQ0KJycgMjMvMDgvMjAyMiAgICAgICAgICBX" _
             & vbCrLf & _
            "YXluZSBKaW4gICAgSW5pdGlhbCBDcmVhdGlvbiBWZXJzaW9uIDEuMA0KJycgLS0tLS0tLS0t" _
             sBase64Variable = sBase64Variable & _
            "LS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0t" _
             & vbCrLf & _
            "LS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0NCicnIDwvUmV2aXNpb25IaXN0" _
             & vbCrLf & _
            "b3J5Pg0KT3B0aW9uIEV4cGxpY2l0DQoNClB1YmxpYyBTdWIgVG9nZ2xlU291bmQob1NoYXBl" _
             & vbCrLf & _
            "U3ltYm9sIEFzIFNoYXBlKQ0KICAgIEFwcGxpY2F0aW9uLlJ1biAiVG9nZ2xlU291bmRFeCIs" _
             & vbCrLf & _
            "IG9TaGFwZVN5bWJvbA0KRW5kIFN1Yg0KDQpQdWJsaWMgU3ViIENvdW50RG93bihvU2hhcGUg" _
             & vbCrLf & _
            "QXMgU2hhcGUpDQogICAgQXBwbGljYXRpb24uUnVuICJDb3VudERvd25FeCIsIG9TaGFwZQ0K" _
             & vbCrLf & _
            "RW5kIFN1Yg0K"
        GetModCountDownBytes = GetBytesFromBase64(sBase64Variable)
    End Function 
  10. InsertNewModuleToProject
    VBA
    Sub InsertNewModuleToProject(ByVal sModuleName As String)
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        
        Set VBProj = Application.ActivePresentation.VBProject
        Set VBComp = VBProj.VBComponents.Add(vbext_ct_StdModule)
        VBComp.Name = sModuleName
    End Sub 
  11. InsertCodesIntoModule
    VBA
    Sub InsertCodesIntoModule(ByVal sModuleName As String, _
        ByVal sCodes As String, Optional ByVal bInsertedAtTop As Boolean = True)
        Dim oVBE As VBE
        Set oVBE = Application.ActivePresentation.VBProject.VBE
        Dim oComponent As VBComponent
        Set oComponent = Application.VBE.ActiveVBProject.VBComponents(sModuleName)
        With oComponent.CodeModule
            If bInsertedAtTop Then
                .AddFromString sCodes
            Else
                .InsertLines .CountOfLines + 1, sCodes
            End If
        End With
    End Sub
  12. InsertCountDownModule
    VBA
    Public Sub InsertCountDownModule()
        Dim sModuleName As String: sModuleName = "modCountDown"
        Dim sCodes As String
        sCodes = GetStringFromBytes(GetModCountDownBytes())
        InsertNewModuleToProject sModuleName
        InsertCodesIntoModule sModuleName, sCodes
    End Sub

Credits

In order to complete this addin, I have Googled many online resources, thanks to all the authors for your generous and great sharing. Please remind me if I have missed anyone in the credit list.

History

  • 4th October, 2022: Initial version

License

This article, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)


Written By
Singapore Singapore
This member has not yet provided a Biography. Assume it's interesting and varied, and probably something to do with programming.

Comments and Discussions

 
PraiseLooking Forward for youtube tutorial Pin
Eugene Khoo 20221-Nov-22 19:57
Eugene Khoo 20221-Nov-22 19:57 
GeneralRe: Looking Forward for youtube tutorial Pin
Wayne Jin1-Nov-22 22:09
Wayne Jin1-Nov-22 22:09 
GeneralRe: Looking Forward for youtube tutorial Pin
Member 1615418216-Dec-23 1:33
Member 1615418216-Dec-23 1:33 

General General    News News    Suggestion Suggestion    Question Question    Bug Bug    Answer Answer    Joke Joke    Praise Praise    Rant Rant    Admin Admin   

Use Ctrl+Left/Right to switch messages, Ctrl+Up/Down to switch threads, Ctrl+Shift+Left/Right to switch pages.