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

Wayne Jin

5.00/5 (5 votes)

31 Oct 2022CPOL9 min read

18.8K

363

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

Download CountDown.mp4 - 1.4 MB to view the actual effect
Download CountDownAddinInstaller.zip - 2 MB to install the add-in;
To view codes, please use: codeproject.com as VBA project password

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:

Insert the relavant VBA codes via a click of Ribbon Button.
Insert a count down timer on any slide via a click of Ribbon Button.
The count down duration and TextEffect are editable.
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

Use the CountDownTimerInstaller.pptm to install and unsintall the Addin.
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.
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.
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.
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.
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.

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?

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

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.

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.

Sound Effect Source: we can use the Windows sound effect files which are stored in "C:\Windows\Media" folder (midi and wav)

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

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

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

To stop playing the media, you can use the below codes:

VBA

Sub StartPlayingMediaFile()
    mciSendString "close media", 0, 0, 0&
End Sub

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.

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.

How to Implement It?

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

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

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

Below is the frmDuration which hosts the configuration of "Duration", "Sound Effect" and "Text Effect".

Let's use "Time Emoji" symbol to show an animated effect of count down timer.

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:
However, the above Unicode(1F550) is in UTF32 format, in order to use it, we need to convert it into UFT16 format.

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;
}

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

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:

How to customize the ribbon of pptm & ppam file?

Please look into below tool shared by Fernando Andreu:
Fernando Andreu: Office Ribbonx editor

To customize the ribbon for CountDown add-in ppam with below XML:

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>

To customize the ribbon for installer pptm with below XML:

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>

Install & uninstall the CountDown Addin: to register & un-register PPT Addin: We can use the below DOS Command REG:

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

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

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:

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

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

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

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

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

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
```

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

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

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

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

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

4^th October, 2022: Initial version

License

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