How to scroll frame with mouse wheel

[gpsingh]

Hello,

First of all a great thanks to Mr Excel for providing so valuable treasure of information about VBA

I want Help that HOW TO SCROLL ON A FRAME Which is on a Userform With Mouse Wheel

thanks in Advance

 

[Jaafar Tribak]

Welcome to the board.
You will need to install a WH_MOUSE_LL hook and handle the WM_MOUSEWHEEL Window message
A quick google search revealed this : Mouse Wheel scroll userform [Archive] - Free Excel\VBA Help Forum- see if you can adapt it

 

[gpsingh]

Thank you jaafar it's great.
But this is perfect for userform.

I have a frame on userform which loads image perfectly ,every thing is working properly.
But frame has both scroll bars .
I want to scroll it with mouse wheel.

How can we modify this code ? Or any other code ?

 

[Jaafar Tribak]

Which version of excel are you using ? And are you using 32bit or 64bit windows ?

 

[gpsingh]

Sir it's 32 bit and and Excel 2007

 

[Jaafar Tribak]

Sir it's 32 bit and and Excel 2007

Ok .. I'll give this a shot later when I am not busy and if anything comes up, I'll post back

 

[Jaafar Tribak]

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

 

[gpsingh]

Well done Jaafar its Magic !!!!!!!!!

Specially the magical movement of Horizontal Bars

Working very well

You have perfect hold on VBA

Thanks a Lot

 

[Jaafar Tribak]

You are welcome and thanks for the feedback
I am interested in taking this a step further ... I want to create a generic MouseWheel pseudo-event that will flexibly add mousewheel scrolling capability to the userform as well as to all the controls within the form ... If I manage to do it I'll post the code here

 

[gpsingh]

Ok I will wait for it.

And kindly find some thing like that
As we hold zoomed image with mouse pointer(pan or select) in a image viewer and able to move it here and there.

Is it possible in Vba?
That is the userform you have created have frame with scrolls.
And if we able to hold and navigate the frame with mouse pan pointer.