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

**شوقي ربيع** · يوليو 16, 2013

السلام عليكم

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

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

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

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

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

السلام عليكم

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

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

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

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

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

**إبراهيم ابوليله** · يوليو 17, 2013

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

بارك الله فيك

كود رائع جدا

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

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

**شوقي ربيع** · يوليو 17, 2013

السلام عليكم

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

رمضان كريم

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

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

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

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

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

**شوقي ربيع** · يوليو 17, 2013

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

بارك الله فيك

كود رائع جدا

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

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

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

تحياتي

megonil · يوليو 17, 2013

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

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

**حمادة عمر** · يوليو 17, 2013

السلام عليكم

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

بارك الله فيك

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

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

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

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

تقبل تحياتي

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

رمضان كريم

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

**شوقي ربيع** · يوليو 17, 2013

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

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

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

Data Validation List

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

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

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

السلام عليكم

شكرا لمرورك

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

رمضان كريم

**شوقي ربيع** · يوليو 17, 2013

السلام عليكم

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

رمضان كريم

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

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

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

**حمادة عمر** · يوليو 17, 2013

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

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

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

Data Validation List

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

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

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

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

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

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

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

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

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

DataValidationMouseScroll.rar

**شوقي ربيع** · يوليو 17, 2013

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

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

تحياتي

**حمادة عمر** · يوليو 17, 2013

الخطوات :

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

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

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

**حمادة عمر** · يوليو 17, 2013

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

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

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

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

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

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

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

megonil · يوليو 18, 2013

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

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

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

**saad abed** · يوليو 18, 2013

اخى شوقى غريب

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

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

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

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

**شوقي ربيع** · يوليو 19, 2013

اخى شوقى غريب

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

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

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

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

السلام عليكم

رمضان كريم

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

تحياتي لك

صلاح الدين المصلح · يوليو 20, 2013

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

**حمادة عمر** · يوليو 20, 2013

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

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

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

**حمادة عمر** · يوليو 20, 2013

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

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

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

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

**شوقي ربيع** · يوليو 20, 2013

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

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

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

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

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

ahlan_32 · مارس 19, 2019

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

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

ahlan_32 · مارس 20, 2019

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

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

ahlan_32 · مارس 23, 2019

up

**مهند محسن** · مارس 23, 2019

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

ahlan_32 · مارس 23, 2019

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

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

تجربة.xlsm

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

تسجيل الدخول

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

الردود الموصى بها

شوقي ربيع

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

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

شوقي ربيع

شوقي ربيع

megonil

حمادة عمر

شوقي ربيع

شوقي ربيع

حمادة عمر

شوقي ربيع

حمادة عمر

حمادة عمر

megonil

saad abed

شوقي ربيع

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

حمادة عمر

حمادة عمر

شوقي ربيع

ahlan_32

ahlan_32

ahlan_32

مهند محسن

ahlan_32

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information