0度跨越

版权声明：转载时请以超链接形式标明文章原始出处和作者信息及本声明
http://pptaddins.blogbus.com/logs/49143130.html

学习写作一个PPT插件

在PowerPoint2003中，当你插入一个Shape（图形）时，PowerPoint会傻乎乎地给Shape命名为诸如：矩形1，矩形2……，看着这一大堆一模一样的孪生兄弟，我们都搞不清楚谁是谁了，即使是微软自己也一定为搞不清楚而苦恼，因此在PowerPoint2007中才提供了一个叫做“选择窗格”的东西，不过这东西还是有点问题：它不能用拖动的方式来调整对象的叠放顺序。

下面我们就分系列来写作一个能在PowerPoint2003中重命名对象、显示/隐藏对象、快速调整对象叠放顺序的插件，希望朋友们能通过这样一个实例的操作快速地入门PPT插件的开发。

一、给所选对象重命名

（1）建立一个PPT文档

（2）按Alt+F11打开VBA编程环境。

（3）选择“插入”->“类模块”，并把这个类模块命名为“clsApp”

（4）在类模块中输入下列代码：

Public WithEvents App As Application '声明一个响应事件的PPT程序对象App
Public ActiveObj As Object

Private Sub App_SlideSelectionChanged(ByVal SldRange As SlideRange)
If ActivePresentation.ReadOnly Then Exit Sub '如果演示文稿只读则退出。
    If SldRange.Count = 1 Then '如果没有选择多张幻灯片，这样就可以对所选择的幻灯片进行重命名
        cbMenu.Controls("Edit").Text = SldRange.Name
        Set ActiveObj = SldRange
    Else
        cbMenu.Controls("Edit").Text = ""
        Set ActiveObj = Nothing
    End If
End Sub

Private Sub App_WindowSelectionChange(ByVal Sel As Selection)
If ActivePresentation.ReadOnly Then Exit Sub
    Select Case Sel.Type '判断选区类型
        Case ppSelectionText '选择的是文本框
            cbMenu.Controls("Edit").Text = Sel.ShapeRange.Name
            Set ActiveObj = Sel.ShapeRange
        Case ppSelectionShapes '选择的是Shape
            If Sel.ShapeRange.Count = 1 Then '只能选一个Shape，否则出错
                cbMenu.Controls("Edit").Text = Sel.ShapeRange.Name
                Set ActiveObj = Sel.ShapeRange
            Else
                cbMenu.Controls("Edit").Text = ""
                Set ActiveObj = Nothing
            End If
        Case ppSelectionNone '什么也没有选
            cbMenu.Controls("Edit").Text = ""
            Set ActiveObj = Nothing
    End Select
End Sub

（5）插入一个模块并命名为mdApp，输入下列代码：

Public clsApp As New clsApp '声明刚才插入的类模块的实例clsapp
Public cbMenu As CommandBar '声明一个命令栏对象

'下面是两个自动运行的宏，这个宏只在PPA中才有效。
Sub Auto_Open()
    Set clsApp.App = Application '把当前的程序实例与类中的App对象进行关联
    CreateMenu '建立工具栏
End Sub

Sub Auto_Close()
On Error Resume Next
    CommandBars("Name Tools").Delete '退出程序时删除建立的命令栏
    End
End Sub

'###############################
'建立命令栏的子过程
'###############################
Sub CreateMenu()
    On Error Resume Next
    CommandBars("Name Tools").Delete
    Err.Clear
    Dim cbCtl As CommandBarControl '声明一个命令栏上的控件

    Set cbMenu = CommandBars.Add("Name Tools") '增加一个叫做"Name Tools"的命令栏
        With cbMenu.Controls.Add(msoControlEdit) '在这个命令栏上增加一个Edit控件
            .Caption = "Edit"
            .OnAction = "Change" '响应动作：Change
        End With
    cbMenu.Visible = True '让命令栏可见
End Sub

'#########################################
'给所选择的对象重命名的子过程
'#########################################
Sub Change()
    On Error Resume Next
    With cbMenu.Controls("Edit")
        If .Text = "" Then: .Text = clsApp.ActiveObj.Name '把所选择对象的名字显示在文框中
        clsApp.ActiveObj.Name = .Text '输入名字并按下回车给对象重命名
        Select Case Err '捕捉错误信息并进行处理
            Case 70
                ActiveWindow.Selection.SlideRange.Shapes(.Text).Select
            Case -2147188160
                ActivePresentation.Slides(.Text).Select
        End Select
    End With
End Sub

（6）在PowerPoint中选择“文件”->“另存为”，“保存类型”选择“PowerPoint 加载宏（*.ppa）”，一个给对象重命名的插件就做好了。

（7）测试效果，在PowerPoint中，选择“工具”->“加载宏”，然后浏览至你刚才保存的文件就可以加载我们刚才编写的插件了。

示例插件下载：http://www.brsbox.com/filebox/down/fc/b68fb4ee97cce3b08c5255d58b872410

下一讲，我将改写上面的代码，把它放入到一个窗体中，从而实现命名的批量功能和对象的显示/隐藏功能。