VBA - 在取消激活Excel应用程序窗口之前运行子例程

时间：2017-01-25 20:30:01

标签： excel vba excel-vba

我真的被困在这里了。我在尝试运行子例程 - 复制范围值 - 在取消激活excel窗口之前。我使用的是64位vba，并且工作簿级别的当前子例程都没有提供此解决方案。我想在Excel失去焦点时复制数据。有什么想法可以做到这一点？ 

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
    Wn.ActiveCell.Copy
End Sub

1 个答案:

答案 0 :(得分：0)

除非你想调查子类，否则我没有看到任何其他选项，只是挂钩到WinEvent（正如@Comitern所说，使用API​​函数完成）。

问题是，一旦你有钩子运行，Excel可能会变得有点气质。基本上，如果您的代码出现错误或者您在开发过程中破坏了代码，那么应用程序将崩溃。就个人而言，它让我精神错乱。结果我创建了一个尽可能保护自己的课程。这是一个怪物类，所以我删除了所有与你的任务无关的代码，但它仍然很大。我也很惭愧地承认我仍然是32位，所以API就是为了这个。有很多网站向您展示64位的等价物，因此您可以只替换相关的数据类型。

好的，所以这里......

首先，插入一个类模块（Insert~＆gt; Class Module）并将其命名为 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常量转换为枚举，以便我可以利用intellisense（不是很好的编程技术，但我无法跟踪所有常量）。代码是：

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
相关问题
最新问题