VBA 在另一个 class 上引发事件

Question

我正在尝试实施 this post in codereview

的建议

Objective:

管理用户与 Excel Tables (ListObjects)

交互时发生的情况

最后的想法是为不同的表设置自定义事件。例如当您向 table1 添加一行时，将引发自定义 AddEvent1，而当您对 table2 执行相同操作时，将引发 AddEvent2。

只有一个 class 来管理事件和一个来保存表格及其信息。

所以建议的流程是：

将列表对象添加到名为 Table
class 会监听父 sheet 上的事件（Change 和 SelectionChange）
触发更改事件时，从 class TableManager 触发自定义事件来处理这些事件（事件如 adding、updating 或 deleting行）

编辑#1：

调整代码：

Create 函数现在 returns 一个 Table
并且属性 Set SourceTable 现在将 listObjectParentSheet 字段设置为相应的值

但是 Table Manager 仍然没有监听 listObjectParentSheet_Change

中引发的事件

组件：

1) 带有 Excel Table (ListObject) 的 Sheet 和后面的代码：

Private Sub Worksheet_Activate()

    Dim myTable As Table
    Dim myTableManager As TableManager

    Set myTable = Table.Create(Me.ListObjects(1))

    Set myTableManager = New TableManager

    Set myTableManager.TableInstance = myTable

End Sub

2) Class Table（使用 rubberduck 将预先声明的 id 设置为 true）

'@Folder("VBAProject")

Option Explicit
'@PredeclaredId

Private Type TTable
    SourceTable As ListObject
End Type

Private this As TTable

Private WithEvents listObjectParentSheet As Excel.Worksheet

Public Event AddEvent()

Public Property Get SourceTable() As ListObject
    Set SourceTable = this.SourceTable
End Property

Public Property Set SourceTable(ByVal value As ListObject)
    Set this.SourceTable = value
    Set listObjectParentSheet = value.Parent
End Property

Public Property Get Self() As Table
    Set Self = Me
End Property

Public Function Create(ByVal EvalSourceTable As ListObject) As Table
    With New Table
        Set .SourceTable = EvalSourceTable
        Set Create = .Self
    End With
End Function

Private Sub listObjectParentSheet_Change(ByVal Target As Range)
    If Not Intersect(Target, SourceTable.DataBodyRange) Is Nothing Then
        MsgBox listObjectParentSheet.Name & " " & Target.Address
        RaiseEvent AddEvent
    End If
End Sub

3) Class TableManager

Option Explicit

Private WithEvents m_table As Table

Public Property Get TableInstance() As Table
    Set TableInstance = m_table
End Property

Public Property Set TableInstance(ByRef tableObject As Table)
    Set m_table = tableObject
End Property

Private Sub m_table_AddEvent()
    MsgBox "Adding something"
End Sub

Question/issue:

我还没有弄清楚如何在 TableManager class 中触发 "AddEvent"。我知道我弄乱了实例化 classes 的一些概念，但我不知道我做错了什么。

预期结果：

当用户更改列表对象的任何单元格时，在引发 AddEvent 时显示消息框 "Adding something"

任何帮助将不胜感激。

编辑#2

最终代码感谢 Mat 的回答：

Sheet:Sheet1:

Private Sub Worksheet_Activate()
    With TableManager
        Set .TableEvents = Table.Create(Sheet1.ListObjects(1))
    End With
End Sub

模块：ListObjectUtilities

Option Explicit

Public Function GetCellRow(ByVal EvalTable As ListObject, ByVal EvalCell As Range) As Long

    If Intersect(EvalCell, EvalTable.DataBodyRange) Is Nothing Then Exit Function

    GetCellRow = EvalCell.Row - EvalTable.HeaderRowRange.Row

End Function

Public Function GetCellColumn(ByVal EvalTable As ListObject, ByVal EvalCell As Range) As Long

    If Intersect(EvalCell, EvalTable.DataBodyRange) Is Nothing Then Exit Function

    GetCellColumn = EvalCell.Column - EvalTable.HeaderRowRange.Column + 1

End Function

Class: ITable

Option Explicit

Public Property Get SourceTable() As ListObject
End Property

Class: Table

'@Folder("VBAProject")
'@PredeclaredId
Option Explicit

