excel - 鼠标滚动在用户窗体 VBA 中不起作用

Question

我创建的用户表单的高度大于可以在显示器上显示的高度。我想将我的用户表单准备得更加“用户友好”

• 高度:612
• KeepScrollBarsVisable - 0 - fmScrollBarsNone
• ScrollBars - 2 - fmScrollBarsVerdical
• ScrollHeight:1100(如果我增加这个数字，显示的空间(高度)也比较多)
• 滚动顶部和左侧:0
• 顶部:0
• Excel 2016。

为什么我不能使用鼠标滚动来上下滚动表单？只有单击左侧滚动框才能显示更多内容。顺便提一句。该滚动框由 ScrollBars 属性自动添加。

你能支持我吗，出了什么问题吗？谢谢。

Answer 1

用户表单不支持 native 鼠标滚轮滚动(据我所知)

我在这里发布代码，以便 64 位答案可用。

---

基于this answer

---

步骤:

1- 在您的用户表单后面添加此代码:

Private Sub UserForm_Initialize() 
    HookFormScroll Me 
End Sub 
 
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 
    UnhookFormScroll 
End Sub 

---

2-根据your office architecture将以下内容之一添加到模块中

If Office is on 32 bit:

Option Explicit 
 ' Based on code from Peter Thornton here:
 ' http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
Private Type POINTAPI 
    x                               As Long 
    y                               As Long 
End Type 
Private Type MOUSEHOOKSTRUCT 
    pt                              As POINTAPI 
    hwnd                            As Long 
    wHitTestCode                    As Long 
    dwExtraInfo                     As Long 
End Type 
 
Private Declare Function FindWindow Lib "user32" _ 
Alias "FindWindowA" ( _ 
ByVal lpClassName As String, _ 
ByVal lpWindowName As String) As Long 
 
Private Declare Function GetWindowLong Lib "user32.dll" _ 
Alias "GetWindowLongA" ( _ 
ByVal hwnd As Long, _ 
ByVal nIndex As Long) As Long 
 
Private Declare Function SetWindowsHookEx Lib "user32" _ 
Alias "SetWindowsHookExA" ( _ 
ByVal idHook As Long, _ 
ByVal lpfn As Long, _ 
ByVal hmod As Long, _ 
ByVal dwThreadId As Long) As Long 
 
Private Declare Function CallNextHookEx Lib "user32" ( _ 
ByVal hHook As Long, _ 
ByVal nCode As Long, _ 
ByVal wParam As Long, _ 
lParam As Any) As Long 
 
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _ 
ByVal hHook As Long) As Long 
 
Private Declare Function PostMessage Lib "user32.dll" _ 
Alias "PostMessageA" ( _ 
ByVal hwnd As Long, _ 
ByVal wMsg As Long, _ 
ByVal wParam As Long, _ 
ByVal lParam As Long) As Long 
 
Private Declare Function WindowFromPoint Lib "user32" ( _ 
ByVal xPoint As Long, _ 
ByVal yPoint As Long) As Long 
 
Private Declare Function GetCursorPos Lib "user32.dll" ( _ 
ByRef lpPoint As POINTAPI) As Long 
 
Private Const WH_MOUSE_LL          As Long = 14 
Private Const WM_MOUSEWHEEL        As Long = &H20A 
Private Const HC_ACTION            As Long = 0 
Private Const GWL_HINSTANCE        As Long = (-6) 
 
Private Const WM_KEYDOWN           As Long = &H100 
Private Const WM_KEYUP             As Long = &H101 
Private Const VK_UP                As Long = &H26 
Private Const VK_DOWN              As Long = &H28 
Private Const WM_LBUTTONDOWN       As Long = &H201 
 
Private Const cSCROLLCHANGE        As Long = 10 
 
Private mLngMouseHook              As Long 
Private mFormHwnd                  As Long 
Private mbHook                     As Boolean 
Dim mForm                          As Object 
 
 
Sub HookFormScroll(oForm As Object) 
    Dim lngAppInst                  As Long 
    Dim hwndUnderCursor             As Long 
     
    Set mForm = oForm 
    hwndUnderCursor = FindWindow("ThunderDFrame", oForm.Caption) 
    Debug.Print "Form window: " & hwndUnderCursor 
    If mFormHwnd <> hwndUnderCursor Then 
        UnhookFormScroll 
        Debug.Print "Unhook old proc" 
        mFormHwnd = hwndUnderCursor 
        lngAppInst = GetWindowLong(mFormHwnd, GWL_HINSTANCE) 
        If Not mbHook Then 
            mLngMouseHook = SetWindowsHookEx( _ 
            WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0) 
            mbHook = mLngMouseHook <> 0 
            If mbHook Then Debug.Print "Form hooked" 
        End If 
    End If 
