VBA userform - 连接到鼠标滚轮(VBA7,Win10 / 64bit,Word2016 / 64bit)时解决应用程序崩溃问题

时间:2017-05-15 09:28:44

标签: vba ms-word word-vba

从搜索这个网站和Google搜索的几个小时后,我发现从32位Office中可以很好地记录从VBA连接到用户表单/控件中的鼠标滚轮事件,我可以在Win10 / 64位上快速而完美地工作和Word 2016/32位环境。但是,当移动到64位Office环境(Win10 / 64bit)时,它在调用' SetWindowsHookEx'之后一直崩溃。然后移动鼠标光标。

了解Long vs LongLong(LongPtr)实现从32位更改为64位以及我发现的与Long / LongPtr不一致的代码示例,我使用the standard Microsoft WIN32API declare statements for 64 bit检查了我的代码的每一位但仍然崩溃。

供参考:我正在构建自己的'插入交叉引用'功能作为Word的加载项,供私人使用。

事件日志仅显示“异常代码:0xc0000005'发生在VBE7.dll中,我不知道如何继续对此进行故障排除。我花了几个小时在线搜索选项,用我的代码尝试不同的东西,但无济于事。任何人都可以建议如何深入研究这个问题?任何帮助表示赞赏。

相关的代码段如下所示,所有声明均来自上述链接的WIN32API引用,但WindowFromPoint除外,因为' LongLong' Point的类型对我来说似乎不对。对err.LastDllError的所有检查都没有报告错误,SetWindowsHookEx除外,来自err.lastDllError的消息为Command successfully completed。在SetWindowsHookEx上,消息为空,但返回非零鼠标挂钩。在此调用之后直接移动鼠标会崩溃Word - 删除对SetWindowsHookEx的调用不会导致Word崩溃。我在debug.print中设置了MouseProc,但它永远不会到达那里。

下面的代码没有VBA7 / WIN64检查,因为我希望在将其与32位实现合并之前检查64位的干净代码并使其正常工作。

Option Explicit

' Window field offsets for GetWindowLong() and GetWindowWord()
Private Const GWL_WNDPROC = (-4)
Private Const GWL_HWNDPARENT = (-8)
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_USERDATA = (-21)
Private Const GWL_ID = (-12)
Private Const GWL_HINSTANCE As Long = (-6)

'set up the variables used for the mousewheel
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As LongPtr = &H20A
Private Const HC_ACTION As Long = 0

' DLL messages
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type Msg
    hwnd As LongPtr
    message As Long
    wParam As LongPtr
    lParam As LongPtr
    time As Long
    pt As POINTAPI
End Type

Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As LongPtr
    wHitTestCode As Long
    dwExtraInfo As LongPtr
End Type

Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongLong) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongPtr) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function SetWindowsHook Lib "user32" Alias "SetWindowsHookA" (ByVal nFilterType As Long, ByVal pfnFilterProc As LongPtr) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, 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 GetCurrentThreadId Lib "kernel32" () As Long

Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As LongPtr) As Long
Private Declare PtrSafe Function GetLastError Lib "kernel32" () As Long

Dim n As Long
Private mCtl As MSForms.Control
Private mbHook As Boolean

Private mLngMouseHook As LongPtr
Private mListBoxHwnd As LongPtr

Sub HookListBoxScroll64(frm As Object, ctl As MSForms.Control)

    Dim tPT As POINTAPI
    Dim lngAppInst As LongPtr
    Dim hwndUnderCursor As LongPtr
    Dim ptLL As LongLong

    GetCursorPos tPT
    Debug.Print "GetCursorPos err: " & GetWin32ErrorDescription(err.LastDllError)

    ptLL = PointToLongLong(tPT)
    Debug.Print "PointToLongLong err: " & GetWin32ErrorDescription(err.LastDllError)

    hwndUnderCursor = WindowFromPoint(ptLL)
    Debug.Print "WindowFromPoint err: " & GetWin32ErrorDescription(err.LastDllError)

    If Not IsNull(frm.ActiveControl) And Not frm.ActiveControl Is ctl Then
        ctl.SetFocus
    End If

    If mListBoxHwnd <> hwndUnderCursor Then
        UnhookListBoxScroll64
        Debug.Print "UnhookListBoxScroll64 err: " & GetWin32ErrorDescription(err.LastDllError)

        Set mCtl = ctl
        mListBoxHwnd = hwndUnderCursor
        lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
        Debug.Print "GetWindowLongPtr AppInst: " & lngAppInst & ", err: " & GetWin32ErrorDescription(err.LastDllError)

        If Not mbHook Then
            mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
            Debug.Print "SetWindowsHookEx hook: " & mLngMouseHook & ", err: " & GetWin32ErrorDescription(err.LastDllError)
            mbHook = mLngMouseHook <> 0
        End If
    End If

End Sub

Private Function MouseProc( _
                        ByVal nCode As Long, ByVal wParam As LongPtr, _
                        ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
    Debug.Print "MouseProc"

    Dim idx As Long
    On Error GoTo errH
    If (nCode = HC_ACTION) Then
        Dim ptLL As LongLong
        ptLL = PointToLongLong(lParam.pt)
        If WindowFromPoint(ptLL) = mListBoxHwnd Then
            If wParam = WM_MOUSEWHEEL Then
                MouseProc = True
                If TypeOf mCtl Is frame Then
                    If lParam.hwnd > 0 Then idx = -10 Else idx = 10
                    idx = idx + mCtl.ScrollTop
                    If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                        mCtl.ScrollTop = idx
                    End If
                ElseIf TypeOf mCtl Is UserForm Then
                    If lParam.hwnd > 0 Then idx = -10 Else idx = 10
                    idx = idx + mCtl.ScrollTop
                    If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                        mCtl.ScrollTop = idx
                    End If
                Else
                    If lParam.hwnd > 0 Then idx = -1 Else idx = 1
                    idx = idx + mCtl.ListIndex
                    If idx >= 0 Then mCtl.ListIndex = idx
                End If
            Exit Function
            End If
        Else
            UnhookListBoxScroll64
        End If
    End If
    MouseProc = CallNextHookEx( _
                            mLngMouseHook, nCode, wParam, ByVal lParam)
    Exit Function
errH:
    UnhookListBoxScroll64
End Function

0 个答案:

没有答案