Control Scroll 2 listbox cùng lúc (1 người xem)

[ThaiDieuAnh]

Em có 2 listbox với số hàng bằng nhau. Có cách nào để Control Scroll 2 listbox này cùng lúc không ạ? Mong các anh chị giúp đỡ, xin cảm ơn

 

[truongvu317]

Tất nhiên là sẽ làm được, chỉ là cách scroll theo kiểu của bạn nó không ổn một chút nào. Khi tôi chưa click chuột mà chỉ di chuột lên listbox mà tôi xoay chuột thì nó đã chạy rồi. Điểm nữa là khi tôi chọn listbox rồi, di chuyển chuột qua chỗ khác thì chức năng scroll lại không chạy. Cái này hơi ngược trong thiết kế form.

 

[ThaiDieuAnh]

Tất nhiên là sẽ làm được, chỉ là cách scroll theo kiểu của bạn nó không ổn một chút nào. Khi tôi chưa click chuột mà chỉ di chuột lên listbox mà tôi xoay chuột thì nó đã chạy rồi. Điểm nữa là khi tôi chọn listbox rồi, di chuyển chuột qua chỗ khác thì chức năng scroll lại không chạy. Cái này hơi ngược trong thiết kế form.

Cái lăn chuột này em coppy trên mạng bác ạ. còn việc chọn khi click thì chuột mới chạy em làm được. Lăn chuột 2 list box cùng một lúc em mò mãi không được. Mong bác giúp đỡ

 

[truongvu317]

Có hai cách:
1: Dùng xự kiện di chuyển chuột trên các listbox để ra lệnh đồng bộ giữa hai listbox. Giả sự trong xự kiện move của listbox2 thì sẽ là listbox1.topindex=listbox2.topindex / đon giản, dễ thực hiện mình thì chưa thử

2: Tương tự, nhưng thực hiện trên modun, chứ không phải là form

 

[ThaiDieuAnh]

Có hai cách:
1: Dùng xự kiện di chuyển chuột trên các listbox để ra lệnh đồng bộ giữa hai listbox. Giả sự trong xự kiện move của listbox2 thì sẽ là listbox1.topindex=listbox2.topindex / đon giản, dễ thực hiện mình thì chưa thử

2: Tương tự, nhưng thực hiện trên modun, chứ không phải là form

Bác giúp em trên file đính kèm được khộng ạ. Em không hiểu lắm

 

[truongvu317]

Mà không hiểu bạn đang muốn làm cái gì nữa, gộp nó vào một listbox cho nhanh hơn không

 

[ThaiDieuAnh]

Mà không hiểu bạn đang muốn làm cái gì nữa, gộp nó vào một listbox cho nhanh hơn không

Em thử làm như bác "listbox1.topindex=listbox2.topindex " thì nó có chuyển dịch cả 2 Lb nhưng không đồng bộ được bác ạ

 

[truongvu317]

Em thử làm như bác "listbox1.topindex=listbox2.topindex " thì nó có chuyển dịch cả 2 Lb nhưng không đồng bộ được bác ạ

Đồng bộ được, nhưng nó không mượt mà thôi

 

[truongvu317]

' in the declarations area
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
'************************************************************************************
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" _
        Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
#Else
Private Declare Function FindWindow Lib "user32" _
        Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
#End If
'-------------
#If VBA7 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
        Alias "GetWindowLongA" ( _
        ByVal hWnd As Long, _
        ByVal nIndex As Long) As Long
#Else
Private Declare Function GetWindowLong Lib "user32.dll" _
        Alias "GetWindowLongA" ( _
        ByVal hWnd As Long, _
        ByVal nIndex As Long) As Long
#End If
'-------------
#If VBA7 Then
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
        Alias "SetWindowsHookExA" ( _
        ByVal idHook As Long, _
        ByVal lpfn As Long, _
        ByVal hmod As Long, _
        ByVal dwThreadId As Long) As Long
