一起学Excel专业开发26：使用类模块创建对象5

学习Excel技术，关注微信公众号：

excelperfect

在阅读本文之前，建议先阅读下面4篇文章：

1.一起学Excel专业开发22：使用类模块创建对象1

2.一起学Excel专业开发23：使用类模块创建对象2

3.一起学Excel专业开发24：使用类模块创建对象3

4.一起学Excel专业开发25：使用类模块创建对象4

引发事件

类模块具有引发事件的能力，这也是它的另一个强大的功能。我们可以定义自已的事件，并在代码中引发这个事件，其他类模块也可以捕获这些自定义的事件并作出相应的响应。

下面的示例演示了Cells对象引发事件，而Cell对象捕获事件并进行响应。在类模块中引发事件分两步：

1.在类模块中声明事件

2.使用RaiseEvent引发该事件

下面是修改后的CCells类模块中的代码：

代码语言：javascript复制

'创建枚举常量
Public Enum anlCellType
   anlCellTypeEmpty
   anlCellTypeLabel
   anlCellTypeConstant
   anlCellTypeFormula
End Enum
 
'声明集合对象
Private mcolCells As Collection
 
'声明模块级事件处理变量
Private WithEvents mwksWorksheet As Excel.Worksheet
 
'对事件进行声明
Event ChangeColor(uCellType AsanlCellType, bColorOn As Boolean)
 
'添加新属性,引用包含Cell对象的工作表
Property Set Worksheet(wks As Excel.Worksheet)
   Set mwksWorksheet = wks
End Property
 
'返回集合成员数
Property Get Count() As Long
   Count = mcolCells.Count
End Property
 
'通过索引值或键值从Cells集合中返回元素项
Property Get Item(ByVal vID As Variant) As CCell
   Set Item = mcolCells(vID)
End Property
 
'使For Each循环能够遍历集合
Public Function NewEnum() As IUnknown
   Set NewEnum = mcolCells.[_NewEnum]
End Function
 
'类初始化时创建新集合
Private Sub Class_Initialize()
   Set mcolCells = New Collection
End Sub
 
'添加新的Cell对象到Cells集合并分析其类型
Public Sub Add(ByRef rngCell As Range)
   Dim clsCell As CCell
   Set clsCell = New CCell
   Set clsCell.Cell = rngCell
   Set clsCell.Parent = Me
   clsCell.Analyze
   mcolCells.Add Item:=clsCell, Key:=rngCell.Address
End Sub
 
'捕获双击工作表单元格事件
Private Sub mwksWorksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   If Not Application.Intersect(Target, mwksWorksheet.UsedRange) Is Nothing Then
       RaiseEvent ChangeColor(mcolCells(Target.Address).CellType, True)
       Cancel = True
   End If
End Sub
 
'捕获右击工作表单元格事件
Private Sub mwksWorksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   If Not Application.Intersect(Target, mwksWorksheet.UsedRange) Is Nothing Then
       RaiseEvent ChangeColor(mcolCells(Target.Address).CellType, False)
       Cancel = True
   End If
End Sub
 
'捕获工作表单元格内容修改事件
Private Sub mwksWorksheet_Change(ByValTarget As Range)
   Dim rngCell As Range
   If Not Application.Intersect(Target, mwksWorksheet.UsedRange) Is NothingThen
       For Each rngCell In Target.Cells
            mcolCells(rngCell.Address).Analyze
       Next rngCell
   End If
End Sub
 
'根据单元格值类型添加背景色
Public Sub Highlight(ByVal uCellType AsanlCellType)
   Dim clsCell As CCell
   For Each clsCell In mcolCells
       If clsCell.CellType = uCellType Then
            clsCell.Highlight
       End If
   Next clsCell
End Sub
 
'取消单元格值类型相应的背景色
Public Sub UnHighlight(ByVal uCellType AsanlCellType)
   Dim clsCell As CCell
   For Each clsCell In mcolCells
       If clsCell.CellType = uCellType Then
            clsCell.UnHighlight
       End If
   Next clsCell
End Sub
 
Public Sub Terminate()
    Dim clsCell As CCell
    '释放所有子类
   For Each clsCell In mcolCells
       clsCell.Terminate
   Next clsCell
    '释放集合对象
   Set mcolCells = Nothing
End Sub

因为在CCells类和CCell类之间显示地建立了父子关系现在，所以枚举型常量anlCellType的声明在父类集合的类模块CCells中。

在CCells类中，声明了一个名为ChangeColor的事件，包含两个参数：第一个参数uCellType接受需要进行更改的单元格类型，第二个参数bColorOn指定是否进行颜色转换。

对BeforeDoubleClick事件和BeforeRightClick事件进行了修改，使之能够引发新的事件，并传递给ChangeColor事件目标单元格的类型和指定颜色开或关的布尔值。

