Обнаружение (в VBA), когда окно, содержащее экземпляр Excel, становится активным

Я вижу, как события WindowActivate запускаются на разных уровнях, когда я переключаюсь между окнами в Excel, но есть ли способ вызвать событие, когда Excel становится основным приложением? Если я щелкаю из Excel и работаю, например, некоторое время в браузере, а затем снова щелкаю в окне Excel, я не вижу запуска ни одного события. Есть ли способ обнаружить это?

Я хотел бы обновить некоторые элементы моего приложения VBA, потому что иногда я обнаруживаю, что моя функция наведения мыши, основанная на функции гипертекста, теряет способность активировать диаграммы. Я могу исправить это, сняв защиту и защитив рабочий лист, или уничтожив и повторно инициализировав подмножество моих объектов. Я хотел бы вызвать это действие на событие, которое я ищу.

Я также могу сделать это с помощью SendKeys, но это нехорошо, потому что он стирает настройки клавиатуры (например, блокировку прокрутки) из-за задокументированной ошибки в SendKeys и заставляет экран мерцать больше, чем хотелось бы.

Поскольку код будет находиться в VBA, я бы ограничил действие конкретной книгой. Если при входе в окно экземпляра Excel активна другая (пассивная) рабочая книга, никакое действие не будет инициировано, и я могу использовать событие WorkbookActivate для обновления приложения, если и когда пользователь выберет рабочую книгу, содержащую его.

Источник

4 ответа

Я считаю, что это не предусмотрено в Excel напрямую, поэтому используйте Windows API. Вы можете заниматься программированием на Win32 в VBA!

объяснение

Вы можете использовать API- интерфейс win32 SetWinEventHook, чтобы Windows сообщала вам об определенных событиях. Включая EVENT_SYSTEM_FOREGROUND, который срабатывает при изменении окна переднего плана. В приведенном ниже примере я проверяю идентификатор процесса нового окна переднего плана с идентификатором процесса Excel. Это простой способ сделать это, но он обнаружит другие окна Excel, такие как окно VBA, так же, как главное окно Excel. Это может или не может быть поведение, которое вы хотите, и может быть изменено соответствующим образом.

Вы должны быть осторожны, используя SetWinEventHook, поскольку вы передаете ему функцию обратного вызова. Вы ограничены в том, что вы можете сделать в этой функции обратного вызова, она существует вне обычного выполнения VBA, и любые ошибки внутри нее приведут к аварийному завершению аварийного завершения Excel.

Вот почему я использую Application.OnTime, чтобы сообщить о событиях. Они не гарантированы, чтобы происходить по порядку, если несколько событий запускаются быстрее, чем обновление Excel и VBA. Но это безопаснее. Вы также можете обновить коллекцию или массив событий, а затем прочитать их отдельно вне обратного вызова WinEventFunc.

Пример кода

Чтобы проверить это, создайте новый модуль и вставьте в него этот код. Затем запустите StartHook. Не забудьте запустить StopAllEventHooks перед закрытием Excel или изменением кода!! В рабочем коде вы, вероятно, добавили бы StartEventHook и StopAllEventHooks к событиям WorkBook_Open и WorkBook_BeforeClose, чтобы обеспечить их запуск в соответствующее время. Помните, что если что-то случится с кодом VBA WinEventFunc до остановки хука, Excel вылетит. Это включает изменяемый код или рабочую книгу, в которой он находится, будучи закрытым. Также не нажимайте кнопку остановки в VBA, когда активен хук. Кнопка Стоп может стереть текущее состояние программы!

Option Explicit

Private Const EVENT_SYSTEM_FOREGROUND = &H3&
Private Const WINEVENT_OUTOFCONTEXT = 0

Private Declare Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, ByVal eventMax As Long, _
    ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, _
    ByVal idThread As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long

Private pRunningHandles As Collection

Public Function StartEventHook() As Long
  If pRunningHandles Is Nothing Then Set pRunningHandles = New Collection
  StartEventHook = SetWinEventHook(EVENT_SYSTEM_FOREGROUND, EVENT_SYSTEM_FOREGROUND, 0&, AddressOf WinEventFunc, 0, 0, WINEVENT_OUTOFCONTEXT)
  pRunningHandles.Add StartEventHook
End Function

Public Sub StopEventHook(lHook As Long)
  Dim LRet As Long
  If lHook = 0 Then Exit Sub

  LRet = UnhookWinEvent(lHook)
