trying to scroll listbox with two commandbutton

[patricktoulon1]

hello i'me trying to scroll a listbox with a commandbutton but that dont work

Option Explicit

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                              (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
                              lParam As Any) As Long

Private Const WM_VSCROLL = &H115
Const SB_LINEDOWN = 1
Const SB_LINEUP = 0

'event mouseUp for then button  because i need  a listbox focused

Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ListBox1.SetFocus
   SendMessage ListBox1.[_GethWnd], WM_VSCROLL, SB_LINEUP, ByVal 0&

End Sub

Private Sub CommandButton2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ListBox1.SetFocus
   SendMessage ListBox1.[_GethWnd], WM_VSCROLL, SB_LINEDOWN, ByVal 0&

End Sub

Private Sub UserForm_Activate()
ListBox1.List = Evaluate("row(1:30)")
End Sub

can you help me please

 

[patricktoulon1]

re
i'me modified the api decration and the fonction switch for vb7/vb6 and 32/64

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'methode de scrolling de control avec l'object InkCollector
'auteur: patricktoulon
'version:1.0

Private WithEvents IC As MSINKAUTLib.InkCollector
Public mycontrol As control
Private Type POINTAPI: X As Long: Y As Long: End Type
#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongLong) As LongPtr
        Private Type t8: L As LongLong: End Type
Private Function PointApiToLong(point As POINTAPI) As LongLong
    Dim T As t8
    LSet T = point
    PointApiToLong = T.L
End Function
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If

    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr

#Else
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
  Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If


#If VBA7 Then
Function handlecombo(control) As LongPtr
    Dim class$, handle As LongPtr, Handleparent As LongPtr
#Else
Function handlecombo(control) As Long
    Dim class$, handle As Long, Handleparent As Long
#End If
    Dim pos As POINTAPI, Q&
    GetCursorPos pos
re:
    #If Win64 Then
        handle = WindowFromPoint(PointApiToLong(pos))
    #Else
        handle = WindowFromPoint(pos.X, pos.Y)
    #End If
    class = Space$(255)
    Handleparent = GetParent(handle)
    GetClassName Handleparent, class, 255
    If Q = 0 And Not class Like "F3 MdcPopup*" Then pos.Y = pos.Y + 25: Q = 1: GoTo re

    If class Like "F3 MdcPopup*" Then handlecombo = Handleparent
End Function


    'creation de l'object InkCollertor pour piloter le scroll
#If VBA7 Then
Private Sub SetupMouseWheel(Ctrl As control, Optional handl As LongPtr = 0)
#Else
Private Sub SetupMouseWheel(Ctrl As control, Optional handl As Long = 0)
#End If
    Set IC = New MSINKAUTLib.InkCollector
    If handl <> 0 Then SetFocus handl Else Ctrl.SetFocus
    Set mycontrol = Ctrl
    On Error Resume Next
    With IC
        If handl <> 0 Then .hwnd = handl Else .hwnd = Ctrl.[_GethWnd] ' The InkCollector requires an 'anchor' hWnd
        .SetEventInterest ICEI_MouseWheel, True ' This sets event that you want to listen for
        .MousePointer = IMP_Arrow ' If this is not set, the mouse pointer disappears
        .DynamicRendering = False ' I suggest turning this off
        .DefaultDrawingAttributes.Transparency = 255 ' And making the drawing fullly transparent
        .Enabled = True ' This must be set last
    End With
End Sub

Private Sub UserForm_Activate()
    ListBox1.List = Evaluate("row(1:30)")
    ComboBox1.List = Evaluate("row(1:30)")
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    'stop the scrolling when you leaves control
    ' destruction of object IC
    Set IC = Nothing
    'THE DESTRUCTION OF THE OBJECT ic IN THE MOVE OF THE USERFORM IS TEMPORARY. I WILL ADD MY RECTANGLE FUNCTIONS TO IT SO THAT IT IS AUTOMATIC.

End Sub


Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    SetupMouseWheel Frame1
End Sub

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

