将事件代码添加到 PowerPoint VBA 中的复选框

Question

我正在开发一个 PowerPoint 2010 幻灯片，向用户展示一系列页面，其中包含一个语句、一个复选框（由标签元素构建以启用更改复选框的大小）和每页上的前进/后退箭头。

由于这将用于具有不同数量页面的众多项目，我正在使用 PowerPoint VBA 动态构建“甲板”，以便从包含单个语句列表的 Excel 电子表格动态构建页面。

我已经能够编写 VBA 代码来打开 Excel 文件，将语句读入 PowerPoint 中的数组，并使用页面上的所有元素构建适当数量的页面。至此，一切正常。我遇到困难的地方是将单击操作分配给复选框。

这是页面构建例程调用以插入复选框的代码（显然在此之前还有更多代码用于访问 Excel 文件、创建页面和添加“语句”文本框...所有哪个有效）：

Sub AddSelectBox(Index As Integer, pptBuildingSlide As Slide)

'Add Checkbox
    With pptBuildingSlide.Shapes.AddOLEObject(Left:=342, Top:=294, Width:=42, Height:=42, ClassName:="Forms.Label.1")
        .Name = "label" & Index
        .OLEFormat.Object.Font.Name = "Wingdings 2"
        .OLEFormat.Object.Font.Charset = "2"
        .OLEFormat.Object.Caption = "£"
        .OLEFormat.Object.Font.Size = 40
    End With

'Add Checkbox Click Code
'(CODE FOR ADDING CLICK EVENT TO EACH BOX GOES HERE)

End Sub

每个页面上的复选框都有一个谨慎的名称，与页码相关（例如 Label1、Label2 等）。我需要将以下代码添加到每个页面上的每个复选框以切换复选标记，以便稍后在程序中我可以通过阅读“标题”属性看到哪些被选中。 （字体设置为“Wingdings 2”以在点击时给出一个空白框和一个选中框）

Private Sub Label1_Click()

   If Label1.Caption = "£" Then
       Label1.Caption = "R"
   Else
       Label1.Caption = "£"
   End If

End Sub

我在网上搜索了动态添加事件代码的任何引用，并找到了许多示例（例如Assign on-click VBA function to a dynamically created button on Excel Userform），但几乎所有示例都是针对 Excel 或 Access。我应该指出，编码“不是我的日常工作”，而且我已经成功地阅读了“掌握 Office 2003 的 VBA”和网络搜索……所以我将这些示例转换为 PowerPoint 的能力不足。感谢您提供的任何帮助。

5/29 附加信息：
我遇到了.CreateEventProc 方法作为将代码写入VBA 的一种方式。我找到的示例是在this site 为 Excel 编写的。我已经做到了这一点（消息框代码将替换为点击代码，但我只是将其用于测试以避免引入其他错误）...

Sub CreateEventProcedure()
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule
    Dim LineNum As Long
    Const DQUOTE = """" ' one " character

    Set VBProj = ActivePresentation.VBProject
    Set VBComp = VBProj.VBComponents(Slides(1))
    Set CodeMod = VBComp.CodeModule

    With CodeMod
        LineNum = .CreateEventProc("Click", "Label1")
        LineNum = LineNum + 1
        .InsertLines LineNum, "    MsgBox " & DQUOTE & "Hello World" & DQUOTE
    End With
End Sub

...但在(slides(1)) 处得到“编译错误：未定义子或函数”。任何清理它的帮助（如果它实际上是一个合适的解决方案）将不胜感激。

Answer 1

你必须使用标签吗？ （我了解尺寸，但您可以添加一个更容易的形状。）

基于： 这只有在您允许访问安全中的 VBE 时才有效（不能在代码中完成）

    Sub makeBox()
Dim strCode As String
With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 10, 10, 20, 20)
.Fill.Visible = False
.Line.Visible = False
With .TextFrame.TextRange.Font
.Name = "Wingdings 2"
.Size = 40
.Color.RGB = vbBlack
End With
.TextFrame.TextRange = "£"
With .ActionSettings(ppMouseClick)
.Action = ppActionRunMacro
.Run = "chex"
End With
End With
strCode = "Sub chex(oshp As Shape)" & vbCrLf & "If oshp.TextFrame.TextRange =" & Chr(34) & "£" & Chr(34) & "Then" _
& vbCrLf & "oshp.TextFrame.TextRange = " & Chr(34) & "R" & Chr(34) & vbCrLf _
& "Else" & vbCrLf & "oshp.TextFrame.TextRange =" & Chr(34) & "£" & Chr(34) & vbCrLf & "End If" & vbCrLf & "End Sub"
With ActivePresentation.VBProject.VBComponents.Add(vbext_ct_StdModule)
.CodeModule.AddFromString (strCode)
End With
End Sub