使用 VBA 和 ActiveX 减少 WithEvent 声明和 subs

Question

在工作表上我有 3 个 ActiveX 对象，分别是 TextBox1、TextBox2、ListBox1

省略其他代码我有一个包含

的 class clsEvents

Private WithEvents txbControl As MSForms.TextBox
Private WithEvents lisControl As MSForms.ListBox 
Private txbEvents As TextBoxEvents                          
Private lisEvents As ListBoxEvents  

Private Sub txbControl_Change()
     txbEvents.ChangeEvent txbControl
End Sub     

Private Sub lisControl_Change()
     lisEvents.ChangeEvent lisControl
End Sub

和 classes TextBoxEvents 和 ListBoxEvents 包含

Public Event Changed(txtBox As MSForms.TextBox)

Public Sub ChangeEvent(txtBox As MSForms.TextBox)
    RaiseEvent Changed(txtBox)
End Sub

Public Event Changed(ByRef myListBox As MSForms.ListBox)

Public Sub ChangeEvent(lisBox As MSForms.ListBox)
    RaiseEvent Changed(lisBox)
End Sub

工作表模块包含

Public WithEvents tbxEvents As TextBoxEvents
Public WithEvents lisEvents As ListBoxEvents

Private Sub tbxEvents_Changed(tbxBox As MSForms.TextBox)
    Debug.Print "tbxEvents_Changed " & tbxBox.Name
End Sub

Private Sub lisEvents_Changed(lisBox As MSForms.ListBox)
    Debug.Print "lisEvents_Changed " & lisBox.Name
End Sub

Private Sub TextBox2_Change()
    Debug.Print "TextBox2_Change"
End Sub

Private Sub TextBox1_Change()
    Debug.Print "TextBox1_Change"
End Sub

Private Sub ListBox1_Change()
    Debug.Print "ListBox1_Changed "
End Sub

如果我在 TextBox1 或 TextBox2 或 ListBox1 中更改某些内容，调试窗口会显示事件将首先发送到工作表（TextBox1_Change 等），然后是 tbxEvents_Changed 或 LisEvents_Changed , 所以它有效。

我想要实现的是将 clsEvents 中的代码替换为

Private WithEvents objControl As OLEobject
Private txbEvents As TextBoxEvents                          
Private lisEvents As ListBoxEvents  

Private Sub objControl_Change()
     if (TypeOf objControl.Object Is MSForms.TextBox) Then
     txbEvents.ChangeEvent objControl
     elseif (TypeOf objControl.Object Is MSForms.ListBox) Then
     lisEvents.ChangeEvent objControl
     endif
End Sub

所以基本上我想知道如何实现 WithEvents 的有效定义，这将消除 clsEvents 中 'many' 事件函数的必要性。

Public WithEvents objControl As ?????

Answer 1

打开记事本并复制下面的代码并将其粘贴到一个新的 txt 文件中另存为 CatchEvents2.cls

    VERSION 1.0 CLASS
    BEGIN
      MultiUse = -1  'True
    END
    Attribute VB_Name = "CatchEvents2"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = False
    Attribute VB_Exposed = False
    Private Type GUID
          Data1 As Long
          Data2 As Integer
          Data3 As Integer
          Data4(0 To 7) As Byte
    End Type

    #If VBA7 And Win64 Then
          Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, _
                  ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, _
                  Optional ByVal ppcpOut As LongPtr) As Long
    #Else
         Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, _
                  ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
    #End If

    Private EventGuide As GUID
    Private Ck As Long
    Private ctl As Object
    Private CustomProp As String

    Public Sub MyChange()
    Attribute MyChange.VB_UserMemId = 2

    Debug.Print " Change ControlName " & " Type: " & TypeName(ctl) & " CustomProp: " & CustomProp
    End Sub


    Public Sub ConnectAllEvents(ByVal connect As Boolean)
          With EventGuide
              .Data1 = &H20400
              .Data4(0) = &HC0
              .Data4(7) = &H46
          End With
          ConnectToConnectionPoint Me, EventGuide, connect, ctl, Ck, 0&
    End Sub

    Public Property Let Prop(newProp As String)
          CustomProp = newProp
    End Property

    Public Property Let Item(Ctrl As Object)
          Set ctl = Ctrl
          Call ConnectAllEvents(True)
    End Property

    Public Sub Clear()
          If (Ck <> 0) Then Call ConnectAllEvents(False)
          Set ctl = Nothing
    End Sub

