在工作表上,我有3个ActiveX对象,分别是TextBox1,TextBox2,ListBox1
省略其他代码我有一个类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
并且类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中“许多”事件函数的必要性。
Public WithEvents objControl As ?????
打开记事本并复制下面的代码,并将其粘贴到新的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子时,将捕获到任何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,它们是容器控件的事件,您无法使用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上不起作用