تفعيل عجلة الماوس في اليست بوكس و الكومبوبوكس

[شوقي ربيع]

السلام عليكم

رمضان كريم على الجميع

وجدة هذا الكود الخاص بتفعيل عجلة الماوس لليست بوكس كما وجدة بأنه يعمل كذلك مع الكومبو بوكس

فأردت مشاركته اياكم لتعميم الفائدة وانا بصراحة اعجبني حيث انه  يصبح من السهل تصفح البينات  خاصتا عندما تكون كبيرة 

كل ما عليكم وضع هذا الكود في موديل عادي

Option Explicit

Private Type POINTAPI
        X As Long
        Y As Long
End Type

Private Type MOUSEHOOKSTRUCT
        pt As POINTAPI
        hwnd As Long
        wHitTestCode As Long
        dwExtraInfo As Long
End Type

Private Declare Function FindWindow Lib "user32" _
                                        Alias "FindWindowA" ( _
                                                        ByVal lpClassName As String, _
                                                        ByVal lpWindowName As String) As Long

Private Declare Function GetWindowLong Lib "user32.dll" _
                                        Alias "GetWindowLongA" ( _
                                                        ByVal hwnd As Long, _
                                                        ByVal nIndex As Long) As Long

Private Declare Function SetWindowsHookEx Lib "user32" _
                                        Alias "SetWindowsHookExA" ( _
                                                        ByVal idHook As Long, _
                                                        ByVal lpfn As Long, _
                                                        ByVal hmod As Long, _
                                                        ByVal dwThreadId As Long) As Long

Private Declare Function CallNextHookEx Lib "user32" ( _
                                                        ByVal hHook As Long, _
                                                        ByVal nCode As Long, _
                                                        ByVal wParam As Long, _
                                                        lParam As Any) As Long

Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
                                                        ByVal hHook As Long) As Long


Private Declare Function WindowFromPoint Lib "user32" ( _
                                                        ByVal xPoint As Long, _
                                                        ByVal yPoint As Long) As Long

Private Declare Function GetCursorPos Lib "user32.dll" ( _
                                                        ByRef lpPoint As POINTAPI) As Long

Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean
Private mCtl As MSForms.Control
Dim n As Long

