كود عام لتفعيل عجلة الماوس على جميع عناصر التحكم (الكونترولس) في اليوزرفورم

[جعفر الطريبق]

السلام عليكم.

أفتقد هذا المنتدى لأنني لم أزوره منذ فترة طويلة.

كما هو معلوم خاصية التمرير باستخدام عجلة الماوس غير متاحة على اليوزرفورم رغم أنها خاصية مهمة ومطلوبة .

لقد كتبت مؤخرا هذا الكود لحل هذه المشكلة ... الكود عام ويشتغل على يوزرفومات متعددة .

الكود سهل الاستعمال حيث يمنح للمستعمل الحدث التالي الذي يكون موجودا داخل موديول الفورم والذي يعطي للمستعمل كل التحكم 

ملف للتحميل

 

تعريف الحدث هو كالتالي:

Public Sub OnMouseWheelScroll( _
    ByVal UserForm As Object, _
    ByVal obj As Object, _
    ByVal WheelRotation As WHEEL_ROTATION, _
    ByVal CtrlKey As CTRL_KEY_PRESS_STATE, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByRef Cancel As Boolean _
)

 

 

 

على كل- الكود بأكمله على النحو التالي:
 

1 - كود في موديول عادي :

Option Explicit

Public Enum CTRL_KEY_PRESS_STATE
    Released
    Pressed
End Enum

Public Enum WHEEL_ROTATION
    Forward
    Backward
End Enum

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

#If Win64 Then
    Private Type MSG
        hwnd As LongLong
        message As Long
        wParam As LongLong
        lParam As LongLong
        time As Long
        pt As POINTAPI
    End Type
#Else
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
#End If
    
#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
    #Else
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As Any, pvarChild As Variant) As Long
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    #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 GetCursorPos Lib "user32.dll" (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 Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    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 EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
    Private Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
    Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hwnd As LongPtr, ByVal gaFlags As Long) As LongPtr
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

    Private hwnd As LongPtr, hObjUnderMouse As LongPtr, lPtr As LongPtr
