trying to scroll listbox with two commandbutton

patricktoulon1

patricktoulon1

Board Regular
Joined
Jan 23, 2025
Messages
76
Office Version
  1. 2013
Platform
  1. Windows
hello i'me trying to scroll a listbox with a commandbutton but that dont work
VBA Code: 
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
 
Sort by date Sort by votes
re
i'me modified the api decration and the fonction switch for vb7/vb6 and 32/64
VBA Code: 
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'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
 
Upvote 0
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
 
Upvote 0
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.
VBA Code: 
'    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'    |||||||||||||    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
 
Upvote 0
Thanks for the update Patrick. Glad it worked for you.

I still experience the issue I explained in post #59
 
Upvote 0
hello @Jaafar Tribak
In 64, you have to change the ink when you change controls.
When you hover over the controls:
Textbox: Create Ink and Client Area handle of the userform
Listbox: Create a new ink: Listbox handle
Frame: Create a new ink with frame1.handle
Multipage: Here you need two handles: Handle Multipage and Client Area Multipage. So, in the move, we add a function so that when the handle under the cursor changes, a new ink with this handle is created without changing the target control.
With the combobox, it's the same as with multipage.

The only problem is that I can't regain focus on the textbox without clicking on it when:
I move from the listbox to the testbox
from the frame to the textbox
from the multipage to the textbox
with the combobox, I have no problem restoring focus to the textbox when I return to it.


VBA Code: 
'    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'    |||||||||||||    EZPZ MOUSECONTROLLER - DEMO 2      |||||||||||||
'    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'
'    AUTHOR:   Kallun Willock - patricktoulon - JP
'    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.1        05/04/2025
'    VERSION 2.0          06/04/2025 PATRICKTOULON A3ND JURASSIC PORK
'    changing ink and handle when you leaves control and you enter in new control
'    the handle is the one below the cursor
Option Explicit
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 LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If
    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
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private TargetHwnd As LongPtr
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    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
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private TargetHwnd As Long
#End If

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

#If Win64 Then
 ' convert pointapi to longlong for api windowfrompoint in 64
Private Function PointApiToLong(Point As POINTAPI) As LongLong
    Dim DbLL As LongLong, StructLong As LongPtr
    StructLong = LenB(DbLL)
    If LenB(Point) = StructLong Then CopyMemory DbLL, Point, StructLong
    PointApiToLong = DbLL
End Function
#End If
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 = 0)
    Set IC = Nothing
    If HandL = 0 Then
    #If VBA7 Then
        Dim hWnd As LongPtr, TemphWnd As LongPtr
    #Else
        Dim hWnd As Long, TemphWnd As Long
    #End If
        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)
   Sheets("Feuil1").Range("B2") = "Label1"
   Sheets("Feuil1").Range("B3") = GetWindowFromCurs()
    If Not Label1 Is TargetControl Then
        Set TargetControl = Label1
'        SetupMouseWheel
    End If
 If Not GetWindowFromCurs() = TargetHwnd Then
        TargetHwnd = GetWindowFromCurs()
        SetupMouseWheel TargetHwnd
  End If
End Sub

Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   Sheets("Feuil1").Range("B2") = "TextBox1"
   Sheets("Feuil1").Range("B3") = GetWindowFromCurs()
   TextBox1.SetFocus
   If Not TextBox1 Is TargetControl Then
         Set TargetControl = TextBox1
'        SetupMouseWheel
    End If
    TargetControl.SetFocus
   If Not GetWindowFromCurs() = TargetHwnd Then
        TargetHwnd = GetWindowFromCurs()
        SetupMouseWheel TargetHwnd
    End If
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
     Sheets("Feuil1").Range("B2") = "ListBox1"
     Sheets("Feuil1").Range("B3") = GetWindowFromCurs()
    If Not ListBox1 Is TargetControl Then
         Set TargetControl = ListBox1
