给Shape对象添加事件,实时监测对象变化

wpxxsyzx

    逛msdn，无意间发现CommandBars对象具有OnUpdata事件，其解释也很简单，就是工具栏更新时触发此事件。经测试，很多常用操作都会引起工具栏的更新，所以，可以利用这个事件实时监测用户是否对某些对象执行了操作，既某些对象是否发生变化，例如：选择、添加、删除Shape对象，更改工作表的顺序，使用鼠标滚轮滚动表格等（excel本身不为这些对象的变化提供相关的事件）。
    说在前面，说是给Shape对象添加事件，其实也可以给其他对象添加额外的事件来监测对象的变化；示例都写成类的形式，是为了方便演示和理解，其实也可以直接在代码中使用OnUpdata事件而不用写入类模块里。总之，本帖是为了介绍OnUpdata事件，示例没有全面考虑所有可能的情况，还有很多漏洞，仅仅是个介绍，有兴趣的朋友可以研究下，使之更完善或者实现更多的功能。
下面通过一个简单例子来认识一下OnUpdata事件，此示例监测显示比例是否变化，如果是，根据情况作出相应的调整。

1、添加一个类模块clsZoom,并输入以下声明
Public WithEvents cmdBars As CommandBars
Public Event Zoom(ByVal number As Integer)
    使用WithEvents声明变量cmdBars 为 CommandBars类型，WithEvents关键字用来引出CommandBars对象的事件：OnUpdata（这个事件也是CommandBars对象公开的唯一一个事件），并把事件添加到VBE编辑器“过程”列表框里。
    使用Event语句为类声明一个名字为Zoom的事件过程
2、在VBE编辑器界面依次单击“对象”列表框——“cmdBars”选项，为类添加“cmdBars_OnUpdate”事件。
3、依次单击“对象”列表框——“Class”选项——“过程”列表框——“Class”选项，为类添加初始化事件“Class_Initialize”。

完整的代码：
Public WithEvents cmdBars As CommandBars
Public Event Zoom(ByVal number As Integer)
Private Sub Class_Initialize()
    '将应用程序的CommandBars对象赋值给变量cmdBars，当用户在界面或使用代码操作excel时，
    '将会使CommandBars对象产生更新，触发cmdBars_OnUpdate事件
    Set cmdBars = Application.CommandBars
End Sub
Private Sub cmdBars_OnUpdate()
    If ActiveWindow.Zoom <> 100 Then
        '使用RaiseEvent语句触发Zoom事件并把当前窗口的显示比例作为参数传入
        RaiseEvent Zoom(ActiveWindow.Zoom)
    End If
End Sub
4、在ThisWorkbook模块添加以下代码：
Private WithEvents MyZoom As clsZoom
    使用WithEvents 声明变量MyZoom 为 clsZoom类型，引出我们在clsZoom类模块里使用Event语句声明的Zoom事件并添加到VBE编辑器“过程”列表框里。
5、依次单击“对象”列表框——“MyZoom”选项——“过程”列表框——“Zoom”选项，添加MyZoom_Zoom事件过程并输入代码。
Private Sub MyZoom_Zoom(ByVal number As Integer)
'在这里输入你的代码以实现在显示比例变化时想要的结果
    If number > 100 Or number < 80 Then
        ActiveWindow.Zoom = 100
    End If
End Sub
6、添加如下代码
Private Sub Workbook_Open()
    Set MyZoom = New clsZoom
End Sub
7、代码是如何工作的
     在打开工作薄时使用New关键字创建clsZoom类的实例并赋值给变量MyZoom，代码转到clsZoom类模块中的Private Sub Class_Initialize()事件过程中执行。当用户操作excel时将会触发clsZoom类模块中的Private Sub cmdBars_OnUpdate()事件过程，执行该过程中的代码，如果用户在界面修改或者使用代码修改了显示比例，则使用RaiseEvent语句触发 Zoom事件，代码转到ThisWorkbook模块中的Private Sub MyZoom_Zoom(ByVal number As Integer)事件过程中继续执行，如果显示比例不在规定范围内，则调整显示比例为100。

wpxxsyzx

    回到帖子标题上来，给Shape对象添加事件。添加多个事件，分别监测是否选择、添加、删除、Shape对象以及是否改变Shape对象的位置和尺寸。没有考虑同时操作多个对象的情况，切换工作表等情况有兴趣的朋友可以完善一下。打开示例，添加、删除、选择Shape对象，改变对象位置或尺寸即可触发相应的事件。

类模块代码：
Public WithEvents CMDBars As Office.CommandBars
'以下5句代码声明5个事件
Public Event ShapeSelectChange(ByVal shp As Shape)
Public Event ShapeMove(ByVal shp As Shape)
Public Event ShapeResize(ByVal shp As Shape)
Public Event ShapesAdd(ByVal shp As Shape)
Public Event ShapesDelete(ByVal name As String)
'存储当前选择的Shape对象以及对象的位置、尺寸、名字
Private NowShape As Shape
Private Top As Single
Private Left As Single
Private Width As Single
Private Height As Single
Private name As String
'Names集合用来存储在添加、删除Shape对象前
'各个Shape对象的名称
Private Names As New Collection