#Else
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow 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 EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
    Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
    Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function GetAncestor Lib "user32" (ByVal hwnd As Long, ByVal gaFlags As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    
    Private hwnd As Long, hObjUnderMouse As Long
#End If

Private oCurrentUserForm As Object, oCurrentIgnoreList As Variant
Private oCollection As Collection
Private objUnderMouse As Object

Private WheelRotation As WHEEL_ROTATION
Private CtrlKey As CTRL_KEY_PRESS_STATE
Private tMsg As MSG
Private tCurPos As POINTAPI, tPt As POINTAPI, tWinRect As RECT, tClient As RECT
Private oIA As IAccessible, oIACtrl As IAccessible, oIAPage As IAccessible
Private oTempCtrl As Control, oCtrl As Control, oTempPage As Control
Private vKid  As Variant
Private lLeft As Long, lTop As Long, lAccResult As Long, lPtInRectlResult As Long, i As Long
Private bCancel As Boolean




Public Property Let EnableWheelScroll(ByVal UserForm As Object, Optional IgnoreList As Variant, ByVal Enable As Boolean)

    Call KillTimer(hwnd, 0)
    If Enable = False Then
        Set oCollection = Nothing
    Else
        Set oCurrentUserForm = UserForm
        oCurrentIgnoreList = IgnoreList
        Call IUnknown_GetWindow(UserForm, VarPtr(hwnd))
        Set oCollection = New Collection
        Call SetTimer(hwnd, 0, 0, AddressOf TimerProc)
    End If

End Property



'________________________________PRIVATE SUBS___________________________________

Private Sub TimerProc()

    Const SCROLL_CHANGE = 20     ' <== Change Const as required '//
    '/////////////////////////////////////////////////////////////

    Const CHILDID_SELF = &H0&
    Const S_OK As Long = &H0
    Const WM_NCLBUTTONDOWN = &HA1
    Const WM_TIMER = &H113
    Const WM_MOUSEWHEEL = &H20A
    Const WHEEL_DELTA = 120
    Const PM_REMOVE = &H1
    Const MK_CONTROL = &H8
    Const GA_ROOT = 2
    Const POINTSPERINCH As Long = 72
    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    

    On Error Resume Next
    
    'RETRIEVE AND STORE THE LOCATION OF EACH CONTROL.
    For Each oIACtrl In oCurrentUserForm.Controls
        Set oTempCtrl = oIACtrl
        If IsError(Application.Match(TypeName(oTempCtrl), oCurrentIgnoreList, 0)) Then
            Call oIACtrl.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF)
            If TypeName(oTempCtrl) = "MultiPage" Then
                Set oIAPage = oTempCtrl.Pages(oTempCtrl.Value)
                Call oIAPage.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF)
                Set oTempPage = oIAPage
                oCollection.Add oTempPage, CStr(lLeft & lTop & oTempCtrl.Name & oTempCtrl.Pages(oTempCtrl.Value).Caption)
            End If
            oCollection.Add oTempCtrl, CStr(lLeft & lTop)
        End If
    Next
        
    'RETRIEVE ELEMENTS UNDER THE MOUSE POINTER.
    Call GetCursorPos(tCurPos)
    Call GetWindowRect(hwnd, tWinRect)
    
    #If Win64 Then
        Call CopyMemory(lPtr, tCurPos, LenB(tCurPos))
        lAccResult = AccessibleObjectFromPoint(lPtr, oIA, vKid)
        hObjUnderMouse = WindowFromPoint(lPtr)
        lPtInRectlResult = PtInRect(tWinRect, lPtr)
    #Else
        lAccResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
        hObjUnderMouse = WindowFromPoint(tCurPos.X, tCurPos.Y)
        lPtInRectlResult = PtInRect(tWinRect, tCursPos.X, tCursPos.Y)
    #End If
    
    'EXIT TIMER PROC IF MOUSE OUTSIDE FORM RECT.
    If lPtInRectlResult = 0 Then
        Call KillTimer(hwnd, 0)
        GoTo Xit
    End If
 
    If lAccResult = S_OK Then
    
        Call oIA.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF)
        Set objUnderMouse = oCollection.Item(lLeft & lTop)
        
        If GetAncestor(hObjUnderMouse, GA_ROOT) <> hwnd Then
            If TypeName(objUnderMouse) <> "ComboBox" Then
                Exit Sub
            End If
        End If
        
        For Each oCtrl In oCurrentUserForm.Controls
            If TypeName(oCtrl) = "MultiPage" Then
                Set objUnderMouse = oCollection.Item(lLeft & lTop & oCtrl.Name & oCtrl.Pages(oCtrl.Value).Caption)
            End If
        Next
        
        If oIA.accName(CHILDID_SELF) = oCurrentUserForm.Caption Then
            Set objUnderMouse = oCurrentUserForm
        End If
        
        'WAIT FOR A MOUSEWHEEL-SCROLL AND RAISE THE SCROLL PSEUDO-EVENT WHEN IT HAPPENS.
        If Not objUnderMouse Is Nothing Then
        
            Call GetMessage(tMsg, 0, 0, 0)
            
            'EXIT TIMER PROC WHEN MOVING THE FORM.
            If tMsg.message = WM_NCLBUTTONDOWN Then
                Call KillTimer(hwnd, 0)
                Call TranslateMessage(tMsg)
                Call DispatchMessage(tMsg)
                GoTo Xit
            End If
                
            tPt = tMsg.pt
            Call GetClientRect(hwnd, tClient)
            Call ScreenToClient(hwnd, tPt)
            
            If GetAsyncKeyState(vbKeyLButton) = 0 And tPt.Y <= 0 Then
                Call KillTimer(hwnd, 0)
                GoTo Xit
            End If
            
            'EXIT TIMER PROC WHEN MOVING THE FORM.
            If tPt.Y <= 0 Then
                If tMsg.message = WM_TIMER Then
                    Call KillTimer(hwnd, 0)
                    Call TranslateMessage(tMsg)
                    Call DispatchMessage(tMsg)
                    GoTo Xit
                End If
            End If

            If tMsg.message = WM_MOUSEWHEEL Then
            
                CtrlKey = IIf(loword(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released)
        
                If (hiword(CLng(tMsg.wParam)) / WHEEL_DELTA) > 0 Or (hiword(CLng(tMsg.wParam)) = WHEEL_DELTA) Then
                    WheelRotation = Forward
                Else
                    WheelRotation = Backward
                End If
                
                'RAISE THE PSEUDO-SCROLL EVENT LOCATED IN THE oCurrentUserForm MODULE.
                Call oCurrentUserForm.OnMouseWheelScroll(oCurrentUserForm, objUnderMouse, WheelRotation, CtrlKey, tCurPos.X - lLeft, tCurPos.Y - lTop, bCancel)
                 
                'IF SCROLL EVENT NOT CANCELED FOR THE CURRENT CONTROL, GO AHEAD AND IMPLEMENT THE SCROLLING.
                If Not bCancel Then
                
                    If TypeName(objUnderMouse) = "TextBox" Then
                        With objUnderMouse
                            .SetFocus
                            If i = 0 Then
                                .SelStart = 0
                            Else
                                .SelStart = IIf(.SelStart = .LineCount, 0, .SelStart)
                            End If
                            If WheelRotation = Forward Then
                                .CurLine = .CurLine - 1
                            Else
                                .CurLine = IIf(.CurLine = .LineCount - 1, .CurLine, .CurLine + 1)
                            End If
                        End With
                        i = i + 1
                    End If
                    
                    If TypeName(objUnderMouse) = "ScrollBar" Then
                        With objUnderMouse
                            If WheelRotation = Forward Then
                                .Value = IIf(.Value - objUnderMouse.SmallChange > .Min, .Value - objUnderMouse.SmallChange, .Min)
                            Else
                                .Value = IIf(.Value + objUnderMouse.SmallChange < .Max, .Value + objUnderMouse.SmallChange, .Max)
                            End If
                        End With
                    End If
                    
                    If TypeName(objUnderMouse) = "ListBox" Or TypeName(objUnderMouse) = "ComboBox" Then
                    
                        With objUnderMouse
                            If CtrlKey = Released Then
                                If WheelRotation = Forward Then
                                .TopIndex = .TopIndex - 1
                                Else
                                .TopIndex = .TopIndex + 1
                                End If
                            Else
                                .SetFocus
                                If WheelRotation = Forward Then
                                    SendKeys "{LEFT}", True
                                    DoEvents
                                    SendKeys "{RIGHT}", True
                                Else
                                    SendKeys "{RIGHT}", True
                                    DoEvents
                                    SendKeys "{RIGHT}", True
                                End If
                            End If
                        End With
                        
                    End If
                    
                    If TypeName(objUnderMouse) <> "ComboBox" Then
                        Call EnumWindows(AddressOf HideDropDown, ByVal 0)
                    End If
                    
                    With objUnderMouse
                        If CtrlKey = Released Then
                            If WheelRotation = Forward Then
                                .ScrollTop = Application.Max(0, .ScrollTop - SCROLL_CHANGE)
                            Else
                                .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE)
                            End If
                        Else
                            If WheelRotation = Forward Then
                                .ScrollLeft = Application.Max(0, .ScrollLeft - SCROLL_CHANGE)
                            Else
                                .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE)
                            End If
                        End If
                    End With
                    
                End If
            End If
        End If
    End If

    Call TranslateMessage(tMsg)
    Call DispatchMessage(tMsg)
    
    Exit Sub

