65.9K
CodeProject 正在变化。 阅读更多。
Home

为 PowerPoint 创建倒计时器插件 - 第一部分

Wayne Jin
starIconstarIconstarIconstarIconstarIcon

5.00/5 (5投票s)

2022 年 10 月 4 日

CPOL

9分钟阅读

viewsIcon

20667

downloadIcon

400

一篇关于为 PowerPoint 创建倒计时器插件的演练文章

下载

引言

本文档将向您展示如何使用 VBA 为 PowerPoint 创建倒计时器插件，以及与此任务相关的各种知识。在下一篇文章（第二部分）中，我将向您展示如何使用 C# 为同一个倒计时器制作 VSTO 插件。

以下是我希望通过此插件实现的目标列表

  1. 通过单击功能区按钮插入相关的 VBA 代码。
  2. 通过单击功能区按钮将倒计时器插入到任何幻灯片上。
  3. 倒计时持续时间和 TextEffect 是可编辑的。
  4. 在幻灯片放映模式下，单击计时器 - 它将开始倒计时，当倒计时器达到 0 时，将触发警报声音（可配置和静音），但倒计时将继续为负值，直到用户再次单击计时器或幻灯片放映结束。

背景

倒计时器的原始创意来自 Karina Adcock 的 YouTube 教程。她在视频（“如何使用 VBA 在 PowerPoint 中制作倒计时器？”）中分享了一个非常巧妙的解决方案。感谢 Karina 的精彩分享。

我尝试在 Karina Adcock 的解决方案基础上增强功能，然后发现要制作一个具有我在引言部分列出的所有功能的体面插件并不容易。

我认为在此分享我的学习成果可能很有用。

Using the Code

  1. 使用 CountDownTimerInstaller.pptm 安装和卸载插件。

  2. 打开您自己的 PPT 或创建一个新的 PPT 并将其保存为 pptm 格式，然后在功能区找到“CountDown”选项卡，单击“安装 CountDown”将 VBA 代码插入到当前 PPT 中。

  3. 单击“添加计时器”将 CountDown 形状插入到当前幻灯片上，将弹出一个对话框供您配置持续时间、声音效果和文本效果，然后单击 **OK**。

  4. CountDown Timer 现已成功安装在当前幻灯片上，要测试效果，只需打开“幻灯片放映”模式并单击计时器，它就会开始倒计时，再次单击或结束“幻灯片放映”即可停止。

  5. 如果您没有看到上面提到的 CountDown Tab，请选择 Developer Tab，然后单击 Powerpoint Add-in 按钮打开插件管理器对话框。您应该会在可用的插件框中看到 CountDownAddin，只需勾选它即可加载此插件，然后单击 Close 按钮。

  6. 如果您也没有看到 Developer Tab，请从菜单栏选择 File\Options 打开 Powerpoint Options 对话框，然后单击 Customize Ribbon Tab。您应该会在右侧窗格中看到 Developer 节点，只需勾选它即可加载此插件，然后单击 Ok 按钮关闭 Options 对话框。

以下是一些可能引起您兴趣的代码片段

1. 倒计时器的基本功能

首先，让我们看看 Karina Adcock 的原始代码

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

为了使 CountDown 方法更灵活并适用于您 PPT 中的任何幻灯片，我们不能硬编码幻灯片编号。倒计时持续时间也是如此。

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

测试后，您会发现“修订 1”将无法工作，因为以下语句“Application.ActiveWindow.View.Slide.SlideNumber”将立即退出子程序。因此，我采用了如下所示的修订 2

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

修订 2 工作正常。但是 Windows(1) 中的索引号“1”和形状名称“rectangle”也是硬编码的。这仍然不是一个万无一失的解决方案，这就是为什么我选择修订 3。

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

这是一个更简洁的解决方案，因为我们不关心幻灯片编号和形状名称。而且，现在它也适用于同一幻灯片上的多个 CountDown 计时器。

注意：如何使用上述代码？

  1. 打开您自己的 PPT 或创建一个新的 PPT，然后将其保存为 pptm 格式。
  2. 按 Alt+F11 打开 VBE（VBA 编辑器），插入一个模块，粘贴修订 3 中的代码片段。
  3. 再次按 Alt+F11 切回 PPT，在当前幻灯片上插入一个矩形形状。
  4. 选中矩形形状，然后插入“Action”，在弹出的对话框中，单击“Run Macro”，选择“CountDown”，然后单击 OK。

  5. 打开“幻灯片放映”模式，单击计时器，倒计时将开始。就是这样！

2. 增强倒计时器的功能

基本上，我们想配置持续时间、声音效果和文本效果。

  1. 持续时间：我们需要一个地方来存储持续时间值（以分钟为单位），每个形状都有一个 AlternativeText 属性，这是一个存储我们值的不错选择。
  2. 声音效果：当计时器计数到零时，我们需要一些警报声音来提醒演示者，让我们在计时器旁边插入一个炸弹符号，并使用其 AlternativeText 属性来存储声音效果选择。
    1. 声音效果来源：我们可以使用存储在“C:\Windows\Media”文件夹中的 Windows 声音效果文件（midi 和 wav）。
    2. 如何异步播放声音？使用下面的 Windows API。
      #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. 为了节省文件加载时间并获得更流畅的声音播放体验，我们可以使用下面的代码预加载媒体文件。在加载现有声音效果之前，它将停止当前正在播放的声音（如果存在）。“MPEGVideo”编解码器类型可用于播放 midi、wav 和 mp3 文件。
      '---------------------------------------------------------
' 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. 要异步重复播放媒体，您可以使用以下代码
      Sub StartPlayingMediaFile()
    mciSendString "play media repeat", 0, 0, 0&