Private WithEvents TableSheet As Excel.Worksheet

Private Type TTable
    SourceTable As ListObject
    LastRowCount As Long
    LastColumnCount As Long
End Type

Private this As TTable

Public Event Changed(ByVal cell As Range)
Public Event AddedNewRow(ByVal newRow As ListRow)
Public Event AddedNewColumn(ByVal newColumn As ListColumn)

Implements ITable

Public Function Create(ByVal Source As ListObject) As ITable
    With New Table
        Set .SourceTable = Source
        Set Create = .Self
    End With
End Function

Public Property Get Self() As Table
    Set Self = Me
End Property

Public Property Get SourceTable() As ListObject
    Set SourceTable = this.SourceTable
End Property

Public Property Set SourceTable(ByVal value As ListObject)
    ThrowIfSet this.SourceTable
    ThrowIfNothing value
    Set TableSheet = value.Parent
    Set this.SourceTable = value
    Resize
End Property

Friend Sub OnChanged(ByVal Target As Range)
    RaiseEvent Changed(Target)
End Sub

Friend Sub OnAddedNewRow(ByVal newRow As ListRow)
    RaiseEvent AddedNewRow(newRow)
End Sub

Friend Sub OnAddedNewColumn(ByVal newColumn As ListColumn)
    RaiseEvent AddedNewColumn(newColumn)
End Sub

Private Sub ThrowIfNothing(ByVal Target As Object)
    If Target Is Nothing Then Err.Raise 5, TypeName(Me), "Argument cannot be a null reference."
End Sub

Private Sub ThrowIfSet(ByVal Target As Object)
    If Not Target Is Nothing Then Err.Raise 5, TypeName(Me), "This reference is already set."
End Sub

Private Sub Resize()
    With this.SourceTable
        this.LastRowCount = .ListRows.Count
        this.LastColumnCount = .ListColumns.Count
    End With
End Sub

Private Sub TableSheet_Change(ByVal Target As Range)

    If Intersect(Target, SourceTable.DataBodyRange) Is Nothing Then Exit Sub

    Select Case True
    Case this.SourceTable.DataBodyRange.Columns.Count > this.LastColumnCount
        OnAddedNewColumn SourceTable.ListColumns(ListObjectUtilities.GetCellColumn(this.SourceTable, Target))
    Case this.SourceTable.DataBodyRange.Rows.Count > this.LastRowCount
        OnAddedNewRow SourceTable.ListRows(ListObjectUtilities.GetCellRow(this.SourceTable, Target))
    Case Else
        OnChanged Target
    End Select
    Resize
End Sub

Private Property Get ITable_SourceTable() As ListObject
    Set ITable_SourceTable = this.SourceTable
End Property

Class: TableManager

'@Folder("VBAProject")
'@PredeclaredId
Option Explicit
Private WithEvents MyTable As Table

Public Property Get TableEvents() As Table
    Set TableEvents = MyTable
End Property

Public Property Set TableEvents(ByVal value As Table)
    Set MyTable = value
End Property

Private Sub MyTable_AddedNewColumn(ByVal newColumn As ListColumn)
    MsgBox "Added new column " & newColumn.Range.Column
End Sub

Private Sub MyTable_AddedNewRow(ByVal newRow As ListRow)
    MsgBox "Added new row " & newRow.Range.Row
End Sub

Private Sub MyTable_Changed(ByVal cell As Range)
    MsgBox "Changed " & cell.Address
End Sub

Sample file

Answer 1

我尝试重现，但后来发现依赖 Worksheet.Activate 来注册处理程序，往往会出现错误行为：有时您需要 "wiggle" sheet 以便它跟上，特别是如果您正在编辑代码。可能只是 :)

请注意，为了能够触发 AddedNewRow、AddedNewColumn，甚至 RemovedRow 或 RemovedColumn，您需要不断跟踪table 混合了 Worksheet.Change 和 Worksheet.SelectionChange 处理程序。

Table class 模块:

'@Folder("VBAProject")
'@PredeclaredId
Option Explicit

Private WithEvents TableSheet As Excel.Worksheet

Private Type TTable
    SourceTable As ListObject
    LastRowCount As Long
    LastColumnCount As Long
End Type

Private this As TTable

