جعفر الطريبق

السلام عليكم.
أفتقد هذا المنتدى لأنني لم أزوره منذ فترة طويلة.
كما هو معلوم خاصية التمرير باستخدام عجلة الماوس غير متاحة على اليوزرفورم رغم أنها خاصية مهمة ومطلوبة .
لقد كتبت مؤخرا هذا الكود لحل هذه المشكلة ... الكود عام ويشتغل على يوزرفومات متعددة .
الكود سهل الاستعمال حيث يمنح للمستعمل الحدث التالي الذي يكون موجودا داخل موديول الفورم والذي يعطي للمستعمل كل التحكم 
ملف للتحميل
 
تعريف الحدث هو كالتالي:
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  
أتمنى أن يكون الكود مفيدا وإذا وجدت أي مشكلة ، فيرجى إبلاغي بذلك.  وأخيرا أتقدم بسلام خاص للأستاذ الفاضل ياسر خليل من مصر الحبيبة الذي عرفني بهذا المنتدى