End Sub
    5. 要停止播放媒体，您可以使用以下代码
      Sub StartPlayingMediaFile()
    mciSendString "close media", 0, 0, 0&
End Sub
    6. 为了帮助用户找到合适的声音效果，当用户选择不同的声音时，该声音将被播放，单击 **OK** 按钮停止声音并确认选择。

  3. 文本效果：我们使用 WordArt 来增强计时器的视觉效果，文本效果存储在 oShape.TextEffect.PresetTextEffect 属性中。WordArt 有 40 种文本效果。为了帮助用户选择正确的效果，我们需要展示每种选择可能的外观。

    如何实现？

    1. 我们可以使用下面的代码在一张幻灯片中插入所有 40 种 WordArt 文本效果
      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. 详情请参阅下图

    3. 让我们使用在线拆分工具将上图拆分成 40 个大小相等的小图像。
      分割图片 | 在线免费 | Aspose.PDF
    4. 在 frmDuration 用户窗体中插入 40 个 ImageControl 并将它们分组在框架控件中。

    5. 调整用户窗体大小以隐藏框架控件，当用户选择不同的文本效果时，只需从 40 个 ImageControl 中分配图像。
      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. 下面是包含“持续时间”、“声音效果”和“文本效果”配置的 frmDuration。

  5. 让我们使用“时间表情符号”符号来展示倒计时器的动画效果。
    1. 要显示表情符号，我们需要知道其 Unicode，打开一个 PPT 幻灯片，插入一个形状，然后插入一个符号，选择“Segoe UI Emoji”并查找时间符号，如下图所示

    2. 但是，上面的 Unicode(1F550) 是 UTF32 格式的，为了使用它，我们需要将其转换为 UTF16 格式。
    3. 如何转换？让我们遵循 Anurag S Sharma 在下面的链接中分享的示例
      是否可以使用仅 Windows API 将 UTF32 文本转换为 UTF16？ 
      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. 让我们将上面的 C++ 代码转换为 VBA。因为 VBA 不支持移位操作，所以我们必须在这里使用 VBA 版本的移位操作。shl 和 shr 函数的功劳归于下面的博客
      Excel 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. 让我们运行 TestConversionFromUTF32ToUTF16，结果是 (55357, 56656)。所以“时钟”符号可以用 chrw(55357)+chrw(56656) 来表示。当 CountDown 计时时，我们可以将符号从 12 点更改为 11 点，依此类推。

关注点

在完成 CountDown 计时器的所有功能后，仍然需要一些额外的工作。

以下是一些我使用的有趣的代码片段

  1. 如何自定义 pptm 和 ppam 文件的功能区？

    请查看 Fernando Andreu 分享的以下工具
    Fernando Andreu: Office Ribbonx editor
  2. 使用以下 XML 为 CountDown 插件 ppam 自定义功能区
    <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. 使用以下 XML 为安装程序 pptm 自定义功能区
    <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. 安装和卸载 CountDown Addin：注册和取消注册 PPT Addin：我们可以使用以下 DOS 命令 REG

    有关注册表项，请参阅以下屏幕截图

    现在我们知道了与 PPT 插件的注册和取消注册相关的注册表项，为了确保此类操作立即生效，我们必须退出 PPT 应用程序并重新启动它，因此我们将再次需要延迟执行技术。以下是“注册和取消注册”任务的实际代码

    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. 取消注册插件后删除插件文件：要完全卸载插件，我们需要删除它。但是，当我们仍在 PPT 应用程序中时，此操作将失败。因此，我们需要触发一个在退出 PPT 应用程序后仍然会执行的操作。以下是我在此安装程序中使用的 meuod
    1. 启动带参数的 Shell 进程
      Public Sub RunShellWithArgument(ByVal sProgramName As String, _
                                ByVal sArgument As String)
    Call Shell("""" & sProgramName & """ """ & sArgument & """", vbHide)
End Sub
    2. 在 Shell 进程中使用 DOS 命令进行延迟执行
      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. 有了上述功能，我们现在就可以进行插件文件的延迟删除了
      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. 我在上面提到，我们需要退出 PPT 应用程序来进行延迟启动的操作，但是，Application.Quit 有时会运行错误。为了在没有错误提示的情况下在 VBA 中退出 PPT，我们可以使用以下 Windows API，感谢 John_w 的分享：John_w: 使用 Windows API 关闭窗口。
      #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. 检查此代码是否在插件模式下运行
    Public bRunningAsAddin As Boolean

' It will only be triggered in Addin
Sub Auto_Open()
    bRunningAsAddin = True
End Sub
  7. PPT 中的 VBA 调用插件中的函数

    “CountDown”是在 PPT 中插入的一个子程序，“CountDownEx”是插件中定义的一个子程序。

    Public Sub CountDown(oShape As Shape)
    Application.Run "CountDownEx", oShape
End Sub
  8. 编码和解码 Base64 字符串
    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. 存储在 string 中的 CountDown 模块
    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 
    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 
    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 
    Public Sub InsertCountDownModule()
    Dim sModuleName As String: sModuleName = "modCountDown"
    Dim sCodes As String
    sCodes = GetStringFromBytes(GetModCountDownBytes())
    InsertNewModuleToProject sModuleName
    InsertCodesIntoModule sModuleName, sCodes
End Sub

致谢

为了完成这个插件，我搜索了许多在线资源，感谢所有作者的慷慨和精彩分享。如果我在致谢列表中遗漏了任何人，请提醒我。

历史

  • 2022 年 10 月 4 日：初始版本
© . All rights reserved.