Xit:
    
    Call SetTimer(hwnd, 0, 0, AddressOf TimerProc)

End Sub



Private Function loword(DWord As Long) As Integer
    If DWord And &H8000& Then
        loword = DWord Or &HFFFF0000
    Else
        loword = DWord And &HFFFF&
    End If
End Function

Private Function hiword(ByVal DWord As Long) As Integer
    hiword = (DWord And &HFFFF0000) \ &H10000
End Function


#If Win64 Then
    Private Function HideDropDown(ByVal hwnd As LongLong, ByVal lParam As Long) As Long
#Else
    Private Function HideDropDown(ByVal hwnd As Long, ByVal lParam As Long) As Long
#End If

    Dim sClassName As String * 256
    
    Call GetClassName(hwnd, sClassName, 256)
    If Left(sClassName, 2) = "F3" Then
        Call ShowWindow(hwnd, 0)
        HideDropDown = 0
        Exit Function
    End If
    HideDropDown = 1

End Function

 

 

2 - كود في اليوزرفورم موديول
 

Option Explicit

Private Sub UserForm_Initialize()
    Dim i As Long

    For i = 1 To 100
        Me.ListBox1.AddItem i
        Me.ComboBox1.AddItem i
    Next i
End Sub

Private Sub UserForm_Activate()
    EnableWheelScroll(Me) = True
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    EnableWheelScroll(Me) = False
    With Sheet1
        .[a9].ClearContents
        .[a12].ClearContents
        .[a15].ClearContents
        .[a18].ClearContents
        .[a21].ClearContents
        .[a24].ClearContents
        .[a27].ClearContents
    End With
End Sub


Private Sub CommandButton1_Click()
    UserForm2.Show vbModeless
End Sub

Private Sub CommandButton2_Click()
    Unload Me
End Sub



'--------------------
'Public Generic event
'Set the Cancel Argument to TRUE to disable scrolling
Public Sub OnMouseWheelScroll( _
    ByVal UserForm As Object, _
    ByVal obj As Object, _
    ByVal WheelRotation As WHEEL_ROTATION, _
    ByVal CtrlKey As CTRL_KEY_PRESS_STATE, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByRef Cancel As Boolean _
)

    With Sheet1
        If TypeName(obj) = "Page" Then
            .[a12] = obj.Parent.Name & "." & obj.Name
        Else
            .[a12] = obj.Name
        End If
        .[a9] = UserForm.Name
        .[a15] = IIf(WheelRotation = Forward, "Forward", "Backward")
        .[a18] = IIf(CtrlKey = Pressed, "Pressed", "Released")
        .[a21] = IIf(CtrlKey = Pressed, "Horizontal", "Vertical")
        .[a24] = X
        .[a27] = Y
    End With

End Sub

 

أتمنى أن يكون الكود مفيدا وإذا وجدت أي مشكلة ، فيرجى إبلاغي بذلك.  وأخيرا أتقدم بسلام خاص للأستاذ الفاضل ياسر خليل من مصر الحبيبة الذي عرفني بهذا المنتدى 

[أ / محمد صالح]

بارك الله لك

كود رائع

[Ali Mohamed Ali]

أحسنت استاذ جعفر ... كود ممتاز جزاك الله كل خير وأحسن الله اليك