在您的 VBA 编辑器中导入此文件（右键单击您的 VBA 项目并选择导入）

在普通模块中，您输入以下代码：

Private AllControls() As New CatchEvents2

Sub connect()
Dim j As Long
With Worksheets("Sheet1")
ReDim AllControls(.OLEObjects.Count - 1)
    For j = 0 To .OLEObjects.Count - 1
       AllControls(j).Item = .OLEObjects(j + 1).Object
       AllControls(j).Prop = .OLEObjects(j + 1).Name
    Next
End With
End Sub

Sub disconnect()
Dim j As Long
  For j = LBound(AllControls) To UBound(AllControls)
          AllControls(j).Clear
   Next j
      Erase AllControls
End Sub

现在，当您运行 connect sub 时，任何 activeX 控件的每个更改都会被捕获

编辑：在评论后放入所有其他事件；其他事件：（所有这些也适用于用户表单）

Public Sub MyChange()
Attribute MyChange.VB_UserMemId = 2
Debug.Print "ch"
End Sub

Public Sub MyListClick()
Attribute MyListClick.VB_UserMemId = -610
Debug.Print "cl1"
End Sub

Public Sub MyClick()
Attribute MyClick.VB_UserMemId = -600
Debug.Print "cl2"
End Sub

Public Sub MyDropButtonClick()
Attribute MyDropButtonClick.VB_UserMemId = 2002
End Sub

Public Sub MyDblClick(ByVal Cancel As MSForms.ReturnBoolean)
Attribute MyDblClick.VB_UserMemId = -601
Debug.Print "dcl"
End Sub

Public Sub MyKeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Attribute MyKeyDown.VB_UserMemId = -602
Debug.Print "kd"
End Sub

Public Sub MyKeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Attribute MyKeyUp.VB_UserMemId = -604
Debug.Print "ku"
End Sub

Public Sub MyMouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Attribute MyMouseDown.VB_UserMemId = -605
Debug.Print "md"
End Sub

Public Sub MyMouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Attribute MyMouseMove.VB_UserMemId = -606
Debug.Print "mm"
End Sub

Public Sub MyMouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Attribute MyMouseUp.VB_UserMemId = -607
Debug.Print "mu"
End Sub

Public Sub myKeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Attribute myKeyPress.VB_UserMemId = -603
Debug.Print "kp"
End Sub

然后有 4 个（用户窗体）事件：Exit、Enter、AfterUpdate 和 BeforeUpdate，它们是容器控件的事件，您不能 'catch' 使用 withevents 但通过这种方式您可以：

Public Sub myExit(ByVal Cancel As MSForms.ReturnBoolean)
Attribute myExit.VB_UserMemId = -2147384829
Debug.Print "exit"
End Sub

Public Sub MyAfterUpdate()
Attribute MyAfterUpdate.VB_UserMemId = -2147384832
Debug.Print "au"
End Sub

Public Sub MyBeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Attribute MyBeforeUpdate.VB_UserMemId = -2147384831
Debug.Print "bu"
End Sub

Public Sub MyEnter()
Attribute MyEnter.VB_UserMemId = -2147384830
Debug.Print "enter"
End Sub

在工作表上有 LostFocus 和 GotFocus（1541 和 1542），但这些我无法开始工作，所以如果有人知道如何做，那就太好了。 最后的评论：它不适用于 mac

使用 VBA 和 ActiveX 减少 WithEvent 声明和 subs

Reducing WithEvent declarations and subs with VBA and ActiveX

excel

vba

activex

class

worksheet