End Sub

Public Sub StartHook()
    StartEventHook
End Sub

Public Sub StopAllEventHooks()
  Dim vHook As Variant, lHook As Long
  For Each vHook In pRunningHandles
    lHook = vHook
    StopEventHook lHook
  Next vHook
End Sub

Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
                            ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, _
                            ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
  'This function is a callback passed to the win32 api
  'We CANNOT throw an error or break. Bad things will happen.
  On Error Resume Next
  Dim thePID As Long

  If LEvent = EVENT_SYSTEM_FOREGROUND Then
    GetWindowThreadProcessId hWnd, thePID
    If thePID = GetCurrentProcessId Then
      Application.OnTime Now, "Event_GotFocus"
    Else
      Application.OnTime Now, "Event_LostFocus"
    End If
  End If

  On Error GoTo 0
End Function

Public Sub Event_GotFocus()
    Sheet1.[A1] = "Got Focus"
End Sub

Public Sub Event_LostFocus()
    Sheet1.[A1] = "Nope"
End Sub
Источник

Я изменил очень хорошее решение @AndASM для работы в 64-битной среде. Изменения были

  • изменил параметры вызова функции API с параметров Long на LongLong
  • включенные атрибуты PtrSafe
  • заменил лист 1.[A1] = на диапазон ("a1"). значение = синтаксис

Код @andasm с модами следует

Option Explicit

Private Const EVENT_SYSTEM_FOREGROUND = &H3&
Private Const WINEVENT_OUTOFCONTEXT = 0

Private Declare PtrSafe Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, _
ByVal eventMax As Long, _
ByVal hmodWinEventProc As LongLong, _
ByVal pfnWinEventProc As LongLong, _
ByVal idProcess As Long, _
ByVal idThread As Long, _
ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long

Private pRunningHandles As Collection

Public Function StartEventHook() As Long
  If pRunningHandles Is Nothing Then Set pRunningHandles = New Collection
  StartEventHook = SetWinEventHook(EVENT_SYSTEM_FOREGROUND, EVENT_SYSTEM_FOREGROUND, 0&, AddressOf WinEventFunc, 0, 0, WINEVENT_OUTOFCONTEXT)
  pRunningHandles.Add StartEventHook
End Function

Public Sub StopEventHook(lHook As Long)
  Dim LRet As Long
  If lHook = 0 Then Exit Sub

  LRet = UnhookWinEvent(lHook)
End Sub

Public Sub StartHook()
    StartEventHook
End Sub

Public Sub StopAllEventHooks()
  Dim vHook As Variant, lHook As Long
  For Each vHook In pRunningHandles
    lHook = vHook
    StopEventHook lHook
  Next vHook
End Sub

Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
                        ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, _
                        ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
  'This function is a callback passed to the win32 api
  'We CANNOT throw an error or break. Bad things will happen.
  On Error Resume Next
  Dim thePID As Long

  If LEvent = EVENT_SYSTEM_FOREGROUND Then
    GetWindowThreadProcessId hWnd, thePID
    If thePID = GetCurrentProcessId Then
      Application.OnTime Now, "Event_GotFocus"
    Else
      Application.OnTime Now, "Event_LostFocus"
    End If
  End If

  On Error GoTo 0
End Function

Public Sub Event_GotFocus()
    Range("a1").Value = "Got Focus"
End Sub

Public Sub Event_LostFocus()
   Range("a1").Value = "Nope"
End Sub
Источник

Вот идея, как добиться этого с помощью VBA: Обнаружение, когда Excel теряет фокус?

Источник

Я использую это для активации текстового поля немодальной пользовательской формы после переключения между окнами.

Код из версии @AndASM и Michael с некоторыми модификациями (StopAllEventHooks теперь работает, протестировано в Excel 32 и 64)

Это стандартный модуль (например, с названием «Hooking»):

      Option Explicit

'https://stackoverflow.com/questions/20486944/detecting-in-vba-when-the-window-containing-an-excel-instance-becomes-active
'https://stackoverflow.com/questions/62245375/detecting-lost-focus-in-excel-application-workbook-or-worksheet
'https://social.msdn.microsoft.com/Forums/office/en-US/70ec18cd-2438-4c96-bbb0-97cdecd3ddbb/detect-the-event-when-someone-minimizes-or-maxmize-the-excel-application?forum=exceldev
'https://learn.microsoft.com/es-es/windows/win32/winmsg/using-hooks?redirectedfrom=MSDN
'https://stackoverflow.com/questions/6777772/call-event-in-excel-vba-when-switching-to-another-app
'https://stackoverflow.com/questions/4659457/forms-gotfocus-event-does-not-seem-to-fire/4659751#4659751

