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

[محمد عبدالسلام]

السلام عليكم ورحمة الله وبركاتة

المطلوب

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

كي  يصبح من السهل تصفح البينات  خاصتا عندما تكون البينات كترة 

 

العطارتمسنا_2015_07_21_2_2.zip

[ياسر خليل أبو البراء]

جرب الكود التالي ..أدرج موديول جديد وضع فيه الكود التالي

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 PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg 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 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 Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201

Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean

Sub HookListBoxScroll()
    Dim lngAppInst As Long
    Dim hwndUnderCursor As Long
    Dim tPT As POINTAPI
    GetCursorPos tPT
    hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
    If mListBoxHwnd <> hwndUnderCursor Then
        UnhookListBoxScroll
        mListBoxHwnd = hwndUnderCursor
        lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
        PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
        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
        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
    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
                    PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
                Else
                    PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
                End If
                PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                Exit Function
            End If
        Else
            UnhookListBoxScroll
        End If
    End If
    MouseProc = CallNextHookEx( _
                mLngMouseHook, nCode, wParam, ByVal lParam)
    Exit Function
errH:
    UnhookListBoxScroll
End Function

ثم في حدث الفورم أضف الكود التالي

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    HookListBoxScroll
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    UnhookListBoxScroll
End Sub

 

[محمد عبدالسلام]

اخي ياسر خليل أبو البراء جزاك الله خير الجزاء جعله الله في ميزان حسناتك الله وأنار قلبك بالايمان ورزقك الفردوس الاعلى من الجنان دمت بحفظ الرحمن

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

تم تعديل أغسطس 15, 2015 بواسطه محمد عبدالسلام