'        SetupMouseWheel ListBox1.[_GethWnd]
    End If
     If Not GetWindowFromCurs() = TargetHwnd Then
        TargetHwnd = GetWindowFromCurs()
        SetupMouseWheel TargetHwnd
    End If
End Sub

Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
     Sheets("Feuil1").Range("B2") = "Frame1"
     Sheets("Feuil1").Range("B3") = GetWindowFromCurs()
     If Not Frame1 Is TargetControl Then
         Set TargetControl = Frame1
'        SetupMouseWheel Frame1.[_GethWnd]
    End If
     If Not GetWindowFromCurs() = TargetHwnd Then
        TargetHwnd = GetWindowFromCurs()
        SetupMouseWheel TargetHwnd
    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)
      Sheets("Feuil1").Range("B2") = "MultiPage1"
      Sheets("Feuil1").Range("B3") = GetWindowFromCurs()
      If Not MultiPage1 Is TargetControl Then
        Set TargetControl = MultiPage1
'        SetupMouseWheel MultiPage1.[_GethWnd]
      End If
      If Not GetWindowFromCurs() = TargetHwnd Then
        TargetHwnd = GetWindowFromCurs()
        SetupMouseWheel TargetHwnd
      End If
End Sub

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Sheets("Feuil1").Range("B2") = "ComboBox1"
    Sheets("Feuil1").Range("B3") = GetWindowFromCurs()
     If Not ComboBox1 Is TargetControl Then
        Set TargetControl = ComboBox1
'        SetupMouseWheel MultiPage1.[_GethWnd]
      End If
    If Not GetWindowFromCurs() = TargetHwnd Then
        TargetHwnd = GetWindowFromCurs()
        Debug.Print "Combo"
        SetupMouseWheel TargetHwnd
    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"
           On Error Resume Next
           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
'---------------------
'Get Window from Point
'---------------------
#If VBA7 Then
    Private Function GetWindowFromCurs() As LongPtr
#Else
    Private Function GetWindowFromCurs() As Long
#End If
    Dim Pt As POINTAPI
    Call GetCursorPos(Pt)
#If Win64 Then
    GetWindowFromCurs = WindowFromPoint(PointToLongLong(Pt))
#Else
    GetWindowFromCurs = WindowFromPoint(Pt.X, Pt.Y)
#End If
End Function
 
Last edited:
Upvote 0
Hi both. Sorry for my absence - I've had family in town, and am only just now starting to read your posts.

Jaafar Tribak said:
The weird thing is that this issue only happens in excel 2016 x64bit. Works fine in Excel x32bit.
Click to expand...
Want to hear something weirder? I'm using 64bit VBA and I'm not getting that problem at all. Like your example above, I put a textbox undernearth the frame, clicked in it (gave it focus), typed something in it, and with it still having focus, was able to control the frame once I was hovering over it again... I still need to work my way through the rest of your replies, but I will look at this again.
 
Upvote 0
patricktoulon1 said:
In 64, you have to change the ink when you change controls.
Click to expand...
But in the example that Jaafar is referrng to, the Frame hWnd has been used to bind with the InkCollector, and it hasn't been disconnected by virtue of hovering over the textbox (given it has no hwnd), so it is indeed very weird that it's behaving this way.

As mentioned, that's not the behaviour I observe in my 64bit Office, though.

bMnjj.gif


And so now I'm concerned that it's not working for Jaafar - because that will mean that it's not a fullly useful solution. @Jaafar Tribak - is it just the textbox this happens with? What is you shifted foccus to a commandbutton, for example?


Multipage: Here you need two handles: Handle Multipage and Client Area Multipage. So, in the move, we add a function so that when the handle under the cursor changes, a new ink with this handle is created without changing the target control.
Click to expand...
In terms of the Multipage control, to get the second hWnd (ie., the one for the page), the method I've been using is that which I learned from Jaafar - namely using the IUnknown_GetWindow API. With this, it is just a matter of passing the page object.

