Excel vba не работает прокрутка

Пользовательские формы изначально не поддерживают прокрутку колесиком мыши (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-Добавьте одно из следующего к Module в зависимости от архитектура вашего офиса

Если Office находится на 32-разрядной версии:

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 

Если Office работает в 64-разрядной версии:

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

person
Ricardo Diaz
  
schedule
06.01.2021

Workbook demo

The following generic code enables MouseWheel scrolling for UserForms and Frames … You just need to pass the UserForm or the Frame to the SetScrollHook routine in the UserForm_Activate event as follows :

Private Sub UserForm_Activate()
    [COLOR=#008000]'Call SetScrollHook(Me)           '.. Apply the mousewheel scrolling to the Userform[/COLOR]
    Call SetScrollHook(Me.Frame1)     [COLOR=#008000]'.. Apply the mousewheel scrolling to the Frame[/COLOR]
End Sub

You can’t apply the mousewheel functionality to more than one object simultaniously (I’ll try to modify the code later to make it work with the userform and with different frames within the form simultaniously)

In order to scroll the frame

horizontally

, have the Ctl key held down

Proceedings:

1- Create a new UserForm (UserForm1) and add a frame to it (Frame1)

2- Place this code in the UserForm Module :

Private Sub UserForm_Activate()
    'Call SetScrollHook(Me)           '.. Apply the mousewheel scrolling to the Userform
    Call SetScrollHook(Me.Frame1)     '.. Apply the mousewheel scrolling to the Frame
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    RemoveScrollHook
End Sub

3- Add a Standard Module to the project and place the following code in it:

Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type

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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const POINTSPERINCH As Long = 72
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const SCROLL_CHANGE As Long = 5

Private lMouseHook As Long
Private lFormHwnd As Long
Private bHookIsSet As Boolean
Private oScrollableObject As Object


Public Sub SetScrollHook(ByVal ScrollableObject As Object)
    If Not (IsObjectUserForm(ScrollableObject) Or TypeName(ScrollableObject) = "Frame") Then Exit Sub
    Set oScrollableObject = ScrollableObject
    lFormHwnd = GetActiveWindow
    With ScrollableObject
        .ScrollBars = fmScrollBarsBoth
        .KeepScrollBarsVisible = fmScrollBarsBoth
        .PictureAlignment = fmPictureAlignmentTopLeft
        ' Adjust the values of the scroll width and height properties as required
        .ScrollWidth = ScrollableObject.InsideWidth * 3
        .ScrollHeight = ScrollableObject.InsideHeight * 2
    End With
    If Not bHookIsSet Then
        lMouseHook = SetWindowsHookEx( _
        WH_MOUSE_LL, AddressOf MouseProc, Application.Hinstance, 0)
        bHookIsSet = lMouseHook <> 0
    End If
End Sub

Public Sub RemoveScrollHook(Optional ByVal Dummy As Boolean)
    If bHookIsSet Then
        UnhookWindowsHookEx lMouseHook
        lMouseHook = 0
        bHookIsSet = False
    End If
End Sub

Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As Long

    Dim tTopLeft As POINTAPI
    Dim tBottomRight As POINTAPI
    Dim tRect As RECT
    
    GetClientRect lFormHwnd, tRect
    With oScrollableObject
        If IsObjectUserForm(oScrollableObject) Then
            tTopLeft.X = tRect.Left
            tTopLeft.Y = tRect.Top
            tBottomRight.X = tRect.Right
            tBottomRight.Y = tRect.Bottom
        Else
            tTopLeft.X = PTtoPX(.Left, False) + tRect.Left
            tTopLeft.Y = PTtoPX(.Top, True) + tRect.Top
            tBottomRight.X = PTtoPX(.Left + .Width, False) + tRect.Left
            tBottomRight.Y = PTtoPX(.Top + .Height, True) + tRect.Top
        End If
    End With
    ClientToScreen lFormHwnd, tTopLeft
    ClientToScreen lFormHwnd, tBottomRight
    SetRect tRect, tTopLeft.X, tTopLeft.Y, tBottomRight.X, tBottomRight.Y
    On Error GoTo errH
    If (nCode = HC_ACTION) And CBool(PtInRect(tRect, lParam.pt.X, lParam.pt.Y)) Then
        If wParam = WM_MOUSEWHEEL Then
            With oScrollableObject
                Select Case GetAsyncKeyState(VBA.vbKeyControl)
                    Case Is = 0 'vertical scroll
                        If lParam.hwnd > 0 Then
                            .ScrollTop = Application.Max(0, .ScrollTop - SCROLL_CHANGE)
                        Else
                            .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE)
                        End If
                    Case Else ' horiz scroll when the Ctl key down
                        If lParam.hwnd > 0 Then
                            .ScrollLeft = Application.Max(0, .ScrollLeft - SCROLL_CHANGE)
                        Else
                            .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE)
                        End If
                End Select
            End With
        End If
    End If
    MouseProc = CallNextHookEx( _
    lMouseHook, nCode, wParam, ByVal lParam)
    Exit Function
errH:
    RemoveScrollHook
End Function

Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1), lDC
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

Private Function IsObjectUserForm(ByVal obj As Object) As Boolean
    Dim oTemp As Object
    On Error Resume Next
        Set oTemp = obj.Parent
        Set oTemp = Nothing
        IsObjectUserForm = Err.Number = 438
    On Error GoTo 0
End Function