对Add方法进行了更新，用来设置Cell对象的新属性Parent。该属性用于保存对Cells对象的引用，从而使Cells对象和Cell对象建立父子关系。

使用《一起学Excel专业开发25：使用类模块创建对象4》中介绍的方法，在CCell类模块中捕获Cells对象所引发的事件。修改后的CCell类模块代码如下：

代码语言：javascript复制

'声明模块变量
Private muCellType As anlCellType
Private mrngCell As Excel.Range
Private WithEvents mclsParent As CCells
 
'引用Cells集合对象
Property Set Parent(ByRef clsCells AsCCells)
   Set mclsParent = clsCells
End Property
 
'为属性赋值
Property Set Cell(ByRef rngCell AsExcel.Range)
   Set mrngCell = rngCell
End Property
 
'获取属性值
Property Get Cell() As Excel.Range
   Set Cell = mrngCell
End Property
 
'获取属性值
Property Get CellType() As anlCellType
   CellType = muCellType
End Property
 
'获取属性值
'转换枚举常量为文本
Property Get DescriptiveCellType() AsString
   Select Case muCellType
       Case anlCellTypeEmpty
            DescriptiveCellType = "空"
       Case anlCellTypeLabel
            DescriptiveCellType = "标签"
       Case anlCellTypeConstant
            DescriptiveCellType = "常量"
       Case anlCellTypeFormula
            DescriptiveCellType = "公式"
   End Select
End Property
 
'分析指定单元格
Public Sub Analyze()
   If IsEmpty(mrngCell) Then
       muCellType = anlCellTypeEmpty
   ElseIf mrngCell.HasFormula Then
       muCellType = anlCellTypeFormula
   ElseIf IsNumeric(mrngCell.Formula) Then
       muCellType = anlCellTypeConstant
   Else
       muCellType = anlCellTypeLabel
   End If
End Sub
 
'添加背景色
Public Sub Highlight()
   Cell.Interior.ColorIndex = Choose(muCellType   1, 5, 6, 7, 8)
End Sub
 
'取消背景色
Public Sub UnHighlight()
   Cell.Interior.ColorIndex = xlNone
End Sub
 
'捕获Cells对象的ChangeColor事件
Private Sub mclsParent_ChangeColor(uCellType As anlCellType, bColorOn As Boolean)
   If Me.CellType = uCellType Then
       If bColorOn Then
            Highlight
       Else
            UnHighlight
       End If
   End If
End Sub
 
Public Sub Terminate()
   Set mclsParent = Nothing
End Sub

在CCell类模块中，使用WithEvents声明了一个模块级的变量mclsParent，用于代表CCells类的实例，在Parent属性过程中，将一个Cells对象赋值给变量mclsParent。这样，当Cells对象引发ChangeColor事件时，Cell对象就能够捕获该事件，并根据单元格的类型进行相应的响应，如下图1所示。

图1

注意，为了更有效地避免内存泄漏，当不需要某个对象时，建议将其显示地设置为空，尽量不要依赖VBA来完成这些操作：

代码语言：javascript复制

Set gclsCells = Nothing

此外，当两个对象中分别保存着对彼此的引用时，即便将它们设置为新值或空值，系统也不会再回收它们的内存空间。其中一种解决方法是：在删除对象之前，将它与另一对象之间的相互引用关系删除。可以在类中加入新方Terminate来解决，例如：

在CCell类模块中的Terminate方法：

代码语言：javascript复制

Public Sub Terminate()
   Set mclsParent = Nothing
End Sub

在CCells类模块中的Terminate方法：

代码语言：javascript复制

Public Sub Terminate()
   Dim clsCell As CCell
    '释放所有子类
   For Each clsCell In mcolCells
       clsCell.Terminate
   Next clsCell
    '释放集合对象
   Set mcolCells = Nothing
End Sub

修改后的CreateCellsCollection过程：

代码语言：javascript复制

Public Sub CreateCellsCollection()
    Dim clsCell As CCell
   Dim rngCell As Range
   
    '清除任意已存在的Cells集合的实例
   If Not gclsCells Is Nothing Then
       gclsCells.Terminate
       Set gclsCells = Nothing
   End If
   
    '创建新的Cells集合
   Set gclsCells = New CCells
   Set gclsCells.Worksheet = ActiveSheet
   
    '对当前工作表中已使用区域中的每个单元格创建Cell对象
   For Each rngCell In Application.ActiveSheet.UsedRange
       gclsCells.Add rngCell
   Next rngCell
End Sub

在上面的代码中，如果变量gclsCells所引用的实例存在，则先执行其Terminate方法，遍历集合中所有对象，并执行它们各自的Terminate方法，最后，将gclsCells对象实例设置为空。

add excel parent 事件

0 人点赞