So in the class I'm writing, it looks something like:
Excel Formula: 
Private Sub MultiPage1_MouseMove(ByVal Index As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
 SetMouseWheel MultiPage1.Pages(MultiPage1.Value)
End Sub
Thereby passing the page object, and it seems to work.

In terms of the combobox, I've discovered that you can get it's hWnd if you use it's DropDown method in the UserForm Initialize event, then use FindWindow against its Class Name - which on my system is F3 MdcPopup 9d280000. There is a subsequent problem about getting the dropdown part to go back up, and I've hacked something together with SendKeys that is less than ideal. But even at the end of all of that, I'm still not properly moving up and down the combobox. I'll try again tomorrow.
 
Last edited:
Upvote 0
patricktoulon1 said:
but once the ink is launched, it can't change.
Click to expand...
It can change. So with the multiple control example I showed above (and which I will upload for you both), I've used a class that uses a single InkCollector for all those controls, contained with a class. The important step is that you must Disable the InkCollector first, then change the settings, then re-enable the InkCollector. This is my (poorly) wrttten code from my demo userform that does this:

VBA Code: 
Sub SetMouseWheel(ByRef Target As MSForms.Control, Optional ByVal PseudoName As String)
  If CurrControlName <> Target.Name Then    ' This is used to test whether the control being passed to the
                                            ' routine is the one that is currently bound to the InkCollector
    Set CurrControl = Target
    On Error GoTo ErrHandler
    MM.Enabled = False                      ' The InkCollector must be disabled before changing the target hWnd
    Set MM.Control = Target                 ' Get's the hwnd of the control and sets it to the Ink Collector
    CurrControlName = Target.Name
    MM.IC.SetEventInterest ICEI_MouseWheel, True
    MM.IC.SetEventInterest ICEI_DblClick, True
    MM.IC.SetEventInterest ICEI_MouseDown, True
    MM.IC.SetEventInterest ICEI_MouseUp, True
    MM.IC.MousePointer = IMP_Hand
ErrHandler:
    If MM.hWnd <> 0 Then
      MM.Enabled = True
    End If
  End If
End Sub

What is missing from the above is the corresponding Control code from the class, which is:

VBA Code: 
  Public Property Set Control(ByRef RHS As Object)
    Set This.TargetControl = RHS
    Dim TemphWnd As LongPtr
    Call IUnknown_GetWindow(RHS, VarPtr(TemphWnd))
    If TypeName(RHS) = RHS.Name Then
      This.UserFormName = RHS.Name
      Const GW_CHILD = 5
      TemphWnd = GetWindow(TemphWnd, GW_CHILD)
    End If
    On Error Resume Next
    IC.hWnd = TemphWnd
    This.Targethwnd = TemphWnd
  End Property

But yess, it can be done.
 
Upvote 0
re

hello Dan_W
Ok I'll look at all your suggestions.
In the meantime, I've been working on it too.
And I transferred everything into a class to make it a utility module for multiple UserForms.
I added my own custom function to determine the control's rectangle (without an API).
When you leave the control's scope, the IC stops.
Just a small problem restoring focus to the textbox when you leave the listbox, frame, or multipage.
and you return in textbox

But in fact, for me, it works fine on all controls using only the handle of the userform's client area.
But on some 64-bit systems, who knows why it doesn't work everywhere?
That's why I switch handles without changing the "targetcontrol" or ("actualControl" for me).

my class modul
VBA Code: 
'    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'    |||||||||||||    EZPZ MOUSECONTROLLER - DEMO 3      |||||||||||||
'    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
'
'    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.1        05/04/2025
'-----------------------------------------------------------------
'    VERSION 2.0          06/04/2025 adapted to 64 bits
'    remastered by:
'    patricktoulon :https://excel-downloads.com/members/patricktoulon.167882/#resources
'    jurassic pork :https://excel-downloads.com/members/jurassic-pork.441753/#resources
'
'Principle:
'Changing ink and handle when you leave a control and enter a new control
'The handle is the one below the cursor

'Control Event
'Control handling is done in two parts:
'1. The ActualControl object variable becomes the control if it doesn't already have one.
'2. The TargetHandle variable changes as soon as the cursor moves over a new handle.

'Version 3.0
'Code transferred to a class module.
'Added the InkScrolling sub ""InkScrolling"", which is the shortcut called by all control movement events in the userform.
'Added a GetUfRectanglefunction for determinate rectangle of control
'in Ic_mouseWheel then testing if integer(X and Y )arent in rectangle  and  we  quit if it's not in rectangle automaticaly



Option Explicit
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 LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If
    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
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Public HandleCible As LongPtr
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    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
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Public HandleCible As Long
#End If

Public WithEvents IC As MSINKAUTLib.InkCollector

Public ActualControl As msforms.Control

Public ArX As Variant

#If Win64 Then
    ' Convert pointapi to longlong for api WindowFromPoint in 64
Private Function PointApiToLong(Point As POINTAPI) As LongLong
    Dim DbLL As LongLong, StructLong As LongPtr
    StructLong = LenB(DbLL)
    If LenB(Point) = StructLong Then CopyMemory DbLL, Point, StructLong
    PointApiToLong = DbLL
End Function
#End If


Public Sub InkScrolling(ctrl As msforms.Control)
    'Sheets("Feuil1").Range("B2") = ctrl.Name
    'Sheets("Feuil1").Range("B3") = GetWindowFromCurs()
     If Not ctrl Is ActualControl Then
        Set ActualControl = ctrl
        ArX = Me.GetUfRectangle(ctrl)
   'Debug.Print Join(ArX)
    End If
    If Not GetWindowFromCurs() = HandleCible Then
        HandleCible = GetWindowFromCurs()
        SetupMouseWheel HandleCible
    End If
End Sub
'SetupMouseWheel est appelée avec le handle sous le curseur ou 0
Public Sub SetupMouseWheel(Optional HandL = 0)
    Set IC = Nothing
    If HandL = 0 Then
        #If VBA7 Then
            Dim hWnd As LongPtr, TemphWnd As LongPtr
        #Else
            Dim hWnd As Long, TemphWnd As Long
        #End If
        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 ' Attachement du handle au inkcollector
        .SetEventInterest ICEI_MouseWheel, True ' evennement du inkcollector que l'on veut ecouter
        .MousePointer = IMP_Arrow ' Iforcer l'affichage du curseur
        .DynamicRendering = False ' on ne se servira pas du rendering pas la peine de consommer de la ressource
        .DefaultDrawingAttributes.Transparency = 255 ' l'object sera completement invisible
        .Enabled = True ' très important Cela doit être défini en dernier
    End With
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)
    Dim ctrl As Control, avail
    Set ctrl = ActualControl
  avail = X > ArX(1) And X < ArX(3) And Y > ArX(2) And Y < ArX(4)
  If Not avail Then Set IC = Nothing: Set ActualControl = Nothing: HandleCible = 0: Exit Sub
  On Error Resume Next
    Select Case TypeName(ActualControl)
        Case "Label": CallByName ActualControl, "Caption", VbLet, "Delta: " & Delta
            
        Case "ListBox": CallByName ActualControl, "TopIndex", VbLet, IIf(Delta > 0, ctrl.TopIndex - 1, ctrl.TopIndex + 1)
            
        Case "ComboBox": CallByName ActualControl, "TopIndex", VbLet, IIf(Delta > 0, ctrl.TopIndex - 1, ctrl.TopIndex + 1)
            
        Case "Frame": CallByName ActualControl, "ScrollTop", VbLet, IIf(Delta > 0, ctrl.ScrollTop - 8, ctrl.ScrollTop + 8)
            
        Case "MultiPage": CallByName ActualControl.Pages(ActualControl.Value), "ScrollTop", VbLet, _
              IIf(Delta > 0, ActualControl.Pages(ActualControl.Value).ScrollTop - 8, ActualControl.Pages(ActualControl.Value).ScrollTop + 8)
            
        Case "TextBox"
            Dim CurrentLine As Long
            CurrentLine = CallByName(ActualControl, "CurLine", VbGet)
            If CurrentLine = ActualControl.LineCount - 1 And Delta < 0 Then Exit Sub
            If CurrentLine = 0 And Delta > 0 Then Exit Sub
            CallByName ActualControl, "CurLine", VbLet, IIf(Delta > 0, CurrentLine - 1, CurrentLine + 1)
    End Select