Private Const EVENT_SYSTEM_FOREGROUND = &H3&
Private Const WINEVENT_OUTOFCONTEXT = 0

#If VBA7 Then
    Private Declare PtrSafe Function SetWinEventHook Lib "user32.dll" (ByVal EventMin As Long, ByVal EventMax As Long, ByVal hmodWinEventProc As LongLong, ByVal lpfnWinEventProc As LongLong, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
    Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
    'https://stackoverflow.com/questions/69464536/vba-codes-32bit-to-64bit
    Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId As Long) As Long
    Private Declare PtrSafe Function UnhookWinEvent Lib "user32.dll" (ByVal hWinEventHook As LongPtr) As Long
#Else
    'https://www.vbforums.com/showthread.php?861147-RESOLVED-help-How-to-use-SetWinEventHook-to-determine-an-application-s-window-is-created
    Private Declare Function SetWinEventHook Lib "user32.dll" (ByVal EventMin As Long, ByVal EventMax As Long, ByVal hmodWinEventProc As Long, ByVal lpfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
    Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    'https://stackoverflow.com/questions/43875909/unhookwinevent-does-not-unhook-in-vba
    Private Declare Function UnhookWinEvent Lib "user32.dll" (ByVal hWinEventHook As Long) As Long
#End If

Private pRunningHandles As Collection

Public Function StartEventHook() As Long
  If pRunningHandles Is Nothing Then Set pRunningHandles = New Collection
  StartEventHook = SetWinEventHook(EVENT_SYSTEM_FOREGROUND, EVENT_SYSTEM_FOREGROUND, 0&, AddressOf WinEventFunc, 0, 0, WINEVENT_OUTOFCONTEXT)
  pRunningHandles.Add StartEventHook
End Function
#If VBA7 Then
   Public Sub StopEventHook(lHook As LongPtr)
#Else
    Public Sub StopEventHook(lHook As Long)
#End If
  Dim LRet As Long
  If lHook = 0 Then Exit Sub

  LRet = UnhookWinEvent(lHook)
End Sub
Public Sub StartHook()
    StartEventHook
End Sub
Public Sub StopAllEventHooks()
Dim vHook As Variant
#If VBA7 Then
    Dim lHook As LongPtr
#Else
    Dim lHook As Long
#End If
For Each vHook In pRunningHandles
    #If VBA7 Then
        lHook = CLngPtr(vHook)
    #Else
        lHook = CLng(vHook)
    #End If
    StopEventHook lHook
Next vHook
End Sub
#If VBA7 Then
    Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
                            ByVal hWnd As LongPtr, ByVal idObject As Long, ByVal idChild As Long, _
                            ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
#Else
    Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
                            ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, _
                            ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
#End If
  'This function is a callback passed to the win32 api
  'We CANNOT throw an error or break. Bad things will happen.
  On Error Resume Next
  Dim thePID As Long

  If LEvent = EVENT_SYSTEM_FOREGROUND Then
    GetWindowThreadProcessId hWnd, thePID
    If thePID = GetCurrentProcessId Then
      Application.OnTime Now, "Event_GotFocus"
    Else
      Application.OnTime Now, "Event_LostFocus"
    End If
  End If

  On Error GoTo 0
End Function
Public Sub Event_GotFocus()
'Debug.Print "GOT FOCUS"
Activar_userform_visible
'Dim SoundName As String
'SoundName = "C:\WINDOWS\Media\Chimes.wav"
'PlayWavSound SoundName, 1
End Sub
Public Sub Event_LostFocus()
'Debug.Print "Nope"
'Dim SoundName As String
'SoundName = "C:\WINDOWS\Media\recycle.wav" 'Chimes.wav
'PlayWavSound SoundName, 1
End Sub

Создайте пользовательскую форму («UserForm1») с двумя текстовыми полями . Это модуль кода UserForm1:

      Option Explicit
#If VBA7 Then
    Dim MeHWnd As LongPtr, lngCurrentStyle As Long, lngNewStyle As Long
#Else
    Dim MeHWnd As Long, lngCurrentStyle As Long, lngNewStyle As Long
#End If

'http://www.cpearson.com/excel/SuppressChangeInForms.htm
'https://riptutorial.com/vba/example/19036/best-practices
Private Type TView
    IsCancelled As Boolean
    EnableEvents As Boolean
End Type
Private this As TView
Public Property Get IsCancelled() As Boolean
    IsCancelled = this.IsCancelled
End Property
Public Property Get EnableEvents() As Boolean
    EnableEvents = this.EnableEvents
End Property
Private Sub UserForm_Initialize()
On Error GoTo ExceptionHandling
'If Application.Version < 9 Then
'    MeHWnd = FindWindow("THUNDERXFRAME", Me.Caption) 'XL97
'Else
    MeHWnd = FindWindow("THUNDERDFRAME", Me.Caption) 'XL2000+
'End If

lngCurrentStyle = GetWindowLong(MeHWnd, GWL_STYLE)
lngNewStyle = lngCurrentStyle Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
SetWindowLong MeHWnd, GWL_STYLE, lngNewStyle

this.EnableEvents = True

CleanUp:
    On Error Resume Next
    Exit Sub
ExceptionHandling:
    'MsgBox "Error: " & Err.Description
    Resume CleanUp
    'https://stackoverflow.com/a/52206311/6406135
    Resume 'for debugging
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = VbQueryClose.vbFormControlMenu Then
        Cancel = True
        this.IsCancelled = True
        'ListBox1.Clear
        'ListBox3.Clear
        StopAllEventHooks
        Me.Hide
    End If
End Sub
Private Sub UserForm_Layout()
'https://www.mrexcel.com/board/threads/how-can-i-tell-if-a-userform-has-been-minimized-vba.920923/
'https://stackoverflow.com/questions/52500202/unhook-scroll-when-userform-minimized
If IsIconic(MeHWnd) Then
    'MsgBox "The userform : '" & Me.Name & "' has just been minimized", vbInformation
    StopAllEventHooks
ElseIf IsZoomed(MeHWnd) Then
    'MsgBox "The userform : '" & Me.Name & "' has just been maximized", vbInformation
    Activar_userform_visible
    StartHook
Else
    'MsgBox "The userform : '" & Me.Name & "' has just been restored", vbInformation
    Activar_userform_visible
    StartHook
End If
End Sub

Код, помещенный в другой стандартный модуль (например, «Модуль1»):

      #If VBA7 Then
    Public Declare PtrSafe Function PlayWavSound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
    Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
    Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Public Declare PtrSafe Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long
    Public Declare PtrSafe Function IsZoomed Lib "user32" (ByVal hWnd As LongPtr) As Long
#Else
    Public Declare Function PlayWavSound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal LpszSoundName As String, ByVal uFlags As Long) As Long
    Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Public Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long
    Public Declare Function IsZoomed Lib "user32" (ByVal hWnd As Long) As Long
