Excel 鼠标滚动在userform VBA中不起作用_Excel_Vba_Scroll_Userform

Excel 鼠标滚动在userform VBA中不起作用

excel vba scroll

Excel 鼠标滚动在userform VBA中不起作用,excel,vba,scroll,userform,Excel,Vba,Scroll,Userform,我创建了userform，它的高度超过了可以在监视器上显示的高度。我想让我的用户表单更“用户友好” 身高：612 KeepScrollBars禁用-0-FmScrollBarsOne 滚动条-2-fmScrollBarsVerdical ScrollHeight:1100（如果我增加这个数字，则显示空间（身高）也更高）上下滚动：0 排名：0 Excel 2016 为什么我不能使用鼠标滚动来上下滚动表单？只有在左滚动框上单击，才能显示更多内容。顺便说一句，这个滚动框是由滚动条属性自动添加

我创建了userform，它的高度超过了可以在监视器上显示的高度。我想让我的用户表单更“用户友好”

身高：612
KeepScrollBars禁用-0-FmScrollBarsOne
滚动条-2-fmScrollBarsVerdical
ScrollHeight:1100（如果我增加这个数字，则显示空间（身高）也更高）
上下滚动：0
排名：0
Excel 2016

为什么我不能使用鼠标滚动来上下滚动表单？只有在左滚动框上单击，才能显示更多内容。顺便说一句，这个滚动框是由滚动条属性自动添加的

你能支持我吗，怎么了？谢谢。

用户表单不支持本机鼠标滚轮滚动（AFAIK）

我把代码贴在这里，这样就可以得到64位的答案

基于

步骤：

1-将此代码添加到您的用户表单后面：

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

2-根据

如果Office位于32位上：

选项显式
“根据Peter Thornton的代码：
' http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
私有类型POINTAPI
x尽可能长
只要
端型
专用型鼠标移动卡车
pt-As-POINTAPI
只要
wHitTestCode尽可能长
只要
端型
私有声明函数findwindowlib“user32”\u
别名“FindWindowA”（）
ByVal lpClassName作为字符串，\u
ByVal lpWindowName（作为字符串）长度相同
私有声明函数GetWindowLong Lib“user32.dll”\u
别名“GetWindowLongA”（\u
再见，只要
ByVal nIndex As Long）As Long
私有声明函数SetWindowsHookEx Lib“user32”\u
别名“SetWindowsHookExA”（\u
ByVal idHook只要
ByVal lpfn，只要
拜瓦尔·赫莫德，只要
ByVal dwThreadId作为Long）作为Long
私有声明函数CallNextHookEx Lib“user32”（\u
拜瓦尔·霍克，只要
只要
ByVal wParam，只要
lpram（如有）一样长
私有声明函数UnhookWindowsHookEx Lib“user32”（\u
ByVal hHook As Long）As Long
私有声明函数PostMessage Lib“user32.dll”\u
别名“PostMessageA”（\u
再见，只要
ByVal wMsg，只要
ByVal wParam，只要
ByVal lParam As Long）As Long
私有声明函数WindowFromPoint Lib“user32”（\u
ByVal xPoint，只要
ByVal yPoint As Long）As Long
私有声明函数GetCursorPos Lib“user32.dll”（\u
ByRef lpPoint作为POINTAPI）一样长
专用常量，鼠标长度=14
专用常量WM_鼠标滚轮长度=&H20A
私有常量HC_动作，只要=0
私人Const GWL_HINSTANCE As Long=（-6）
私用常量WM_键控长度=&H100
私有常量WM_KEYUP的长度=&H101
私用Const VK_UP As Long=&H26
私有常量VK_向下，长度=&H28
私有常量WM_LBUTTONDOWN的长度=&H201
私有常量cSCROLLCHANGE，只要=10
私人mLngMouseHook尽可能长
一等兵
作为布尔值的私有mbHook
作为对象的Dim mForm
子钩子窗体滚动（窗体作为对象）
昏庸的印度佬
将HwnUnderCursor设置为长
设置mForm=oForm
HwnUnderCursor=FindWindow（“ThunderDFrame”，格式说明）
调试。打印“窗体窗口：”&hwndUnderCursor
如果mFormHwnd hwndUnderCursor，则
脱钩
Debug.Print“Unhook old proc”
mFormHwnd=hwndUnderCursor
lngAppInst=GetWindowLong（mFormHwnd，GWL_HINSTANCE）
如果不是，那么
mLngMouseHook=SetWindowsHookEx（\u
WH_MOUSE_LL，MouseProc的地址，lngappinest，0）
mbHook=mLngMouseHook 0
如果是mbHook，则调试。打印“表单已挂起”
如果结束
如果结束
端接头
子解钩formscroll（）
如果是这样的话
Unhookwindowshookx mLngMouseHook
mLngMouseHook=0
mFormHwnd=0
mbHook=False
如果结束
端接头
专用函数MouseProc（
ByVal n代码为Long，ByVal wParam为Long，\u
ByRef lParam作为鼠标指针）一样长
出现错误时转到“错误”下一步继续
如果（nCode=HC\U动作），则
调试。打印“操作”
调试。打印“右窗口”
如果wParam=WM\u鼠标滚轮，则
调试。打印“鼠标滚动”
MouseProc=True
如果lParam.hwnd>0，则
mForm.ScrollTop=Application.Max（0，mForm.ScrollTop-cSCROLLCHANGE）
其他的
mForm.ScrollTop=Application.Min（mForm.ScrollHeight-mForm.InsideHeight，mForm.ScrollTop+cSCROLLCHANGE）
如果结束
退出功能
如果结束
如果结束
MouseProc=CallNextHookEx（\u
mLngMouseHook、nCode、wParam、ByVal lParam）
退出功能
呃:
脱钩
端函数