Sub HookListBoxScroll(frm As Object, ctl As MSForms.Control)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
     GetCursorPos tPT
     hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
     If Not frm.ActiveControl Is ctl Then
             ctl.SetFocus
     End If
     If mListBoxHwnd <> hwndUnderCursor Then
             UnhookListBoxScroll
             Set mCtl = ctl
             mListBoxHwnd = hwndUnderCursor
             lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
             If Not mbHook Then
                     mLngMouseHook = SetWindowsHookEx( _
                                                     WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
                     mbHook = mLngMouseHook <> 0
             End If
     End If
End Sub

Sub UnhookListBoxScroll()
     If mbHook Then
                Set mCtl = Nothing
             UnhookWindowsHookEx mLngMouseHook
             mLngMouseHook = 0
             mListBoxHwnd = 0
             mbHook = False
        End If
End Sub

Private Function MouseProc( _
             ByVal nCode As Long, ByVal wParam As Long, _
             ByRef lParam As MOUSEHOOKSTRUCT) As Long
Dim idx As Long
        On Error GoTo errH
     If (nCode = HC_ACTION) Then
             If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then
                     If wParam = WM_MOUSEWHEEL Then
                                MouseProc = True
                                If lParam.hwnd > 0 Then idx = -1 Else idx = 1
                         idx = idx + mCtl.TopIndex
                         If idx >= 0 Then mCtl.TopIndex = idx

                                Exit Function
                     End If
             Else
                     UnhookListBoxScroll
             End If
     End If
     MouseProc = CallNextHookEx( _
                             mLngMouseHook, nCode, wParam, ByVal lParam)
     Exit Function
errH:
     UnhookListBoxScroll
End Function

ثم في حدث MouseMove بالنسبة للكومبوبوكس ضع هذا الكود

HookListBoxScroll Me, Me.ComboBox1

اما بالنسبة لليست بوكس في حدث  MouseDown ضع هذا الكود

HookListBoxScroll Me, Me.ListBox1

وفي الاخير في حدث  UserForm_QueryClose ضع هذا الكود

UnhookListBoxScroll

ارجو ان يفيدكم الموضوع

قبل الله صيام الجميع

تفعيل عجلة الماوس.rar

[مصطفى كمال متولى]

السلام عليكم

الاخ  شوقي ربيع
رمضان كريم

جزاك الله خيرا

يصلح فقط داخل الفورم وليس مربع القائمة 

ولو فى كود لتكبير الخط لمربع التحرير والسرد تشكر

تم تعديل يوليو 17, 2013 بواسطه مصطفى كامل

[إبراهيم ابوليله]

اخى واستاذنا شوقى ربيع

بارك الله فيك

كود رائع جدا

واعتقد ان الجميع سوف يستفيد منه

مشكورا على هذه الهديه الرائعه

[شوقي ربيع]

 

السلام عليكم

الاخ  شوقي ربيع

رمضان كريم

جزاك الله خيرا

يصلح فقط داخل الفورم وليس مربع القائمة 

ولو فى كود لتكبير الخط لمربع التحرير والسرد تشكر

 

الكود يعمل جيدا

انقل الكود الموجود في حدث MouseDown بالنسبة مربع القائمة الى الحدث MouseMove

[شوقي ربيع]

اخى واستاذنا شوقى ربيع

بارك الله فيك

كود رائع جدا

واعتقد ان الجميع سوف يستفيد منه

مشكورا على هذه الهديه الرائعه

شكرا لكلماتك الجميلة

تحياتي

[megonil]

أشكر الأستاذ شوقى ربيع
ولكنى اريد تفعيل هذا الكود
اوما ينتج منه فى 
Data Validation List

وليس فى الفورم 
ماذا افعل وانا فى انتظار ردك 
وشكرآ مره أخرى 

[حمادة عمر]

السلام عليكم

الاخ الحبيب / شوقي ربيع

بارك الله فيك

دائما تحب الافادة والاستفادة للجميع باي شكل وباي طريقة

ودائما ملك الحركات

حتي في عثورك علي بعض الاكواد من بعض المنتديات

تعثر علي كود خاص ايضا ببعض الحركات

تقبل تحياتي

جزاك الله خيرا

رمضان كريم

تم تعديل يوليو 17, 2013 بواسطه حمادة عمر

[شوقي ربيع]

أشكر الأستاذ شوقى ربيع

ولكنى اريد تفعيل هذا الكود

اوما ينتج منه فى 

Data Validation List

وليس فى الفورم 

ماذا افعل وانا فى انتظار ردك 

وشكرآ مره أخرى 

السلام عليكم

شكرا لمرورك

بخصوص طلبك اعتقد انه لدي  رأيته سابقا سأبحث  عنه وأعلمك بالامر

رمضان كريم

[شوقي ربيع]

السلام عليكم

الاخ الحبيب حمادة عمر

رمضان كريم

يكفيني مرورك العطر ويسعدني دائما تواجدك في المنتدى

جزاك الله خيرا

تقبل الله صيام الجميع

[حمادة عمر]

أشكر الأستاذ شوقى ربيع

ولكنى اريد تفعيل هذا الكود

اوما ينتج منه فى 

Data Validation List

وليس فى الفورم 

ماذا افعل وانا فى انتظار ردك 

وشكرآ مره أخرى 

 

الاخوة الكرام

بعد اذن اخي الحبيب / شوقي ربيع

اقدم لكم ملف به كود للعلامة القدير / جعفر طرباق المغربي

به كود لتنفيذ الطلب الخاص بـ Data Validation List

اليكم الملف بالمرفقات به الاكواد ... وطريقة وضع الاكواد في المشاركة التالية

ارجو ان يفي بطلبكم

 

 

DataValidationMouseScroll.rar

[شوقي ربيع]

شكرا جزيلا اخي حمادة

هو الملف بعينه الذي قصدته

تحياتي

[حمادة عمر]

الخطوات :

1- ضع هدا الكود في ThisWorkBook Module

Option Explicit

Private Sub Workbook_Open()

    Application.Goto ActiveSheet.Cells(1, 1), True

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    'Safety measure in case hook still installed.
    Call UnHookValidationList
    Call Delay(2) 'two seconds.

End Sub

Private Sub Delay(sTime As Single)

    Dim t As Single
    
    t = Timer
    Do
    DoEvents
    Loop Until Timer - t >= sTime

End Sub

2- ضع هدا الكود في Sheet Module ( موديول الصفحة الموجود فيها القائمة المنسدلة)

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    If HasValidateList(Target) Then
    
        Call HookValidationList
    
    Else
    
        Call UnHookValidationList
    
    End If
 
End Sub


Private Function HasValidateList(Cell As Range) As Boolean
 
    On Error Resume Next
    HasValidateList = Cell.Validation.InCellDropdown
 
End Function

3- و اخيرا هدا الكود في ( Standard Module)

Option Explicit
 
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" _
() As Long
 
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex 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 SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
 
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
 
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
Private Declare Function WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
 
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
 
Private Type POINTAPI
  X As Long
  Y As Long
End Type
 
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
 
Private Const WH_CBT                      As Long = 5
Private Const HCBT_CREATEWND        As Long = 3
Private Const HCBT_DESTROYWND      As Long = 4
Private Const WH_MOUSE_LL             As Long = 14
Private Const WM_MOUSEWHEEL        As Long = &H20A
Private Const HC_ACTION                 As Long = 0
Private Const GWL_HINSTANCE          As Long = (-6)
 
Private lCBTHook                             As Long
Private lMouseHook                          As Long
Private lAppHwnd                            As Long
Private lDeskHwnd                           As Long
Private lWkbHwnd                           As Long
Private lDropDownHwnd                   As Long
 
Sub HookValidationList()
 
    On Error Resume Next
    
    lAppHwnd = _
    FindWindow("XLMAIN", Application.Caption)
    lDeskHwnd = FindWindowEx _
    (lAppHwnd, 0, "XLDESK", vbNullString)
    lWkbHwnd = FindWindowEx _
    (lDeskHwnd, 0, "EXCEL7", vbNullString)
    lCBTHook = SetWindowsHookEx _
    (WH_CBT, AddressOf CBTProc, _
    GetAppInstance, GetCurrentThreadId)
        
 
End Sub

Sub UnHookValidationList()
 
    UnhookWindowsHookEx lCBTHook
    UnhookWindowsHookEx lMouseHook

End Sub


Private Function CBTProc _
(ByVal idHook As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
    Dim strBuffer As String
    Dim lRetVal As Long
 
    On Error Resume Next
    
    Select Case idHook
    
        Case Is = HCBT_CREATEWND
        
            strBuffer = Space(256)
            lRetVal = GetClassName(wParam, strBuffer, 256)
            If Left(strBuffer, lRetVal) = "EXCEL:" Then
            
             UnhookWindowsHookEx lCBTHook
                lDropDownHwnd = wParam
                lMouseHook = SetWindowsHookEx _
                (WH_MOUSE_LL, _
                AddressOf LowLevelMouseProc, GetAppInstance, 0)
                
            End If
            
        Case Is = HCBT_DESTROYWND
        
            If wParam = lDropDownHwnd Then
                UnhookWindowsHookEx lMouseHook
            End If
            
    End Select
    
    CBTProc = CallNextHookEx _
    (lCBTHook, idHook, ByVal wParam, ByVal lParam)
 
End Function

Private Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MSLLHOOKSTRUCT) As Long
 
    On Error Resume Next
    
    If (nCode = HC_ACTION) Then
    
        If wParam = WM_MOUSEWHEEL Then
        
            LowLevelMouseProc = True
            
            If lParam.mouseData > 0 Then
                SendKeys "{UP}"
            Else
                SendKeys "{DOWN}"
            End If
            
            Exit Function
            
        End If
        
        With lParam.pt

            If WindowFromPoint(.X, .Y) <> lDropDownHwnd _
            And WindowFromPoint(.X, .Y) <> lWkbHwnd Then
                ShowWindow lDropDownHwnd, 0
            End If

        End With
        
    End If
    
    LowLevelMouseProc = _
    CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam)
 
