打开记事本并复制下面的代码并将其粘贴到新的 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,它们是容器控件的事件,您无法使用 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