البحث في الموقع

السلام عليكم السكرول بعجلة الماوس غير ممكن مع الفورم أو الكنترولات ... الكود التالي يفتح هذه الامكانية وهو كود جامع موحد ملف للتحميل 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 Private Type LongToInteger Low As Integer High As Integer End Type #If VBA7 Then Private Type MSG hwnd As LongPtr message As Long wParam As LongPtr lParam As LongPtr time As Long pt As POINTAPI End Type Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long Private Declare PtrSafe Function WaitMessage Lib "user32" () 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 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 Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As LongPtr) Private Declare PtrSafe Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long #If Win64 Then Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long #Else Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long #End If #Else Private Type MSG hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wCmd 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function WaitMessage Lib "user32" () As Long Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long) Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long #End If Private Const CHILDID_SELF = &H0& Private Const S_OK As Long = &H0 Private Const POINTSPERINCH As Long = 72 Private Const LOGPIXELSX As Long = 88 Private Const LOGPIXELSY As Long = 90 Private Const WM_MOUSEWHEEL = &H20A Private Const PM_REMOVE = &H1 Private bCancelProcessing As Boolean Private Const MK_CONTROL = &H8 Private Const SCROLL_CHANGE = 10 Private arObjCaptions() As Variant Private arObjPointers() As Variant Public Sub HookMouseWheelScroll(ByVal UF As Object) Dim WheelRotation As WHEEL_ROTATION Dim CtrlKey As CTRL_KEY_PRESS_STATE Dim tMsg As MSG Dim tCurPos As POINTAPI Dim oIA As IAccessible Dim oObjUnderMouse As Object Dim oPage As Object Dim oCtrl As Object Dim vKid As Variant Dim i As Long Dim j As Long Dim lResult As Long Dim bCancel As Boolean Static k As Long #If VBA7 Then Dim Ptr As LongPtr #Else Dim Ptr As Long #End If bCancelProcessing = False k = 0 UF.Caption = UF.Caption & Chr(10) j = 0 Erase arObjCaptions Erase arObjPointers For Each oCtrl In UF.Controls If TypeName(oCtrl) = "MultiPage" Then For Each oPage In oCtrl.Pages i = i + 1 oPage.Caption = oPage.Caption & String(i, Chr(10)) ReDim Preserve arObjCaptions(j) ReDim Preserve arObjPointers(j) arObjCaptions(j) = oPage.Caption & Chr(10) arObjPointers(j) = ObjPtr(oPage) j = j + 1 Next End If Next Do While Not bCancelProcessing DoEvents GetCursorPos tCurPos #If Win64 Then CopyMemory Ptr, tCurPos, LenB(tCurPos) lResult = AccessibleObjectFromPoint(Ptr, oIA, vKid) #Else lResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid) #End If If lResult = S_OK Then On Error Resume Next Set oObjUnderMouse = objUnderMouse(UF, oIA, tCurPos) If Not oObjUnderMouse Is Nothing Then WaitMessage If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then CtrlKey = IIf(LoWord(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released) WheelRotation = IIf(tMsg.wParam > 0, Forward, Backward) Call UF.OnScrollEvent(oObjUnderMouse, WheelRotation, CtrlKey, tMsg.pt.X, tMsg.pt.Y, bCancel) If Not bCancel Then If TypeName(oObjUnderMouse) = "TextBox" Then With oObjUnderMouse .SetFocus If k = 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 k = k + 1 End If If TypeName(oObjUnderMouse) = "ScrollBar" Then With oObjUnderMouse If WheelRotation = Forward Then .Value = IIf(.Value - oObjUnderMouse.SmallChange > .Min, .Value - oObjUnderMouse.SmallChange, .Min) Else .Value = IIf(.Value + oObjUnderMouse.SmallChange < .Max, .Value + oObjUnderMouse.SmallChange, .Max) End If End With End If If TypeName(oObjUnderMouse) = "ListBox" Or TypeName(oObjUnderMouse) = "ComboBox" Then With oObjUnderMouse 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(oObjUnderMouse) = UF.Name Or TypeName(oObjUnderMouse) = "Frame" Or TypeName(oObjUnderMouse) = "Page" Then With oObjUnderMouse If CtrlKey = Released Then If WheelRotation = Forward Then .ScrollTop = Application.Max(0, .ScrollTop - 5) Else .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE) End If Else If WheelRotation = Forward Then .ScrollLeft = Application.Max(0, .ScrollLeft - 5) Else .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE) End If End If End With End If End If DoEvents End If End If End If Loop End Sub Public Sub RemoveMouseWheelHook() bCancelProcessing = True End Sub 'Private Routines .. '------------------- Private Function objUnderMouse(ByVal UF As Object, ByVal oAcc As IAccessible, MouseLoc As POINTAPI) As Object #If VBA7 Then Dim lngPtr As LongPtr Dim lObjPtr As LongPtr Dim lCtrlPtr As LongPtr Dim hwndForm As LongPtr Dim hwndFromPoint As LongPtr #Else Dim lObjPtr As Long Dim lCtrlPtr As Long Dim hwndForm As Long Dim hwndFromPoint As Long #End If Dim arCtrlsPosition() As Variant Dim arCtrlsPointers() As Variant Dim tPt As POINTAPI Dim tRect As RECT Dim oObj As Object Dim oCtrl As Control Dim sBuffer As String Dim lCtrlLeft As Long Dim lCtrlTop As Long Dim lPos1 As Long Dim lPos2 As Long Dim lPos3 As Long Dim lRet As Long Dim i As Long On Error Resume Next hwndForm = FindWindow(vbNullString, UF.Caption) For Each oCtrl In UF.Controls ReDim Preserve arCtrlsPosition(i + 1) ReDim Preserve arCtrlsPointers(i + 1) tPt = GetRealCtrlScreenLocation(oCtrl, hwndForm, UF) arCtrlsPosition(i) = tPt.X & tPt.Y arCtrlsPointers(i) = ObjPtr(oCtrl) arCtrlsPosition(i + 1) = tPt.X - 2 & tPt.Y - 1 arCtrlsPointers(i + 1) = ObjPtr(oCtrl) i = i + 2 Next lPos1 = WorksheetFunction.Match(oAcc.accName(CHILDID_SELF) & Chr(10), arObjCaptions, 0) lObjPtr = WorksheetFunction.Index(arObjPointers, 1, lPos1) Call oAcc.accLocation(lCtrlLeft, lCtrlTop, 0, 0, CHILDID_SELF) lPos2 = WorksheetFunction.Match(lCtrlLeft & lCtrlTop, arCtrlsPosition, 0) lCtrlPtr = WorksheetFunction.Index(arCtrlsPointers, 1, lPos2) #If VBA7 Then CopyMemory lngPtr, MouseLoc, LenB(MouseLoc) hwndFromPoint = WindowFromPoint(lngPtr) #Else hwndFromPoint = WindowFromPoint(MouseLoc.X, MouseLoc.Y) #End If sBuffer = Space(256) lRet = GetClassName(GetParent(hwndFromPoint), sBuffer, 256) lPos3 = InStr(1, Left(sBuffer, lRet), "MdcPopup") Select Case True Case lPos3 <> 0 Set objUnderMouse = GetActiveComboBox(UF) Exit Function Case oAcc.accName(CHILDID_SELF) = UF.Caption Set oObj = UF Case lObjPtr = 0 If IsBadCodePtr(lCtrlPtr) = 0 Then CopyMemory oObj, lCtrlPtr, 4 End If Case lObjPtr <> 0 If IsBadCodePtr(lObjPtr) = 0 Then CopyMemory oObj, lObjPtr, 4 End If End Select Set objUnderMouse = oObj If Not oObj Is Nothing Then ZeroMemory oObj, 4 End If End Function #If VBA7 Then Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As LongPtr, ByVal UF As Object) As POINTAPI #Else Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As Long, ByVal UF As Object) As POINTAPI #End If Dim tRect As RECT Dim tTopLeft As POINTAPI Dim oMultiPage As Control Dim oTempObj As Control On Error Resume Next Set oTempObj = Ctl.Parent With tTopLeft Select Case True Case oTempObj Is Nothing .X = PTtoPX(Ctl.Left - UF.ScrollLeft * UF.Zoom / 100, False) .Y = PTtoPX(Ctl.Top - UF.ScrollTop * UF.Zoom / 100, True) ClientToScreen hwnd, tTopLeft Case TypeName(oTempObj) = "Frame" GetWindowRect oTempObj.[_GethWnd], tRect .X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left + 2 .Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top + 8 Case TypeName(oTempObj) = "Page" Set oMultiPage = oTempObj.Parent GetWindowRect GetNextWindow(oMultiPage.[_GethWnd], 5), tRect .X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left .Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top Set oMultiPage = Nothing End Select End With GetRealCtrlScreenLocation = tTopLeft Set oTempObj = Nothing End Function Private Function GetActiveComboBox(ByVal Ctl As Object) As Control Dim oCtl As Object Dim lCur As Long On Error Resume Next For Each oCtl In Ctl.Controls Err.Clear lCur = oCtl.CurX If Err.Number = 0 And TypeName(oCtl) = "ComboBox" Then Set GetActiveComboBox = oCtl: Exit Function Next End Function Private Function LoWord(ByVal Word As Long) As Integer Dim X As LongToInteger CopyMemory X, Word, LenB(X) LoWord = X.Low End Function Private Function ScreenDPI(ByVal bVert As Boolean) As Long Static lDPI(1), lDC If lDPI(0) = 0 Then lDC = GetDC(0) lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX) lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY) lDC = ReleaseDC(0, lDC) End If ScreenDPI = lDPI(Abs(bVert)) End Function Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH End Function 2- كود في موديول الفورم Option Explicit Private Sub UserForm_Activate() Dim i As Long 'Populate the controls For i = 0 To 100 With ListBox1 .ColumnCount = 4 .ColumnWidths = "100;100;100;100" .AddItem "COLUMN1" .List(i, 1) = "COLUMN2" .List(i, 2) = "COLUMN3" .List(i, 3) = "COLUMN4" End With ListBox2.AddItem i ComboBox1.AddItem i ComboBox2.AddItem i ComboBox3.AddItem i ComboBox4.AddItem i ComboBox5.AddItem i ComboBox6.AddItem i ComboBox7.AddItem i ComboBox8.AddItem i ComboBox9.AddItem i Next i With TextBox1 .Text = .Text & String(300, "A") .Text = .Text & String(300, "I") .Text = .Text & String(300, "X") End With Label1.Caption = "Object :" Label2.Caption = "Wheel Rotation :" Label3.Caption = "Scroll Direction :" Label4.Caption = "Cursor X :" Label5.Caption = "Cursor Y :" Label6.Caption = "Scroll Cancelled :" 'Hook MouseWheel Scroll of Form and of all its controls Call HookMouseWheelScroll(Me) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Call RemoveMouseWheelHook End Sub Private Sub CommandButton1_Click() Unload Me End Sub '-------------------- 'Public Generic event '-------------------- Public Sub OnScrollEvent(ByVal Obj As Object, ByVal WheelRotation As WHEEL_ROTATION, _ ByVal CtrlKey As CTRL_KEY_PRESS_STATE, ByVal X As Long, ByVal Y As Long, Cancel As Boolean) Dim sObjName As String, sWheelRot As String, sCtrlKey As String Dim sCurX As String, sCurY As String, sCancelScrol As String sObjName = "Object : (" & Obj.Name & ")" sWheelRot = "Wheel Rotation : (" & IIf(WheelRotation = Forward, "Forward", "Backward") & ")" sCtrlKey = "Scroll Direction : (" & IIf(CtrlKey = Released, "Vert", "Horiz") & ")" sCurX = "Cursor X : (" & X & ")" sCurY = "Cursor Y : (" & Y & ")" sCancelScrol = "Scroll Cancelled : (" & Cancel & ")" Label1.Caption = sObjName Label2.Caption = sWheelRot Label3.Caption = sCtrlKey Label4.Caption = sCurX Label5.Caption = sCurY Label6.Caption = sCancelScrol End Sub