Private Sub MultiPage1_MouseMove(ByVal Index As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    SetupMouseWheel MultiPage1
End Sub

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

    #If VBA7 Then
        Dim h As LongPtr
    #Else
        Dim h As Long
    #End If
    h = handlecombo(ComboBox1)
    Label2.Caption = "combobox1" & vbCrLf & " handle : " & h
    If h <> 0 Then
        SetupMouseWheel ComboBox1, h
    End If
End Sub

Private Sub IC_MouseWheel(ByVal Button As MSINKAUTLib.InkMouseButton, ByVal Shift As MSINKAUTLib.InkShiftKeyModifierFlags, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long, Cancel As Boolean)
    Select Case True
        Case TypeOf mycontrol Is Frame
            CallByName mycontrol, "ScrollTop", VbLet, IIf(Delta > 0, Application.Max(mycontrol.ScrollTop - 8, 0), mycontrol.ScrollTop + 8)
            
        Case TypeName(mycontrol) = "ListBox" Or TypeOf mycontrol Is ComboBox
            CallByName mycontrol, "TopIndex", VbLet, IIf(Delta > 0, Application.Max(mycontrol.TopIndex - 1, 0), mycontrol.TopIndex + 1)
            
        Case TypeOf mycontrol Is MultiPage
            CallByName mycontrol.Pages(mycontrol.Value), "ScrollTop", VbLet, IIf(Delta > 0, _
                                                          Application.Max(mycontrol.Pages(mycontrol.Value).ScrollTop - 8, 0), _
                                                          mycontrol.Pages(mycontrol.Value).ScrollTop + 8)
            
    End Select
End Sub

 

[patricktoulon1]

Hello @Jaafar Tribak and @Dan_W

I would like to thank you because thanks to you and your examples, I understood how it works.

My favorite is the method with the inkcollector for userforms, it's very simple.

but i'me keep too a methode click on scrollbar of @jaafar triback at side

Thank you both very much

 

[patricktoulon1]

re
From what I've seen with the inkcollector, thanks to Dan_W's examples,

Indeed, it's fine for one control, but when you want to create a module for all controls, the method differs a little.

First of all, the handle with "#172" works for one control, but once the ink is launched, it can't change.
Especially for some controls (multipage), it doesn't work.
So,
I operated as follows:

The setmousewheel is executed when the control moves, avoiding repetition.

The setmousewheel has an additional argument, "HandL."

And in the calls, depending on the control, I inject the control handle.

And there you have it.

It differs a little from Dan_W, but the basics are the same.

It works perfectly well in 32-bit.

'    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'    |||||||||||||    EZPZ MOUSECONTROLLER - DEMO 2      |||||||||||||
'    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'
'    AUTHOR:   Kallun Willock
'    NOTES:    This demonstrates how the InkController can be used with
'              windowless MSForms controls. It relies on attaching to
'              the UserForm's hWnd. Note that with the UserForm, you must
'              use the hWnd of the Client Area and not the UserForm
'              proper (as set out in the code below).
'
'              - The technique requires a reference to be set to
'                Microsoft Tablet PC Type Library, version 1.0.
'                "C:\Users\YourUserName\AppData\Roaming\Microsoft
'
'    VERSION:  1.0        31/03/2025         Uploaded to Github
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal wCmd As Long) As LongPtr
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hWnd As LongPtr) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hWnd As LongPtr) As Long
    Private Declare Function GetWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal wCmd As Long) As LongPtr
    Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
#End If

Private WithEvents IC As MSINKAUTLib.InkCollector
Private TargetControl As MSForms.Control


Private Sub UserForm_Initialize()
    Label1.Picture = New StdPicture
    Me.TextBox1.SelStart = 0
    ListBox1.List = Evaluate("row(1:30)")
    ComboBox1.List = Evaluate("row(1:30)")
End Sub