End Sub

'---------------------
'Get Window from Point
'---------------------
#If VBA7 Then
Public Function GetWindowFromCurs() As LongPtr
#Else
Public Function GetWindowFromCurs() As Long
#End If
    Dim Pt As POINTAPI
    Call GetCursorPos(Pt)
    #If Win64 Then
        GetWindowFromCurs = WindowFromPoint(PointToLongLong(Pt))
    #Else
        GetWindowFromCurs = WindowFromPoint(Pt.X, Pt.Y)
    #End If
End Function

'fonction rectangle control dans userform
Public Function GetUfRectangle(obj As Control)
    'fonction de positionement calendar reconvertie :patricktoulon calendar
    If Not obj Is Nothing Then
        Dim Lft As Double, Ltop As Double, P As Object, PInsWidth As Double, PInsHeight As Double, tt As Double, ar(1 To 4)
        Dim K As Double, PPx, A, z, yy
        Lft = obj.left: Ltop = obj.top: Set P = obj.Parent
        PPx = 0.75
        Do

            PInsWidth = P.InsideWidth ' Le Page en est pourvu, mais pas le Multipage.
            PInsHeight = P.InsideHeight
            If TypeOf P Is msforms.Page Then Set P = P.Parent ' Prend le Multipage, car le Page est sans positionnement.
            K = (P.Width - PInsWidth) / 2: Lft = (Lft + P.left + K): Ltop = (Ltop + P.top + P.Height - K - PInsHeight)
            If Not (TypeOf P Is msforms.Frame Or TypeOf P Is msforms.MultiPage) Then Exit Do
            Set P = P.Parent
            DoEvents
        Loop
        If TypeOf obj Is ComboBox Then yy = (obj.Font.Size * 1.2) * obj.ListRows
        ar(1) = Lft / PPx
        ar(2) = Ltop / PPx
        ar(3) = (Lft + obj.Width) / PPx
        ar(4) = (Ltop + obj.Height + yy) / PPx
        GetUfRectangle = ar
    End If
