'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'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 Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length 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
Private Function PointApiToLong(point As POINTAPI) As LongLong
Dim DbLL As LongLong
Dim structLong As LongPtr
structLong = LenB(DbLL)
If LenB(point) = structLong Then CopyMemory VarPtr(DbLL), VarPtr(point), structLong
PointApiToLong = DbLL
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 Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Private Declare 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 SetFocus Ctrl.[_GethWnd]
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