#End If

'Siddharth Rout: https://stackoverflow.com/questions/20555050/minimize-userform-when-macro-in-it-is-running/20558520#20558520
'https://answers.microsoft.com/en-us/msoffice/forum/all/excel-vba-how-to-exclude-minimize-and-esc-button/0617ee7c-6c49-4127-8dba-3f8eb04acb9d
Public Const WS_MINIMIZEBOX As Long = &H20000
Public Const WS_MAXIMIZEBOX As Long = &H10000

Public Const GWL_STYLE As Long = -16

Sub Show_Userform1()
Dim frm As UserForm1
Set frm = New UserForm1
frm.Show vbModeless
End Sub

Sub Activar_userform_visible()
Dim objLoop As Object, Pausa As Single, Inicio As Single
Pausa = 0.2
For Each objLoop In VBA.UserForms
    If (objLoop.Name = "UserForm1" Or objLoop.Name = "UserForm1") And objLoop.Visible = True Then
        'https://stackoverflow.com/questions/28042521/set-focus-back-to-the-application-window-after-showing-userform
        AppActivate objLoop.Caption
        Inicio = Timer
        Do While Timer < Inicio + Pausa
          DoEvents
        Loop
        CreateObject("WScript.Shell").SendKeys "{TAB}", True
        CreateObject("WScript.Shell").SendKeys "+{TAB}", True
    End If
Next objLoop
End Sub
Источник
Другие вопросы по тегам