Private Sub Class_Initialize()
    Set CMDBars = Application.CommandBars
    Set NowShape = GetShape()
    Call GetShapes
    If Not NowShape Is Nothing Then
        Top = NowShape.Top
        Left = NowShape.Left
        Width = NowShape.Width
        Height = NowShape.Height
        name = NowShape.name
    End If
End Sub
Private Sub CMDBars_OnUpdate()
    Set NowShape = GetShape()
    '如果当前选中的是Shape对象则将对象的5个属性值
    '赋值给5个变量，以备下次变化时做比对
    If NowShape Is Nothing Then
        name = ""
        Width = 0
    Else
        Call ShapeEvent
        Top = NowShape.Top
        Left = NowShape.Left
        Width = NowShape.Width
        Height = NowShape.Height
        name = NowShape.name
    End If
    Call ShapesEvent
    Call GetShapes
End Sub
Private Function GetShape() As Shape
    Dim shp As Shape
    Dim shprange As ShapeRange
    On Error Resume Next
        Set shprange = Application.Selection.ShapeRange
    If Not shprange Is Nothing Then Set shp = shprange.Item(1)
    Set GetShape = shp
End Function
Private Sub ShapeEvent()
    '如果当前选择的是Shape对象，并且名字和name变量里不一致
    '并且当前Sheets集合数量和names集合数量一致，说明不是新添加Shape对象
    '可能是用户选择发生变化了触发了CMDBars_OnUpdate事件
    If Not NowShape Is Nothing Then
        If NowShape.name <> name Then
            If Application.ActiveSheet.Shapes.Count = Names.Count Then
                RaiseEvent ShapeSelectChange(NowShape)
            End If
        Else '否则，可能是改变Shape对象的位置或尺寸触发了CMDBars_OnUpdate事件
              '把NoeShape对象的四个属性和四个变量比较，并触发相应的事件
            If name <> "" Then
                If NowShape.Top <> Top Or Left <> Left Then
                    RaiseEvent ShapeMove(NowShape)
                End If
                If NowShape.Width <> Width Or NowShape.Height <> Height Then
                    RaiseEvent ShapeResize(NowShape)
                End If
            End If
        End If
    End If
End Sub
Private Sub GetShapes()
    Dim shp As Shape
    Set Names = New Collection
    With Application.ActiveSheet
        If .Shapes.Count > 0 Then
            For i = 1 To .Shapes.Count
              Names.Add (.Shapes(i).name)
            Next
        End If
    End With
End Sub
Private Sub ShapesEvent()
    Dim shp As Excel.Shape
    With Application.ActiveSheet
    '比较当前Sheets集合数量和Names集合数量，如果不一致，
    '说明可能是添加、删除Shapes对象触发了CMDBars_OnUpdate事件
        If .Shapes.Count > Names.Count Then
            RaiseEvent ShapesAdd(NowShape)
        ElseIf .Shapes.Count < Names.Count Then
            For i = 1 To Names.Count
                On Error Resume Next
                '把删除的对象赋值给shp变量将产生错误
                Set shp = .Shapes(Names.Item(i))
                If Err.Number = -2147024809 Then
                    RaiseEvent ShapesDelete(Names.Item(i))
                    Exit Sub
                End If
            Next
        End If
    End With
End Sub

ThisWorkbook模块代码：
Private WithEvents MyShape As EventShape
'在对象列表框里选择“SelectShape”，在过程列表框里依次单击各个选项，
'添加以下5个事件过程，每个事件过程里添加你自己的代码，
Private Sub MyShape_ShapeMove(ByVal shp As Shape)
    '添加你的代码
    MsgBox "移动图形“" & shp.name & "”"
End Sub
Private Sub MyShape_ShapeSelectChange(ByVal shp As Shape)
    MsgBox "选中图形“" & shp.name & "”"
End Sub
Private Sub MyShape_ShapeResize(ByVal shp As Shape)
    MsgBox "图形“" & shp.name & "”的尺寸改变"
End Sub
Private Sub MyShape_ShapesAdd(ByVal shp As Shape)
    MsgBox "增加图形“" & shp.name & "”"
End Sub
Private Sub MyShape_ShapesDelete(ByVal name As String)
    MsgBox "删除图形“" & name & "”"
End Sub
Private Sub Workbook_Open()
    Set MyShape = New EventShape
End Sub

wpxxsyzx

这个没意思？OnUpdata是个好东西啊！

wcymiss

这么有料的东东居然没人顶啊。收了

老师应该换个比较噱头标题，如：

谁动了我的Excel？------用OnUpload事件实时监控Excel

或

Excel克格勃------ComandBar的OnUpload事件

（捂嘴笑）

lee1892

Application 级的，同Session跨文件响应...

liucqa

支持一下  

xvideo

好东西，支持，并提问：
能否为一些Shape添加MouseMove事件呢？

wangchangping

刚刚发现版主的作品,好用啊,赞一个

五音

这个，厉害了！！！

hanyu518

谢谢分享 纠结了几天的问题，看到这篇文章，终于解决了，谢谢