Public Event Changed(ByVal cell As Range)
Public Event AddedNewRow(ByVal newRow As ListRow)
Public Event AddedNewColumn(ByVal newColumn As ListColumn)

Public Function Create(ByVal Source As ListObject) As Table
    With New Table
        Set .SourceTable = Source
        Set Create = .Self
    End With
End Function

Public Property Get Self() As Table
    Set Self = Me
End Property

Public Property Get SourceTable() As ListObject
    Set SourceTable = this.SourceTable
End Property

Public Property Set SourceTable(ByVal Value As ListObject)
    ThrowIfSet this.SourceTable
    ThrowIfNothing Value
    Set TableSheet = Value.Parent
    Set this.SourceTable = Value
    Resize
End Property

Friend Sub OnChanged(ByVal Target As Range)
    RaiseEvent Changed(Target)
End Sub

Friend Sub OnAddedNewRow(ByVal newRow As ListRow)
    RaiseEvent AddedNewRow(newRow)
End Sub

Friend Sub OnAddedNewColumn(ByVal newColumn As ListColumn)
    RaiseEvent AddedNewColumn(newColumn)
End Sub

Private Sub ThrowIfNothing(ByVal Target As Object)
    If Target Is Nothing Then Err.Raise 5, TypeName(Me), "Argument cannot be a null reference."
End Sub

Private Sub ThrowIfSet(ByVal Target As Object)
    If Not Target Is Nothing Then Err.Raise 5, TypeName(Me), "This reference is already set."
End Sub

Private Sub Resize()
    With this.SourceTable
        this.LastRowCount = .ListRows.Count
        this.LastColumnCount = .ListColumns.Count
    End With
End Sub

Private Sub TableSheet_Change(ByVal Target As Range)
    If Not (Target.ListObject Is SourceTable) Then Exit Sub
    OnChanged Target
    Resize
End Sub

请注意，您可以使用 Is 运算符来确定 Target.ListObject 是否引用与 SourceTable 相同的对象，而不是使用 Application.Intersect 范围：

If Not (Target.ListObject Is SourceTable) Then Exit Sub

从那里我们只需要一个 class 来处理这个 Changed 事件 - 我已经把它放在 Sheet1 代码隐藏在这里，但是任何 class 模块会做（包括 UserForm 模块）：

Sheet1工作sheet模块：

'@Folder("VBAProject")
Option Explicit
Private WithEvents MyTable As Table

Public Property Get TableEvents() As Table
    Set TableEvents = MyTable
End Property

Public Property Set TableEvents(ByVal value As Table)
    Set MyTable = value
End Property

Private Sub MyTable_Changed(ByVal cell As Range)
    MsgBox "Changed " & cell.Address
End Sub

Table 引用仍然需要在某处 Set - 在主机工作簿的 Open 处理程序中：

ThisWorkbook 工作簿模块：

'@Folder("VBAProject")
Option Explicit

Private Sub Workbook_Open()
    With Sheet1
        Set .TableEvents = Table.Create(.ListObjects(1))
    End With
End Sub

下一步将是清理由 Table.Create 编辑的 public 界面 return - 就目前而言，事情非常混乱， Table 界面是有点臃肿：

所有这些成员都将对 Sheet1.TableEvents 可用，除非我们做些什么。如果我们只能像这样公开客户端代码真正需要的成员会怎样？

使用 Rubberduck 您可以 提取接口 通过右键单击 Table class 中的任意位置并选择 "Extract Interface"从 "Refactor" 菜单中，然后选择要提取的成员 - 这里是 SourceTable getter（我们不会公开 setter！）：

这将创建一个新的私有 class（这将在未来的版本中更改）- 如果界面被提取出来一个public class.

重构会在Tableclass的顶部添加Implements ITable（假设你没有重命名接口），会添加这个成员：

Private Property Get ITable_SourceTable() As ListObject
    Err.Raise 5 'TODO implement interface member
End Property

您需要做的就是提供实现：

Private Property Get ITable_SourceTable() As ListObject
    Set ITable_SourceTable = this.SourceTable
End Property

现在 Table.Create 可以 return ITable 抽象：

Public Function Create(ByVal Source As ListObject) As ITable

VBA 在另一个 class 上引发事件

VBA Raising event on another class

excel

events

vba

rubberduck