Насколько я знаю, такого события в VBA нет. Из документации:
События Активировать и Деактивировать происходят только при перемещении фокуса в приложении. Перемещение фокуса к или от объекта в другом приложении не вызывает ни одно из событий.
Однако API-интерфейсы Windows могут обрабатывать событие с помощью hook . Проблема с Win API в VBA состоит в том, что VBA не обрабатывает ошибки, поэтому Excel будет аварийно завершать работу, если / когда код обнаружит ошибку;так что они могут быть разочаровывающими для разработчика. С чисто личной точки зрения мне нравится сводить код внутри процедур подключения к минимуму и передавать любые значения классу, который затем может инициировать события - это по крайней мере минимизирует сбои. Также важно помнить, что нужно отцепиться перед завершением сеанса.
Базовая реализация ловушки Win API будет выглядеть примерно так:
В объекте класса (здесь он называется cHookHandler)
Option Explicit
Public Event HookWindowActivated()
Public Event HookIdChanged()
Private mHookId As LongPtr
Private mTargetWindows As Collection
Public Property Get HookID() As LongPtr
HookID = mHookId
End Property
Public Property Let HookID(RHS As LongPtr)
mHookId = RHS
RaiseEvent HookIdChanged
End Property
Public Sub AttachHook()
modHook.AttachHook Me
End Sub
Public Sub DetachHook()
modHook.DetachHook
End Sub
Public Sub AddTargetWindow(className As String, Optional windowTitle As String)
Dim v(1) As String
'Creates an array of [0 => className, 1=> windowTitle]
'which is stored in a collection and tested for in
'your hook callback.
v(0) = className
v(1) = windowTitle
mTargetWindows.Add v
End Sub
Public Sub TestForTargetWindowActivated(className As String, windowTitle As String)
Dim v As Variant
'Tests if the callback window is one that we're after.
For Each v In mTargetWindows
If v(0) = className Then
If v(1) = "" Or v(1) = windowTitle Then
'Fires the event that our target window has been activated.
RaiseEvent HookWindowActivated
Exit Sub
End If
End If
Next
End Sub
Private Sub Class_Initialize()
Set mTargetWindows = New Collection
End Sub
Private Sub Class_Terminate()
modHook.DetachHook
End Sub
Код модуля (здесь модуль называется modHook)
Option Explicit
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" _
(ByVal hHook As LongPtr, _
ByVal ncode As Long, _
ByVal wParam As LongPtr, _
lParam As Any) As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As LongPtr, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" _
(ByVal hwnd As LongPtr, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private mHookHandler As cHookHandler
Public Sub AttachHook(hookHandler As cHookHandler)
Set mHookHandler = hookHandler
mHookHandler.HookID = SetWindowsHookEx(WH_CBT, AddressOf CBTCallback, 0, GetCurrentThreadId)
End Sub
Private Function CBTCallback(ByVal lMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
Dim className As String, windowTitle As String
If mHookHandler Is Nothing Then Exit Function
If lMsg = HCBT_ACTIVATE Then
className = GetClassText(wParam)
windowTitle = GetWindowTitle(wParam)
If Not mHookHandler Is Nothing Then
mHookHandler.TestForTargetWindowActivated className, windowTitle
End If
End If
CBTCallback = CallNextHookEx(mHookHandler.HookID, lMsg, ByVal wParam, ByVal lParam)
End Function
Public Sub DetachHook()
Dim ret As Long
If mHookHandler Is Nothing Then Exit Sub
ret = UnhookWindowsHookEx(mHookHandler.HookID)
If ret = 1 Then
mHookHandler.HookID = 0
End If
End Sub
Private Function GetWindowTitle(wParam As LongPtr) As String
Dim tWnd As String
Dim lWnd As Long
tWnd = String(100, Chr(0))
lWnd = GetWindowText(wParam, tWnd, 100)
tWnd = Left(tWnd, lWnd)
GetWindowTitle = tWnd
End Function
Private Function GetClassText(wParam As LongPtr) As String
Dim tWnd As String
Dim lWnd As Long
tWnd = String(100, Chr(0))
lWnd = GetClassName(wParam, tWnd, 100)
tWnd = Left(tWnd, lWnd)
GetClassText = tWnd
End Function
И в этом примере все события регистрируются вUserform
В этом простом примере две кнопки на Userform присоединяют и отсоединяют хук, но вы, вероятно, вызываете подпрограммы откуда-то еще (возможно, пользовательская форма Initialize иTerminate событий). Userform также имеет метку, отображающую HookId, который я использую во время разработки - для производственного кода вы, вероятно, этого не захотите, поэтому вы можете оставить этот бит вне.
Option Explicit
Private WithEvents mHookHandler As cHookHandler
Private Sub btnHook_Click()
mHookHandler.AttachHook
End Sub
Private Sub btnUnhook_Click()
mHookHandler.DetachHook
End Sub
Private Sub mHookHandler_HookIdChanged()
lblHook.Caption = mHookHandler.HookID
End Sub
Private Sub mHookHandler_HookWindowActivated()
Debug.Print "I've been activated!"
End Sub
Private Sub UserForm_Initialize()
Set mHookHandler = New cHookHandler
mHookHandler.AddTargetWindow "ThunderDFrame", "UserForm1"
End Sub
Private Sub UserForm_Terminate()
Set mHookHandler = Nothing
End Sub