End Sub 
 
Sub UnhookFormScroll() 
    If mbHook Then 
        UnhookWindowsHookEx mLngMouseHook 
        mLngMouseHook = 0 
        mFormHwnd = 0 
        mbHook = False 
    End If 
End Sub 
 
Private Function MouseProc( _ 
    ByVal nCode As Long, ByVal wParam As Long, _ 
    ByRef lParam As MOUSEHOOKSTRUCT) As Long 
    On Error Goto errH 'Resume Next
    If (nCode = HC_ACTION) Then 
        Debug.Print "action" 
        Debug.Print "right window" 
        If wParam = WM_MOUSEWHEEL Then 
            Debug.Print "mouse scroll" 
            MouseProc = True 
            If lParam.hwnd > 0 Then 
                mForm.ScrollTop = Application.Max(0, mForm.ScrollTop - cSCROLLCHANGE) 
            Else 
                mForm.ScrollTop = Application.Min(mForm.ScrollHeight - mForm.InsideHeight, mForm.ScrollTop + cSCROLLCHANGE) 
            End If 
            Exit Function 
        End If 
    End If 
    MouseProc = CallNextHookEx( _ 
    mLngMouseHook, nCode, wParam, ByVal lParam) 
    Exit Function 
errH: 
    UnhookFormScroll 
End Function 

If Office is on 64 bit:

Option Explicit
 ' Based on code from Peter Thornton here:
 ' http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
Private Type POINTAPI
    x                               As Long
    y                               As Long
End Type
Private Type MOUSEHOOKSTRUCT
    pt                              As POINTAPI
    hwnd                            As Long
    wHitTestCode                    As Long
    dwExtraInfo                     As Long
End Type
 
Private Declare PtrSafe Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
 
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
 
Private Declare PtrSafe Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
 
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
 
Private Const WH_MOUSE_LL          As Long = 14
Private Const WM_MOUSEWHEEL        As Long = &H20A
Private Const HC_ACTION            As Long = 0
Private Const GWL_HINSTANCE        As Long = (-6)
 
Private Const WM_KEYDOWN           As Long = &H100
Private Const WM_KEYUP             As Long = &H101
Private Const VK_UP                As Long = &H26
Private Const VK_DOWN              As Long = &H28
Private Const WM_LBUTTONDOWN       As Long = &H201
 
Private Const cSCROLLCHANGE        As Long = 10
 
Private mLngMouseHook              As Long
Private mFormHwnd                  As Long
Private mbHook                     As Boolean
Dim mForm                          As Object
 
 
Sub HookFormScroll(oForm As Object)
    Dim lngAppInst                  As Long
    Dim hwndUnderCursor             As Long
     
    Set mForm = oForm
    hwndUnderCursor = FindWindow("ThunderDFrame", oForm.Caption)
    Debug.Print "Form window: " & hwndUnderCursor
    If mFormHwnd <> hwndUnderCursor Then
        UnhookFormScroll
        Debug.Print "Unhook old proc"
        mFormHwnd = hwndUnderCursor
        lngAppInst = GetWindowLong(mFormHwnd, GWL_HINSTANCE)
        If Not mbHook Then
            mLngMouseHook = SetWindowsHookEx( _
            WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
            mbHook = mLngMouseHook <> 0
            If mbHook Then Debug.Print "Form hooked"
        End If
    End If
End Sub
 
Sub UnhookFormScroll()
    If mbHook Then
        UnhookWindowsHookEx mLngMouseHook
        mLngMouseHook = 0
        mFormHwnd = 0
        mbHook = False
    End If
End Sub
 
Private Function MouseProc( _
    ByVal nCode As Long, ByVal wParam As Long, _
    ByRef lParam As MOUSEHOOKSTRUCT) As Long
    On Error GoTo errH 'Resume Next
    If (nCode = HC_ACTION) Then
        Debug.Print "action"
        Debug.Print "right window"
        If wParam = WM_MOUSEWHEEL Then
            Debug.Print "mouse scroll"
            MouseProc = True
            If lParam.hwnd > 0 Then
                mForm.ScrollTop = Application.Max(0, mForm.ScrollTop - cSCROLLCHANGE)
            Else
                mForm.ScrollTop = Application.Min(mForm.ScrollHeight - mForm.InsideHeight, mForm.ScrollTop + cSCROLLCHANGE)
            End If
            Exit Function
        End If
    End If
    MouseProc = CallNextHookEx( _
    mLngMouseHook, nCode, wParam, ByVal lParam)
    Exit Function
errH:
    UnhookFormScroll
End Function