1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
#If VBA7 Then
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As Long
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
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
Private hwnd As LongPtr
#Else
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As GUID) As Long
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
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long
Private hwnd As Long
#End If
Private WithEvents CmndBras As CommandBars
Private oClientForm As Object
Private oCurrentTextBox As MSForms.TextBox
Private sClassInstanceName As String
Event OnEnter(ByVal TextBox As MSForms.TextBox)
Event OnExit(ByVal TextBox As MSForms.TextBox, ByRef Cancel As MSForms.ReturnBoolean)
Event BeforeUpdate(ByVal TextBox As MSForms.TextBox, ByRef Cancel As MSForms.ReturnBoolean)
Event AfterUpdate(ByVal TextBox As MSForms.TextBox)
' __________________________________ CLASS PUBLIC METHOD ________________________________________
Property Let HookEvents(ClassInstanceName As String, Optional ByVal TextBox As MSForms.TextBox, ByVal SetEvents As Boolean)
Const S_OK = &H0
Static lCookie As Long
Dim tIID As GUID
Debug.Print "HookEvents"
If Not TextBox Is Nothing Then
Debug.Print "HookEvents : Not TextBox Is Nothing"
Set oCurrentTextBox = TextBox
Debug.Print "HookEvents oCurrentTextBox = TextBox : " & oCurrentTextBox.Name
Set oClientForm = GetUserForm(TextBox)
sClassInstanceName = ClassInstanceName
Debug.Print "HookEvents sClassInstanceName = ClassInstanceName : " & sClassInstanceName
Set CmndBras = Application.CommandBars
Call IUnknown_GetWindow(oClientForm, VarPtr(hwnd))
End If
If IIDFromString(StrPtr("{00020400-0000-0000-C000-000000000046}"), tIID) = S_OK Then
If ConnectToConnectionPoint(Me, tIID, SetEvents, TextBox, lCookie) = S_OK Then
Debug.Print oCurrentTextBox.Name & IIf(SetEvents, " connected", " disconnected") & " successfully"
Else
Debug.Print "Connection failed for: " & oCurrentTextBox.Name
End If
Else
Debug.Print "HookEvents IIDFromString(StrPtr(""{00020400-0000-0000-C000-000000000046}""), tIID) = S_OK : False"
End If
End Property
' __________________________________ TEXTBOX CONTROL EVENTS ________________________________________
Public Sub OnEnter()
' Attribute OnEnter.VB_UserMemId = &H80018202
Dim oThis As ClassTextBoxEvents
Set oThis = Me
Call CallByName(oClientForm, sClassInstanceName, VbSet, oThis)
Set oThis = Nothing
Debug.Print "OnEnter oCurrentTextBox : " & oCurrentTextBox.Name
RaiseEvent OnEnter(oCurrentTextBox)
End Sub
Public Sub OnExit(ByVal Cancel As MSForms.ReturnBoolean)
' Attribute OnExit.VB_UserMemId = &H80018203
Debug.Print "OnExit oCurrentTextBox : " & oCurrentTextBox.Name
RaiseEvent OnExit(oCurrentTextBox, Cancel)
End Sub
Public Sub BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
' Attribute BeforeUpdate.VB_UserMemId = &H80018201
RaiseEvent BeforeUpdate(oCurrentTextBox, Cancel)
End Sub
Public Sub AfterUpdate()
' Attribute AfterUpdate.VB_UserMemId = &H80018200
RaiseEvent AfterUpdate(oCurrentTextBox)
End Sub
' __________________________________ PRIVATE ROUTINES ________________________________________
Private Function GetUserForm(ByVal Ctrl As MSForms.Control) As Object
Dim oTmp As Object
Debug.Print "GetUserForm"
Set oTmp = Ctrl.Parent
Do While TypeOf oTmp Is MSForms.Control
Set oTmp = oTmp.Parent
Debug.Print "GetUserForm oTmp = oTmp.Parent : " & oTmp.Name
Loop
Set GetUserForm = oTmp
End Function
Private Sub CmndBras_OnUpdate()
Debug.Print "CmndBras_OnUpdate"
If IsWindow(hwnd) = 0 Then
Debug.Print "CmndBras_OnUpdate IsWindow(hwnd) = 0 : " & IsWindow(hwnd)
HookEvents(sClassInstanceName, oCurrentTextBox) = False
End If
End Sub
Private Sub Class_Terminate()
Debug.Print "Class instance treminated and memory released properly related to: " & oCurrentTextBox.Name
Set oCurrentTextBox = Nothing
Set oClientForm = Nothing
Set CmndBras = Nothing
End Sub |
Interception des évènements Enter et Exit des contrôles MSForms.TextBox
Répondre avec citation
Partager