Private Sub SetupMouseWheel(Optional HandL As Long = 0)
    Set IC = Nothing
    If HandL = 0 Then
        Dim hWnd As LongPtr, TemphWnd As LongPtr
        Call IUnknown_GetWindow(Me, VarPtr(hWnd))
        Const GW_CHILD = 5
        TemphWnd = GetWindow(hWnd, GW_CHILD)
    Else
        TemphWnd = HandL
    End If
    Set IC = New MSINKAUTLib.InkCollector
    With IC
        SetFocus TemphWnd
        .hWnd = TemphWnd ' The InkCollector requires an 'anchor' hWnd
        .SetEventInterest ICEI_MouseWheel, True ' This sets event that you want to listen for
        .MousePointer = IMP_Arrow ' If this is not set, the mouse pointer disappears
        .DynamicRendering = False ' I suggest turning this off = less overhead
        .DefaultDrawingAttributes.Transparency = 255 ' And making the drawing fullly transparent
        .Enabled = True ' This must be set last
    End With
End Sub

' When the mouse cursor moves over these controls, this will set the control as the target of the mousewheel event.

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Not Label1 Is TargetControl Then
        Set TargetControl = Label1
        SetupMouseWheel
    End If
End Sub

Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   TextBox1.SetFocus
   If Not TextBox1 Is TargetControl Then
        Set TargetControl = TextBox1
        SetupMouseWheel
    End If
    TargetControl.SetFocus
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Not ListBox1 Is TargetControl Then
        Set TargetControl = ListBox1
        SetupMouseWheel ListBox1.[_GethWnd]
    End If
End Sub

Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Not Frame1 Is TargetControl Then
        Set TargetControl = Frame1
        SetupMouseWheel Frame1.[_GethWnd]
    End If
End Sub

Private Sub MultiPage1_MouseMove(ByVal Index As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Not MultiPage1 Is TargetControl Then
        Set TargetControl = MultiPage1
        SetupMouseWheel MultiPage1.[_GethWnd]
    End If

End Sub

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Not ComboBox1 Is TargetControl Then
        Set TargetControl = ComboBox1
        SetupMouseWheel
    End If
End Sub





' The MouseWheel event selects what type of control it is dealing with and then executes the custom actions accoringly.
' Here, I use CallByName to adjust the controls properties to avoid the headaches associated with the limitations found
' in the the generic MSForms.Control control.

Private Sub IC_MouseWheel(ByVal Button As MSINKAUTLib.InkMouseButton, ByVal Shift As MSINKAUTLib.InkShiftKeyModifierFlags, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long, Cancel As Boolean)
    Dim ctrl As Control
    Set ctrl = TargetControl
    Select Case TypeName(TargetControl)
        Case "Label"
            CallByName TargetControl, "Caption", VbLet, "Delta: " & Delta
        Case "TextBox"
            Dim CurrentLine As Long
            CurrentLine = CallByName(TargetControl, "CurLine", VbGet)
            If CurrentLine = TextBox1.LineCount - 1 And Delta < 0 Then Exit Sub
            If CurrentLine = 0 And Delta > 0 Then Exit Sub
            CallByName TargetControl, "CurLine", VbLet, IIf(Delta > 0, CurrentLine - 1, CurrentLine + 1)
            
        Case "ListBox"
            CallByName TargetControl, "TopIndex", VbLet, IIf(Delta > 0, ctrl.TopIndex - 1, ctrl.TopIndex + 1)
            
        Case "ComboBox"
            CallByName TargetControl, "TopIndex", VbLet, IIf(Delta > 0, ctrl.TopIndex - 1, ctrl.TopIndex + 1)
        Case "Frame"
            CallByName TargetControl, "ScrollTop", VbLet, IIf(Delta > 0, ctrl.ScrollTop - 8, ctrl.ScrollTop + 8)
            
        Case "MultiPage"
            CallByName TargetControl.Pages(TargetControl.Value), "ScrollTop", VbLet, _
                                                                  IIf(Delta > 0, TargetControl.Pages(TargetControl.Value).ScrollTop - 8, TargetControl.Pages(TargetControl.Value).ScrollTop + 8)
            
    End Select
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Set IC = Nothing
End Sub