End Function
 
Private Function GetAppInstance() As Long
 
    GetAppInstance = GetWindowLong(lAppHwnd, GWL_HINSTANCE)
 
End Function

وان شاء الله يعمل معكم بالشكل الذي تريدونه

جزاكم الله خيرا

[حمادة عمر]

اخي الحبيب / شوقي ربيع

الشكر في البداية لك

فأنت صاحب الموضوع وصاحب الابداعات

وكنت متأكدا انك سوف تصل وترسل الملف لجميع الاخوة

ولكني سبقتك لفعل الخير هذه المرة ... هههه

جزاك الله خيرا

تقبل خالص تحياتي

[megonil]

اشكر كل من 
أ/ شوقى ربيع
أ/ حماده عمر
على هذا المجهود 
 

 

 

 

 

 

 

 

 

 

 

 

 

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*الإمساكية الذكية لعام 2013م /1434هـ

تم تعديل يوليو 18, 2013 بواسطه megonil

[saad abed]

اخى شوقى غريب

مواضيعك كلها ممتازه ومفيده

كل عام وانتم بخير

تحياتى حمادة عمر

كل عام وانتم بخير

[شوقي ربيع]

اخى شوقى غريب

مواضيعك كلها ممتازه ومفيده

كل عام وانتم بخير

تحياتى حمادة عمر

كل عام وانتم بخير

السلام عليكم

رمضان كريم

الاخ سعد عابد يشرفني مرورك ويسعدني دائما

تحياتي لك

[صلاح الدين المصلح]

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

[حمادة عمر]

الاخ الكريم / سعد عابد

جزاك الله خيرا

تقبل خالص تحياتي

[حمادة عمر]

الاخ الكريم / صلاح

جزاك الله خيرا

تقبل خالص تحياتي

والفضل في الاساس بعد الله في هذا الموضوع هو صاحبة الاخ الحبيب / شوقي ربيع .. جزاه الله خيرا

[شوقي ربيع]

الاخ الكريم / صلاح

جزاك الله خيرا

تقبل خالص تحياتي

والفضل في الاساس بعد الله في هذا الموضوع هو صاحبة الاخ الحبيب / شوقي ربيع .. جزاه الله خيرا

كلنا واحد في هذا المنتدى ان شاء الله

[ahlan_32]

شكرا لكل الاساتذا الكرام

سؤال هل يمكن تفعيل عجلة الماوس في الفورم نفسه

[ahlan_32]

الرجاء الرد بدون تعب اسف للازعاج

تم تعديل مارس 20, 2019 بواسطه ahlan_32

[ahlan_32]

up

[مهند محسن]

لا يمكن عمل هذا

[ahlan_32]

شكر جزيلا اخي مهند محسن

اقصد لو عندنا فورم به scrollbars كالمثال المرفق هل يمكن ان نحرك scrollbars بعجلة الموس

 

تجربة.xlsm

تم تعديل مارس 23, 2019 بواسطه ahlan_32