Подкласс кнопка.
Ручка WM_SETFOCUS
.
Действуй соответственно.
Пример.
Форма Form1:
Option Explicit
Private Sub cmdCleverButton_Click()
MsgBox cmdCleverButton.Tag
End Sub
Private Sub Form_Load()
modCleverButtonSublass.SubclassCleverButton cmdCleverButton, Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
modCleverButtonSublass.UnsubclassCleverButton
End Sub
Модуль modCleverButtonSublass
Option Explicit
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const GWL_WNDPROC As Long = -4&
Private Const WM_SETFOCUS As Long = &H7&
Private m_PrevWndProc As Long
Private m_Button As CommandButton
Private m_Form As Form
Public Sub SubclassCleverButton(ByVal b As CommandButton, ByVal ParentForm As Form)
If Not m_Button Is Nothing Then Err.Raise 5, , "Already subslassed."
Set m_Button = b
Set m_Form = ParentForm
m_PrevWndProc = SetWindowLong(m_Button.hwnd, GWL_WNDPROC, AddressOf SubclassCallback)
End Sub
Public Sub UnsubclassCleverButton()
If m_Button Is Nothing Then Err.Raise 5, , "Subclass first."
SetWindowLong m_Button.hwnd, GWL_WNDPROC, m_PrevWndProc
Set m_Form = Nothing
Set m_Button = Nothing
End Sub
Private Function SubclassCallback(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WM_SETFOCUS Then
Dim c As Control
Set c = FindByHwnd(m_Form, wParam)
If c Is Nothing Then
m_Button.Tag = vbNullString
Else
m_Button.Tag = c.Name
End If
End If
SubclassCallback = CallWindowProc(m_PrevWndProc, hwnd, uMsg, wParam, lParam)
End Function
Private Function FindByHwnd(ByVal Parent As Form, ByVal hwnd As Long) As Control
Dim c As Control
For Each c In Parent.Controls
If c.hwnd = hwnd Then
Set FindByHwnd = c
Exit Function
End If
Next
End Function