End Function

and in userform
VBA Code: 
Dim cls As New InkScroll


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


Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
     cls.InkScrolling Label1
  End Sub

Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    cls.InkScrolling TextBox1
  End Sub

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

Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
     cls.InkScrolling Frame1
  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)
     cls.InkScrolling MultiPage1
  End Sub

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

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Set cls.IC = Nothing
    Set cls = Nothing
End Sub
 
Upvote 0
re
i see your proposition
you said for changing hwnd multipage to multipge.pages(x) with unknow child
VBA Code: 
Private Sub MultiPage1_MouseMove(ByVal Index As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
 SetMouseWheel MultiPage1.Pages(MultiPage1.Value)
End Sub
its not working like that you want
unknow+child give you always a handle of userform client area
im my proposition i use windowfrompoint its very sure
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
Run-Time Error 381
2
Replies
12
Views
505
Micron
M
C
  • Question Question
A Bookmark to return to the same row when exiting and opening the application
Replies
8
Views
662
Edgar_
Edgar_
A
  • Question Question
What is wrong with this VBA code: userForm get hand ico for pointer on hover
2
Replies
15
Views
2K
RoryA
RoryA
P
  • Question Question
RUNTIME ERROR 91 for USERFORM CODE
Replies
1
Views
291
6StringJazzer
6StringJazzer
D
  • Solved
Show Tag of a Commandbutton in an Excel sheet (Vba Macro)
2
Replies
11
Views
901
Joe4
Joe4

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top