[英]VBA - Running a sub routine before excel application window is deactivated
我真的被困在這里。 我試圖運行一個子例程-復制范圍值-在停用excel窗口之前。 我正在使用64位vba,並且工作簿級別的當前子例程均未提供此解決方案。 每當Excel失去焦點時,我都想復制數據。 任何想法如何做到這一點?
Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
Wn.ActiveCell.Copy
End Sub
除非您想研究子類化,否則我看不到任何其他選擇,只能鈎到WinEvent(如@Comitern所說,是使用API函數完成的)。
問題是,一旦運行了鈎子,Excel就會變得有點氣質。 基本上,如果您的代碼出現錯誤或在開發過程中破壞了代碼,則很有可能導致應用程序崩潰。 就個人而言,這使我精神錯亂。 結果,我創建了一個類來盡可能地保護自己。 這有點像怪物類,所以我刪除了所有與您的任務無關的代碼,但是它仍然很大。 我也很ham愧地承認我仍然使用32位,因此API就是為此而設計的。 有很多網站向您顯示64位等效項,因此您可以替換相關的數據類型。
好,就這樣...
首先,插入一個類模塊(插入〜>類模塊)並將其命名為clsEventHookPair 。 這只是一個數據字段類,代碼為:
Option Explicit
Public EventID As WinEventId
Public EventHook As Long
其次,插入另一個類模塊,並將其命名為clsWinEventListener 。 這是管理鈎子的類:
Option Explicit
Private Const TAG As String = "clsWinEventListener"
Public Event WinEventHooked()
Public hWinEventHook As Long
Public WinEvent As WinEventId
Public hWnd As Long
Public idObject As Long
Public idChild As Long
Public dwEventThread As Long
Public dwmsEventTime As Long
Private mWinEventHookList As Collection
Private mTmpList As Collection
Public Sub AttachHook(evId As WinEventId)
Dim ehp As clsEventHookPair
'Check if hook is already running and remove it
Me.DetachHook evId
If mWinEventHookList Is Nothing Then
Set mWinEventHookList = New Collection
End If
'Populate our hook list with new hook details
Set ehp = New clsEventHookPair
With ehp
.EventID = evId
.EventHook = modHook.HookUp(.EventID)
mWinEventHookList.Add ehp, CStr(.EventID)
Debug.Print TAG & ": Event hooked up [id=" & .EventID & ", hk=" & .EventHook & "]"
End With
Exit Sub
EH:
Me.DetachAll
MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description
End Sub
Public Sub DetachHook(evId As WinEventId)
Dim ehp As clsEventHookPair
If Not mWinEventHookList Is Nothing Then
'Check the hook is in our list
On Error Resume Next
Set ehp = mWinEventHookList(CStr(evId))
On Error GoTo 0
'Detach hook and remove from our list
On Error GoTo EH
If Not ehp Is Nothing Then
With ehp
modHook.Unhook .EventHook
mWinEventHookList.Remove CStr(.EventID)
Debug.Print TAG & ": Event unhooked [id=" & .EventID & ", hk=" & .EventHook & "]"
End With
End If
End If
Exit Sub
EH:
Me.DetachAll
MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description
End Sub
Public Sub DetachAll()
Dim ehp As clsEventHookPair
'Remove all hooks from our list.
'Mainly used in event of error being thrown.
Debug.Print TAG & ": Commencing emergency detach..."
If Not mWinEventHookList Is Nothing Then
For Each ehp In mWinEventHookList
Me.DetachHook ehp.EventID
Next
End If
Set mWinEventHookList = Nothing
Debug.Print TAG & ": Emergency detach complete."
End Sub
Public Sub PauseHooks()
Dim ehp As clsEventHookPair
'Detaches the hooks but keeps a record of the eventIds
'so that we can attach hooks again on resume.
'Note: we can't keep the old event hook ids as
'we'll get new ones when reattached.
On Error GoTo EH
Debug.Print TAG & ": Pausing hooks ..."
If Not mWinEventHookList Is Nothing Then
Set mTmpList = New Collection
For Each ehp In mWinEventHookList
With ehp
mTmpList.Add .EventID
Me.DetachHook .EventID
End With
Next
Set mWinEventHookList = Nothing
End If
Exit Sub
EH:
Me.DetachAll
MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description
End Sub
Public Sub ResumeHooks()
Dim evId As Variant
'Re attach the 'paused' hooks
On Error GoTo EH
Debug.Print TAG & ": Resuming hooks ..."
If Not mTmpList Is Nothing Then
For Each evId In mTmpList
Me.AttachHook CLng(evId)
Next
Set mTmpList = Nothing
End If
Exit Sub
EH:
Me.DetachAll
MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description
End Sub
Public Sub ConsumeHookEvent()
Dim isTargetHook As Boolean
Dim ehp As clsEventHookPair
If mWinEventHookList Is Nothing Then Exit Sub
On Error GoTo EH
For Each ehp In mWinEventHookList
With ehp
'Check the hook event is one we want and fire the class event
'Shouldn't be needed but included in case we've left a rogue hook running.
If .EventHook = Me.hWinEventHook And .EventID = Me.WinEvent Then
RaiseEvent WinEventHooked
Exit Sub
End If
End With
Next
Exit Sub
EH:
Me.DetachAll
MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description
End Sub
Public Sub CountHooks()
Dim c As Long
'Used during development to ensure I don't break the code with hooks running
If Not mWinEventHookList Is Nothing Then
c = mWinEventHookList.Count
End If
Debug.Print TAG & ": " & c & " current hook" & IIf(c <> 1, "s.", ".")
End Sub
Private Sub Class_Initialize()
'Assign this class to the modHook module
'so that it can call the ConsumeHookEvent method
Set modHook.Listener = Me
'Remove after development.
'I use this to remove all the hooks
'if I want to break the code.
frmHook.UseWhileDeveloping Me
End Sub
Private Sub Class_Terminate()
'Remove the hooks
Me.DetachAll
Set modHook.Listener = Nothing
End Sub
第三,在modHook中插入一個新模塊並命名。 這是包含API的模塊,我已經將eventId常量轉換為枚舉,以便可以利用智能感知(雖然不是很好的編程技術,但是我無法跟蹤所有常量)。 代碼是:
Option Explicit
Private Const TAG As String = "modHook"
Public Enum WinEventId
EventSystemSound = &H1
EventSystemAlert = &H2
EventSystemForeground = &H3
EventSystemMenuStart = &H4
EventSystemMenuEnd = &H5
EventSystemMenuPopUpStart = &H6
EventSystemMenuPopUpEnd = &H7
EventSystemCaptureStart = &H8
EventSystemCaptureEnd = &H9
EventSystemMoveSizeStart = &HA
EventSystemMoveSizeEnd = &HB
EventSystemContextHelpStart = &HC
EventSystemContextHelpEnd = &HD
EventSystemDragdropStart = &HE
EventSystemDragDropEnd = &HF
EventSystemDialogStart = &H10
EventSystemDialogEnd = &H11
EventSystemScrollingStart = &H12
EventSystemScrollingEnd = &H13
EventSystemSwitchStart = &H14
EventSystemSwitchEnd = &H15
EventSystemMinimizeStart = &H16
EventSystemMinimizeEnd = &H17
EventSystemDesktopSwitch = &H20
EventSystemEnd = &HFF
EventObjectCreate = &H8000
EventObjectDestroy = &H8001
EventObjectShow = &H8002
EventObjectHide = &H8003
EventObjectReorder = &H8004
EventObjectFocus = &H8005
EventObjectSelection = &H8006
EventObjectSelectionAdd = &H8007
EventObjectSelectionRemove = &H8008
EventObjectSelectionWithin = &H8009
EventObjectStateChange = &H800A
EventObjectLocationChange = &H800B
EventObjectNameChange = &H800C
EventObjectDescriptionChange = &H800D
EventObjectValueChange = &H800E
EventObjectParentChange = &H800F
EventObjectHelpChange = &H8010
EventObjectDefactionChange = &H8011
EventObjectAcceleratorChange = &H8012
EventObjectInvoked = &H8013
EventObjectTextSelectionChanged = &H8014
EventObjectContentScrolled = &H8015
EventSystemArrangmentPreview = &H8016
EventObjectLiveregionChanged = &H8019
EventObjectHostedObjectsInvalidated = &H8020
EventObjectDragStart = &H8021
EventObjectDragcancel = &H8022
EventObjectDragcomplete = &H8023
EventObjectDragEnter = &H8024
EventObjectDragLeave = &H8025
EventObjectDragDropped = &H8026
EventObjectImeShow = &H8027
EventObjectImeHide = &H8028
EventObjectImeChange = &H8029
EventObjectTextEditConversionTargetChanged = &H8030
EventObjectEnd = &H80FF
End Enum
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 UnhookWinEvent Lib "user32" _
(ByVal hWinEventHook As Long) As Long
Private mListener As clsWinEventListener
Public Property Set Listener(val As clsWinEventListener)
Dim res As VbMsgBoxResult
'Check if we have, and want, another instance of listener
If Not mListener Is Nothing And Not val Is Nothing Then
res = MsgBox(TAG & ": multiple instances of listener." & _
vbCrLf & vbCrLf & "Do you want to continue?", _
vbYesNo, "Developer warning")
If res = vbNo Then
mListener.DetachAll
End
End If
End If
Set mListener = val
End Property
Public Function HookUp(evId As WinEventId) As Long
HookUp = SetWinEventHook(evId, evId, 0, AddressOf WinEventProc, 0, 0, 0)
End Function
Private Function WinEventProc _
(ByVal hWinEventHook As Long, _
ByVal WinEvent As Long, _
ByVal hWnd As Long, _
ByVal idObject As Long, _
ByVal idChild As Long, _
ByVal dwEventThread As Long, _
ByVal dwmsEventTime As Long) As Long
On Error GoTo EH
'Pass event parameters to listener
'and call listener's consume event method
If Not mListener Is Nothing Then
With mListener
.hWinEventHook = hWinEventHook
.WinEvent = WinEvent
.hWnd = hWnd
.idObject = idObject
.idChild = idChild
.dwEventThread = dwEventThread
.dwmsEventTime = dwmsEventTime
.ConsumeHookEvent
End With
End If
Exit Function
EH:
If Not mListener Is Nothing Then mListener.DetachAll
MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description
End Function
Public Sub Unhook(winEventHook As Long)
Dim ret As Long
ret = UnhookWinEvent(winEventHook)
End Sub
第四,這是可選的,但是在開發過程中我還展示了一個用戶Userform
,這樣我就可以在破壞代碼之前按一下按鈕來刪除鈎子。 它在很多情況下都救了我,但我想取決於您。 如果需要,請插入一個UserForm並將其命名為frmHook 。 添加兩個名為btnUnHook和btnCount的按鈕。 第一個用於刪除鈎子,第二個僅將運行中的鈎子數寫入立即窗口。 基本上,每當您要退出代碼時,請按“摘機”按鈕。 后面的代碼是:
Option Explicit
Private mListener As clsWinEventListener
Public Sub UseWhileDeveloping(lstnr As clsWinEventListener)
Set mListener = lstnr
Me.Show False
End Sub
Private Sub btnCount_Click()
mListener.CountHooks
End Sub
Private Sub btnUnHook_Click()
mListener.DetachAll
End Sub
Private Sub UserForm_Terminate()
mListener.DetachAll
End Sub
最后,您可以在任何對象模塊中訪問此批次。 通常,人們會鈎住Workbook_Open
事件,因此我在下面的代碼中做了同樣的事情:
Option Explicit
Private WithEvents mListener As clsWinEventListener
Private Sub mListener_WinEventHooked()
On Error GoTo EH
'Handler for the hook event
If mListener.WinEvent = EventSystemForeground Then
If mListener.hWnd <> Application.hWnd Then
mListener.PauseHooks 'don't need this but I remove hooks while working on sheets
MsgBox "Excel lost focus."
'... code goes here ...
mListener.ResumeHooks 're-attch the hooks
End If
End If
Exit Sub
EH:
If Not mListener Is Nothing Then mListener.DetachAll
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Remove all hooks before close
If Not mListener Is Nothing Then
mListener.DetachAll
End If
End Sub
Private Sub Workbook_Open()
On Error GoTo EH
Set mListener = New clsWinEventListener
'Hook up to desired events here
mListener.AttachHook EventSystemForeground
Exit Sub
EH:
If Not mListener Is Nothing Then mListener.DetachAll
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.