#Else
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
#End If
'-----------
#If VBA7 Then
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As Long, _
        ByVal nCode As Long, _
        ByVal wParam As Long, _
        ByRef lParam As Any) As Long
#Else
Private Declare Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As Long, _
        ByVal nCode As Long, _
        ByVal wParam As Long, _
        ByRef lParam As Any) As Long
#End If
'-------------
#If VBA7 Then
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hHook As Long) As Long
#Else
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hHook As Long) As Long
#End If
'------------
#If VBA7 Then
Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
        ByVal xPoint As Long, _
        ByVal yPoint As Long) As Long
#Else
Private Declare Function WindowFromPoint Lib "user32" ( _
        ByVal xPoint As Long, _
        ByVal yPoint As Long) As Long
#End If
'-----------
#If VBA7 Then
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
        ByRef lpPoint As PointAPI) As Long
#Else
Private Declare Function GetCursorPos Lib "user32.dll" ( _
        ByRef lpPoint As PointAPI) As Long
#End If
'************************************************************************************
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 mControlHwnd As Long
Private mbHook As Boolean
Private mCtl As MSForms.Control
Private mCtrl2 As MSForms.Control
'************************************************************************************
Sub HookControlScroll(ByVal Ctl As MSForms.Control, a As MSForms.Control)
    Dim lngAppInst As Long
    Dim hwndUnderCursor As Long
    Dim tPT As PointAPI
    GetCursorPos tPT
    hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
    If mControlHwnd <> hwndUnderCursor Then
        UnhookControlScroll
        Set mCtl = Ctl
        Set mCtrl2 = a
        mControlHwnd = hwndUnderCursor
        lngAppInst = GetWindowLong(mControlHwnd, 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 UnhookControlScroll()
    If mbHook Then
        Set mCtl = Nothing
        Set mCtrl2 = Nothing
        UnhookWindowsHookEx mLngMouseHook
        mLngMouseHook = 0
        mControlHwnd = 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 ErrorHandler
    
    Dim Index As Long
    If (nCode = HC_ACTION) Then
        If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mControlHwnd Then
            If wParam = WM_MOUSEWHEEL Then
                
                MouseProc = True
                
                If lParam.hWnd > 0 Then
                    Index = -1
                Else
                    Index = 1
                End If
                
                Index = Index + mCtl.TopIndex
                
                If Index >= 0 Then
                    mCtl.TopIndex = Index
                    mCtrl2.TopIndex = Index
                End If
                
                Exit Function
            End If
        Else
            UnhookControlScroll
        End If
    End If
    MouseProc = CallNextHookEx( _
    mLngMouseHook, nCode, wParam, ByVal lParam)
    Exit Function
ErrorHandler:
    UnhookControlScroll
End Function

 

[truongvu317]

Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub ListBox1_Click()
Dim i As Byte
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then
Me.ListBox2.Selected(i) = True
End If
Next
End Sub

Private Sub ListBox2_Click()
Dim i As Byte
For i = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(i) = True Then
Me.ListBox1.Selected(i) = True
End If
Next
End Sub
Private Sub UserForm_Terminate()
    UnhookControlScroll
End Sub
Private Sub ListBox1_mousemove(ByVal Button As Integer, _
                               ByVal Shift As Integer, _
                               ByVal X As Single, _
                               ByVal Y As Single)

    HookControlScroll ListBox1, ListBox2
End Sub
Private Sub ListBox2_mousemove(ByVal Button As Integer, _
                               ByVal Shift As Integer, _
                               ByVal X As Single, _
                               ByVal Y As Single)

    HookControlScroll ListBox2, ListBox1
End Sub

 

[ThaiDieuAnh]

Đồng bộ được, nhưng nó không mượt mà thôi

Vậy là quá ngon rồi, không cầu toàn được đâu bác ạ. Cảm ơn bác nhiều nhé!