如果Office是64位的：

选项显式
“根据Peter Thornton的代码：
' http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
私有类型POINTAPI
x尽可能长
只要
端型
专用型鼠标移动卡车
pt-As-POINTAPI
只要
wHitTestCode尽可能长
只要
端型
私有声明PtrSafe函数FindWindow Lib“user32”_
别名“FindWindowA”（_
ByVal lpClassName作为字符串_
拜瓦尔
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 

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

Option Explicit

Public Sub ShowModal()
    UserForm1.Show vbModal
End Sub

Public Sub ShowModeless()
    UserForm1.Show vbModeless
End Sub

Option Explicit
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 WHEEL_DOWN           As LongPtr = 7864320
Private Const WHEEL_UP             As LongPtr = 4287102976#

Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, 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 UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Private Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongPtr                                                                '
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr

Private Type POINTAPI
    XY As LongLong
End Type

Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As LongPtr
    wHitTestCode As Long '????
    dwExtraInfo As LongPtr
End Type
 
Private HookPtr As LongPtr, EventControl As Object, EventPtr As LongPtr
 
'------------------
'Hook, Proc, UnHook
'------------------
 
Public Sub HookControl(NewEventControl As Object)
    If HookPtr = 0 Then
       Set EventControl = NewEventControl
       EventControl.BackColor = vbRed 'Test
       EventPtr = CurserPtr
       HookPtr = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, FormPtr, 0)
    End If
End Sub
 
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
    On Error GoTo 1
    MouseProc = CallNextHookEx(HookPtr, nCode, wParam, ByVal lParam)

    Dim WheelScrool As Variant
    Select Case True
           Case EventControl Is Nothing: UnHookControl
           Case EventPtr <> CurserPtr: UnHookControl
           Case HookPtr = 0
           Case nCode <> HC_ACTION
           Case wParam <> WM_MOUSEWHEEL
           Case lParam.hwnd = WHEEL_DOWN: WheelScrool = EventControl.ListIndex - 1
           Case lParam.hwnd = WHEEL_UP:   WheelScrool = EventControl.ListIndex + 1
    End Select
    If Not IsEmpty(WheelScrool) Then
       WheelScrool = IIf(WheelScrool < 0, 0, WheelScrool)
       WheelScrool = IIf(WheelScrool > EventControl.ListCount - 1, EventControl.ListCount - 1, WheelScrool)
       If EventControl.BackColor <> vbYellow Then EventControl.BackColor = vbYellow 'Test
       EventControl.ListIndex = WheelScrool
    End If
    Exit Function

1:  UnHookControl
End Function

Public Sub UnHookControl()
    If HookPtr <> 0 Then
       UnhookWindowsHookEx HookPtr
       HookPtr = 0
       EventControl.BackColor = vbGreen 'Test
       Set EventControl = Nothing
    End If
End Sub

'---------------------------
'Status query (not required)
'---------------------------

Public Property Get IsHookControl() As Boolean
    IsHookControl = (HookPtr <> 0)
End Property

'------------------
'Pointer Functionen
'------------------

Public Function CurserPtr() As LongPtr
    Dim tPT As POINTAPI: GetCursorPos tPT
    CurserPtr = WindowFromPoint(tPT.XY)
End Function

Private Function FormPtr() As LongPtr
    Dim fHw As LongPtr: fHw = FindWindow("ThunderDFrame", EventControl.Parent.Caption)
    FormPtr = GetWindowLong(fHw, GWL_HINSTANCE)
End Function

'-----------------------------
'Elemente:
'   ComboBox1
'   ListBox1
'   ListBox2
'-----------------------------

Option Explicit

Private ActControl As Object

'---------
'User Form
'---------

Private Sub UserForm_Initialize()
    Dim i As Long
    For i = 10 To 30
        ListBox1.AddItem i & " - ListBox1"
        ListBox2.AddItem i & " - ListBox2"
        ComboBox1.AddItem i & " - ComboBox1"
    Next
    ComboBox1.ListIndex = 0
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    UnHookControl
End Sub

'----------------------------
'CombBox1, ListBox1, ListBox2
'----------------------------

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    HookControl ComboBox1
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    HookControl ListBox1
End Sub

Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    HookControl ListBox2
End Sub