- Tham gia
- 17/8/08
- Bài viết
- 8,662
- Được thích
- 16,720
- Giới tính
- Nam
Từ nhiều nguồn code sưu tầm được cả trên diễn đàn ta lẫn các diễn đàn khác, thì mỗi một thủ tục sẽ cho ra một kết quả nhất định, song, chúng không lỗi vấn đề này thì lỗi ở vấn đề khác.
Chẳng hạn, có code thì cuộn trên ListBox nhưng khi mở một ứng dụng khác như NotePad thì vô hiệu hóa thanh cuộn của NotePad, nhưng ListBox vẫn hoạt động.
Chẳng hạn, một thủ tục không bị lỗi trên, nhưng nếu vô tình code bất kỳ nào đó trên form bị lỗi, thì cả Excel sẽ bị treo mà không thể nào Break được, buộc phải Alt+Ctrl+Delete để giải phóng Excel.
Chẳng hạn, một thủ tục cuộn các Item trong ListBox, đồng thời lại Select các Item này. Đây là một điều tối kỵ khi ListBox có sử dụng các sự kiện Change hoặc Click, mỗi lần cuộn, mỗi lần tạo ra sự kiện thì hoàn toàn chẳng tốt lành gì mà cứ hao tốn bộ nhớ cho việc tính toán khi chạy sự kiện Change/ Click.
Từ đó, tôi kết hợp, nghiên cứu các thủ tục lại với nhau, chỉnh sửa, cải tiến, xử lý để có một file mà tôi cho là tránh được tất cả 3 trường hợp trên như sau:
Tạo một file Excel có chứa một UserForm1, 1 ComboBox1 & 1 ListBox1 trong Form đó.
Code chính trong Module:
[GPECODE=vb]
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, _
ByRef 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 mControlHwnd As Long
Private mbHook As Boolean
Private mCtl As MSForms.Control
'************************************************************************************
Sub HookControlScroll(ByVal 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 mControlHwnd <> hwndUnderCursor Then
UnhookControlScroll
Set mCtl = ctl
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
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
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
[/GPECODE]
Và thủ tục trong UserForm:
[GPECODE=vb]
Option Explicit
'************************************************************************************
Private Sub UserForm_Initialize()
Dim b As Byte
Dim s As String
s = "Trong Nghia "
For b = 1 To 50
ComboBox1.AddItem s & b
ListBox1.AddItem s & b
Next
End Sub
Private Sub UserForm_Terminate()
UnhookControlScroll
End Sub
'************************************************************************************
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
HookControlScroll ComboBox1
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
HookControlScroll ListBox1
End Sub
[/GPECODE]
Lưu ý, tôi có thêm 1 nút lệnh trên form nhằm kiểm tra nếu lỗi thì Excel có bị treo hay không. Code của nút lệnh này:
Các bạn tải về trải nghiệm và test thử nếu có lỗi gì thì cho mình biết nhé!
Hoàng Trọng Nghĩa
''=====================================
Đã update phiên bản 2, chạy luôn trên ComboBox trên sheet (LbxAndCbxScroll.V2.xls).
Thử với phiên bản 64bit, ai có máy loại này test thử xem có lỗi gì không (mình không có nên không test được). Thanks.
Chẳng hạn, có code thì cuộn trên ListBox nhưng khi mở một ứng dụng khác như NotePad thì vô hiệu hóa thanh cuộn của NotePad, nhưng ListBox vẫn hoạt động.
Chẳng hạn, một thủ tục không bị lỗi trên, nhưng nếu vô tình code bất kỳ nào đó trên form bị lỗi, thì cả Excel sẽ bị treo mà không thể nào Break được, buộc phải Alt+Ctrl+Delete để giải phóng Excel.
Chẳng hạn, một thủ tục cuộn các Item trong ListBox, đồng thời lại Select các Item này. Đây là một điều tối kỵ khi ListBox có sử dụng các sự kiện Change hoặc Click, mỗi lần cuộn, mỗi lần tạo ra sự kiện thì hoàn toàn chẳng tốt lành gì mà cứ hao tốn bộ nhớ cho việc tính toán khi chạy sự kiện Change/ Click.
Từ đó, tôi kết hợp, nghiên cứu các thủ tục lại với nhau, chỉnh sửa, cải tiến, xử lý để có một file mà tôi cho là tránh được tất cả 3 trường hợp trên như sau:
Tạo một file Excel có chứa một UserForm1, 1 ComboBox1 & 1 ListBox1 trong Form đó.
Code chính trong Module:
[GPECODE=vb]
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, _
ByRef 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 mControlHwnd As Long
Private mbHook As Boolean
Private mCtl As MSForms.Control
'************************************************************************************
Sub HookControlScroll(ByVal 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 mControlHwnd <> hwndUnderCursor Then
UnhookControlScroll
Set mCtl = ctl
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
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
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
[/GPECODE]
Và thủ tục trong UserForm:
[GPECODE=vb]
Option Explicit
'************************************************************************************
Private Sub UserForm_Initialize()
Dim b As Byte
Dim s As String
s = "Trong Nghia "
For b = 1 To 50
ComboBox1.AddItem s & b
ListBox1.AddItem s & b
Next
End Sub
Private Sub UserForm_Terminate()
UnhookControlScroll
End Sub
'************************************************************************************
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
HookControlScroll ComboBox1
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
HookControlScroll ListBox1
End Sub
[/GPECODE]
Lưu ý, tôi có thêm 1 nút lệnh trên form nhằm kiểm tra nếu lỗi thì Excel có bị treo hay không. Code của nút lệnh này:
Mã:
Private Sub CommandButton1_Click()
''Thu loi de xem co bi treo Excel
''hay khong, cac phien ban truoc
''thuong bi treo khi gap loi.
[COLOR=#ff0000][B] MsgBox 4 / 0[/B][/COLOR]
End SubCác bạn tải về trải nghiệm và test thử nếu có lỗi gì thì cho mình biết nhé!
Hoàng Trọng Nghĩa
''=====================================
Đã update phiên bản 2, chạy luôn trên ComboBox trên sheet (LbxAndCbxScroll.V2.xls).
Thử với phiên bản 64bit, ai có máy loại này test thử xem có lỗi gì không (mình không có nên không test được). Thanks.
Lần chỉnh sửa cuối:
thực ra đoạn code này mình không hiểu lắm, nên cứ copy đại để dùng, có điều là khi gặp vấn đề thì mình phản hồi lại kèm luôn điều kiện dùng của mình để người đọc đỡ phải hỏi lại thôi.
