Sử dụng con lăn chuột trong listbox UserForm (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
vu_tuan_manh_linh

vu_tuan_manh_linh

linhvtm84@gmail.com
Tham gia
27/2/10
Bài viết
2,637
Được thích
1,904
Giới tính
Nam
Nghề nghiệp
Kỹ sư Kinh tế Xây dựng
Tôi đang sử dụng code sưu tầm trên diễn đàn về việc sử dụng con lăn chuột trong listbox userform. Tuy nhiên code chỉ chạy trên office 32bit. Nếu dùng office bản 64 bit thì bị lỗi đoạn code sau:
PHP: 
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, _
'lỗi đúng chỗ này
'______________________
                             AddressOf MouseProc, _
'______________________
                             lngAppInst, 0)
            mbHook = mLngMouseHook <> 0
        End If
    End If
End Sub
Tôi đã cố gắng tìm giải pháp trên các trang khác (VD https://stackoverflow.com/questions...serform-form-does-not-scroll-with-mouse-wheel) nhưng được trả lời là code này không chạy trên bản office 64 bit. Kính nhờ các thành viên giải quyết giúp vấn đề này. Xin cảm ơn!!
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Sai đâu sửa đó . Trong hàm khai báo của SetWindowsHookEx chỗ tham số thứ 2 sửa lại kiểu Long thành LongPtr chơi.
 
Upvote 0
AutoReply đã viết:
Sai đâu sửa đó . Trong hàm khai báo của SetWindowsHookEx chỗ tham số thứ 2 sửa lại kiểu Long thành LongPtr chơi.
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn! Tôi cũng đang đọc 1 bài khác trong diễn đàn nói về vấn đề này! Do không có kiến thức sâu nên tôi không hiểu 2 cái: win32 và win64, office32 và office64. sử dụng câu lệnh #If VBA7 là xác định win64 hay office64. Máy tôi sử dụng win64 và office 32 thì ok, nhưng máy win64 và office 64 thì không dùng được. Mong bạn giải thích giúp!
 
Upvote 0
vu_tuan_manh_linh đã viết:
Cảm ơn bạn! Tôi cũng đang đọc 1 bài khác trong diễn đàn nói về vấn đề này! Do không có kiến thức sâu nên tôi không hiểu 2 cái: win32 và win64, office32 và office64. sử dụng câu lệnh #If VBA7 là xác định win64 hay office64. Mong bạn giải thích giúp!
Nhấp chuột vào đây để mở rộng...

Chịu thua, mình chỉ biết sửa cho hết lỗi thôi ạ. Các vấn đề khác mình không biết. :(
 
Upvote 0
ủa dựa vào yếu tố nào để kêu hpkhuong là anh, còn AutoReply là bạn nhỉ ? :confused:
 
Upvote 0
Sau một hồi loay hoay với #If VBA7, #If Win64, LongPtr thì cuối cùng cái lăn chuột nó cũng hoạt động, nhưng lăn chiều nào thì Scroll Bar nó cũng chỉ chạy có 1 chiều là đi từ dưới lên các bác ạ!
PHP: 
'************************************************************************************
#If VBA7 Then
    Private Type PointAPI
            x As LongPtr
            y As LongPtr
End Type
    Private Type MOUSEHOOKSTRUCT
            pt As PointAPI
            hwnd As LongPtr
            wHitTestCode As LongPtr
            dwExtraInfo As LongPtr
    End Type
#Else
   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
#End If


'************************************************************************************
#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" _
        Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr
#Else
    Private Declare Function FindWindow Lib "user32" _
        Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
#End If
'-------------
#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
            Alias "GetWindowLongPtrA" ( _
            ByVal hwnd As LongPtr, _
            ByVal nIndex As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
            Alias "GetWindowLongA" ( _
            ByVal hwnd As LongPtr, _
            ByVal nIndex As LongPtr) As LongPtr
    #End If
#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 LongPtr, _
        ByVal lpfn As LongPtr, _
        ByVal hMod As LongPtr, _
        ByVal dwThreadId As LongPtr) As LongPtr
#Else
    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
#End If
'-----------
#If VBA7 Then
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As LongPtr, _
        ByVal ncode As LongPtr, _
        ByVal wParam As LongPtr, _
        ByRef lParam As Any) As LongPtr
#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 LongPtr) As LongPtr
#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 LongPtr, _
        ByVal yPoint As LongPtr) As LongPtr
#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 LongPtr
#Else
    Private Declare Function GetCursorPos Lib "user32.dll" ( _
        ByRef lpPoint As PointAPI) As Long
#End If
'************************************************************************************
#If VBA7 Then
    Private Const WH_MOUSE_LL As LongPtr = 14
    Private Const WM_MOUSEWHEEL As LongPtr = &H20A
    Private Const HC_ACTION As LongPtr = 0
    Private Const GWL_HINSTANCE As LongPtr = (-6)
    '************************************************************************************
    Private mLngMouseHook As LongPtr
    Private mControlHwnd As LongPtr
#Else
    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
#End If
Private mbHook As Boolean
Private mCtl As MSForms.control

'************************************************************************************
Sub HookControlScroll(ByVal Ctl As MSForms.control)
#If VBA7 Then
    Dim lngAppInst As LongPtr
    Dim hwndUnderCursor As LongPtr
#Else
    Dim lngAppInst As Long
    Dim hwndUnderCursor As Long
#End If
    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
            #If VBA7 Then
                mLngMouseHook = _
                SetWindowsHookEx(WH_MOUSE_LL, _
                             AddressOf MouseProcVBA7, _
                             lngAppInst, 0)
            #Else
                mLngMouseHook = _
                SetWindowsHookEx(WH_MOUSE_LL, _
                             AddressOf MouseProc, _
                             lngAppInst, 0)
            #End If
            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
Private Function MouseProcVBA7( _
        ByVal ncode As LongPtr, _
        ByVal wParam As LongPtr, _
        ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
    On Error GoTo ErrorHandler
    Dim Index As LongPtr
    If (ncode = HC_ACTION) Then
        If WindowFromPoint(lParam.pt.x, lParam.pt.y) = mControlHwnd Then
            If wParam = WM_MOUSEWHEEL Then
                MouseProcVBA7 = 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
    MouseProcVBA7 = CallNextHookEx( _
    mLngMouseHook, ncode, wParam, ByVal lParam)
    Exit Function
ErrorHandler:
    UnhookControlScroll
End Function

Function Office32or64() As Long
Dim k As Long
Dim sPath As String
Dim aSubKeys(), vKey
Const cFind As String = "00FF1CE}"  ' note zeros and number 1
Const HKEY_LOCAL_MACHINE As Long = &H80000002
Dim objWMI As Object

    On Error GoTo errH
    Set objWMI = CreateObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")

    sPath = "Software\Microsoft\Windows\CurrentVersion\Uninstall"
    For k = 0 To 1
        objWMI.EnumKey HKEY_LOCAL_MACHINE, sPath, aSubKeys
        For Each vKey In aSubKeys
            If InStr(1, vKey, cFind) Then
                Select Case Mid$(vKey, 21, 1)
                Case "0": Office32or64 = 32
                Case "1": Office32or64 = 64
                End Select
                Debug.Print Mid$(vKey, 21, 1), vKey
                Exit Function
            End If
        Next
        ' this key will error in 32bit Windows
        sPath = "Software\WOW6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
    Next
    Exit Function
errH:

End Function
 
Upvote 0
vu_tuan_manh_linh đã viết:
Sau một hồi loay hoay với #If VBA7, #If Win64, LongPtr thì cuối cùng cái lăn chuột nó cũng hoạt động, nhưng lăn chiều nào thì Scroll Bar nó cũng chỉ chạy có 1 chiều là đi từ dưới lên các bác ạ!
PHP: 
'************************************************************************************
#If VBA7 Then
    Private Type PointAPI
            x As LongPtr
            y As LongPtr
End Type
    Private Type MOUSEHOOKSTRUCT
            pt As PointAPI
            hwnd As LongPtr
            wHitTestCode As LongPtr
            dwExtraInfo As LongPtr
    End Type
#Else
   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
#End If


'************************************************************************************
#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" _
        Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr
#Else
    Private Declare Function FindWindow Lib "user32" _
        Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
#End If
'-------------
#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
            Alias "GetWindowLongPtrA" ( _
            ByVal hwnd As LongPtr, _
            ByVal nIndex As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" _
            Alias "GetWindowLongA" ( _
            ByVal hwnd As LongPtr, _
            ByVal nIndex As LongPtr) As LongPtr
    #End If
#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 LongPtr, _
        ByVal lpfn As LongPtr, _
        ByVal hMod As LongPtr, _
        ByVal dwThreadId As LongPtr) As LongPtr
#Else
    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
#End If
'-----------
#If VBA7 Then
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As LongPtr, _
        ByVal ncode As LongPtr, _
        ByVal wParam As LongPtr, _
        ByRef lParam As Any) As LongPtr
#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 LongPtr) As LongPtr
#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 LongPtr, _
        ByVal yPoint As LongPtr) As LongPtr
#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 LongPtr
#Else
    Private Declare Function GetCursorPos Lib "user32.dll" ( _
        ByRef lpPoint As PointAPI) As Long
#End If
'************************************************************************************
#If VBA7 Then
    Private Const WH_MOUSE_LL As LongPtr = 14
    Private Const WM_MOUSEWHEEL As LongPtr = &H20A
    Private Const HC_ACTION As LongPtr = 0
    Private Const GWL_HINSTANCE As LongPtr = (-6)
    '************************************************************************************
    Private mLngMouseHook As LongPtr
    Private mControlHwnd As LongPtr
#Else
    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
#End If
Private mbHook As Boolean
Private mCtl As MSForms.control

'************************************************************************************
Sub HookControlScroll(ByVal Ctl As MSForms.control)
#If VBA7 Then
    Dim lngAppInst As LongPtr
    Dim hwndUnderCursor As LongPtr
#Else
    Dim lngAppInst As Long
    Dim hwndUnderCursor As Long
#End If
    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
            #If VBA7 Then
                mLngMouseHook = _
                SetWindowsHookEx(WH_MOUSE_LL, _
                             AddressOf MouseProcVBA7, _
                             lngAppInst, 0)
            #Else
                mLngMouseHook = _
                SetWindowsHookEx(WH_MOUSE_LL, _
                             AddressOf MouseProc, _
                             lngAppInst, 0)
            #End If
            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
Private Function MouseProcVBA7( _
        ByVal ncode As LongPtr, _
        ByVal wParam As LongPtr, _
        ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
    On Error GoTo ErrorHandler
    Dim Index As LongPtr
    If (ncode = HC_ACTION) Then
        If WindowFromPoint(lParam.pt.x, lParam.pt.y) = mControlHwnd Then
            If wParam = WM_MOUSEWHEEL Then
                MouseProcVBA7 = 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
    MouseProcVBA7 = CallNextHookEx( _
    mLngMouseHook, ncode, wParam, ByVal lParam)
    Exit Function
ErrorHandler:
    UnhookControlScroll
End Function

Function Office32or64() As Long
Dim k As Long
Dim sPath As String
Dim aSubKeys(), vKey
Const cFind As String = "00FF1CE}"  ' note zeros and number 1
Const HKEY_LOCAL_MACHINE As Long = &H80000002
Dim objWMI As Object

    On Error GoTo errH
    Set objWMI = CreateObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")

    sPath = "Software\Microsoft\Windows\CurrentVersion\Uninstall"
    For k = 0 To 1
        objWMI.EnumKey HKEY_LOCAL_MACHINE, sPath, aSubKeys
        For Each vKey In aSubKeys
            If InStr(1, vKey, cFind) Then
                Select Case Mid$(vKey, 21, 1)
                Case "0": Office32or64 = 32
                Case "1": Office32or64 = 64
                End Select
                Debug.Print Mid$(vKey, 21, 1), vKey
                Exit Function
            End If
        Next
        ' this key will error in 32bit Windows
        sPath = "Software\WOW6432Node\Microsoft\Windows\CurrentVersion\Uninstall"
    Next
    Exit Function
errH:

End Function
Nhấp chuột vào đây để mở rộng...
Anh Linh đã xử lý được vụ này chưa ạ, em cũng dính cái này,. nếu được mong anh chia sẻ, cảm ơn
 
Upvote 0
vu_tuan_manh_linh đã viết:
Cảm ơn bạn! Tôi cũng đang đọc 1 bài khác trong diễn đàn nói về vấn đề này! Do không có kiến thức sâu nên tôi không hiểu 2 cái: win32 và win64, office32 và office64. sử dụng câu lệnh #If VBA7 là xác định win64 hay office64. Máy tôi sử dụng win64 và office 32 thì ok, nhưng máy win64 và office 64 thì không dùng được. Mong bạn giải thích giúp!
Nhấp chuột vào đây để mở rộng...
Có lẽ là cái này chăng: Tính tương thích ngược office 32 và 64
 
Upvote 0
vu_tuan_manh_linh đã viết:
Tôi đang sử dụng code sưu tầm trên diễn đàn về việc sử dụng con lăn chuột trong listbox userform. Tuy nhiên code chỉ chạy trên office 32bit. Nếu dùng office bản 64 bit thì bị lỗi đoạn code sau:
PHP: 
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, _
'lỗi đúng chỗ này
'______________________
                             AddressOf MouseProc, _
'______________________
                             lngAppInst, 0)
            mbHook = mLngMouseHook <> 0
        End If
    End If
End Sub
Tôi đã cố gắng tìm giải pháp trên các trang khác (VD https://stackoverflow.com/questions...serform-form-does-not-scroll-with-mouse-wheel) nhưng được trả lời là code này không chạy trên bản office 64 bit. Kính nhờ các thành viên giải quyết giúp vấn đề này. Xin cảm ơn!!
Nhấp chuột vào đây để mở rộng...
Trên Social MSND của microsoft cũng đang bàn tán xôn xao. Thấy có kết quả nên tôi copy code về đây luôn
Nguồn: Link
PHP: 
(in the module)


Option Explicit

#If Win64 Then
    Private Type POINTAPI
       XY As LongLong
    End Type
#Else
    Private Type POINTAPI
           X As Long
           Y As Long
    End Type
#End If

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 LongPtr
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
                                            Alias "GetWindowLongPtrA" ( _
                                                            ByVal hWnd As LongPtr, _
                                                            ByVal nIndex As Long) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" _
                                            Alias "GetWindowLongA" ( _
                                                            ByVal hWnd As LongPtr, _
                                                            ByVal nIndex As Long) As LongPtr
    #End If
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
                                            Alias "SetWindowsHookExA" ( _
                                                            ByVal idHook As Long, _
                                                            ByVal lpfn As LongPtr, _
                                                            ByVal hmod As LongPtr, _
                                                            ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
                                                            ByVal hHook As LongPtr, _
                                                            ByVal nCode As Long, _
                                                            ByVal wParam As LongPtr, _
                                                           lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
                                                            ByVal hHook As LongPtr) As Long
    'Private Declare PtrSafe Function PostMessage Lib "user32.dll" _
    '                                         Alias "PostMessageA" ( _
    '                                                         ByVal hwnd As LongPtr, _
    '                                                         ByVal wMsg As Long, _
    '                                                         ByVal wParam As LongPtr, _
    '                                                         ByVal lParam As LongPtr) As Long
    #If Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                            ByVal Point As LongLong) As LongPtr
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                            ByVal xPoint As Long, _
                                                            ByVal yPoint As Long) As LongPtr
    #End If
    Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
                                                            ByRef lpPoint As POINTAPI) As Long
#Else
    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
#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 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
Dim n As Long
Private mCtl As Object
Private mbHook As Boolean
#If VBA7 Then
    Private mLngMouseHook As LongPtr
    Private mListBoxHwnd As LongPtr
#Else
    Private mLngMouseHook As Long
    Private mListBoxHwnd As Long
#End If

Sub HookListBoxScroll(frm As Object, ctl As Object)
    Dim tPT As POINTAPI
    #If VBA7 Then
        Dim lngAppInst As LongPtr
        Dim hwndUnderCursor As LongPtr
    #Else
        Dim lngAppInst As Long
        Dim hwndUnderCursor As Long
    #End If
    GetCursorPos tPT
    #If Win64 Then
        hwndUnderCursor = WindowFromPoint(tPT.XY)
    #Else
        hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
    #End If
  ' Đoạn này không cần thiết ---------------------------------------------------------
    If TypeOf ctl Is UserForm Then
        If Not frm Is ctl Then
               ctl.SetFocus
        End If
    Else
        If Not frm.ActiveControl Is ctl Then
             ctl.SetFocus
        End If
    End If
   '---------------------------------------------------------------------------------------
    If mListBoxHwnd <> hwndUnderCursor Then
        UnhookListBoxScroll
        Set mCtl = ctl
        mListBoxHwnd = hwndUnderCursor
        #If Win64 Then
            lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
        #Else
            lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
        #End If
        ' 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
        Set mCtl = Nothing
        UnhookWindowsHookEx mLngMouseHook
        mLngMouseHook = 0
        mListBoxHwnd = 0
        mbHook = False
    End If
End Sub

#If VBA7 Then
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
#Else
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
#End If
        Dim idx As Long
        On Error GoTo errH
        If (nCode = HC_ACTION) Then
            #If Win64 Then
                If WindowFromPoint(lParam.Pt.XY) = 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
                        If TypeOf mCtl Is Frame Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        ElseIf TypeOf mCtl Is UserForm Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 Then mCtl.ListIndex = idx
                        End If
                    Exit Function
                    End If
                Else
                    UnhookListBoxScroll
                End If
            #Else
                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
                        If TypeOf mCtl Is Frame Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        ElseIf TypeOf mCtl Is UserForm Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 Then mCtl.ListIndex = idx
                        End If
                        Exit Function
                    End If
                Else
                    UnhookListBoxScroll
                End If
            #End If
        End If
        MouseProc = CallNextHookEx(mLngMouseHook, nCode, wParam, ByVal lParam)
        Exit Function
errH:
        UnhookListBoxScroll
End Function

(in the Form)


Private Sub cmbbData_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.cmbbData
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
Dim s As String
        s = "this is line "
        For i = 1 To 50
                        Me.cmbbData.AddItem s & i

        Next
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        UnhookListBoxScroll
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
minahnh0011 đã viết:
Trên Social MSMD của microsoft cũng đang bàn tán xôn xao. Thấy có kết quả nên tôi copy code về đây luôn
Nguồn: Link
Mã: 
(in the module)


Option Explicit

#If Win64 Then
    Private Type POINTAPI
       XY As LongLong
    End Type
#Else
    Private Type POINTAPI
           X As Long
           Y As Long
    End Type
#End If

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 LongPtr
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
                                            Alias "GetWindowLongPtrA" ( _
                                                            ByVal hWnd As LongPtr, _
                                                            ByVal nIndex As Long) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" _
                                            Alias "GetWindowLongA" ( _
                                                            ByVal hWnd As LongPtr, _
                                                            ByVal nIndex As Long) As LongPtr
    #End If
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
                                            Alias "SetWindowsHookExA" ( _
                                                            ByVal idHook As Long, _
                                                            ByVal lpfn As LongPtr, _
                                                            ByVal hmod As LongPtr, _
                                                            ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
                                                            ByVal hHook As LongPtr, _
                                                            ByVal nCode As Long, _
                                                            ByVal wParam As LongPtr, _
                                                           lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
                                                            ByVal hHook As LongPtr) As Long
    'Private Declare PtrSafe Function PostMessage Lib "user32.dll" _
    '                                         Alias "PostMessageA" ( _
    '                                                         ByVal hwnd As LongPtr, _
    '                                                         ByVal wMsg As Long, _
    '                                                         ByVal wParam As LongPtr, _
    '                                                         ByVal lParam As LongPtr) As Long
    #If Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                            ByVal Point As LongLong) As LongPtr
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                            ByVal xPoint As Long, _
                                                            ByVal yPoint As Long) As LongPtr
    #End If
    Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
                                                            ByRef lpPoint As POINTAPI) As Long
#Else
    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
#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 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
Dim n As Long
Private mCtl As Object
Private mbHook As Boolean
#If VBA7 Then
    Private mLngMouseHook As LongPtr
    Private mListBoxHwnd As LongPtr
#Else
    Private mLngMouseHook As Long
    Private mListBoxHwnd As Long
#End If

Sub HookListBoxScroll(frm As Object, ctl As Object)
    Dim tPT As POINTAPI
    #If VBA7 Then
        Dim lngAppInst As LongPtr
        Dim hwndUnderCursor As LongPtr
    #Else
        Dim lngAppInst As Long
        Dim hwndUnderCursor As Long
    #End If
    GetCursorPos tPT
    #If Win64 Then
        hwndUnderCursor = WindowFromPoint(tPT.XY)
    #Else
        hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
    #End If
    If TypeOf ctl Is UserForm Then
        If Not frm Is ctl Then
               ctl.SetFocus
        End If
    Else
        If Not frm.ActiveControl Is ctl Then
             ctl.SetFocus
        End If
    End If
    If mListBoxHwnd <> hwndUnderCursor Then
        UnhookListBoxScroll
        Set mCtl = ctl
        mListBoxHwnd = hwndUnderCursor
        #If Win64 Then
            lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
        #Else
            lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
        #End If
        ' 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
        Set mCtl = Nothing
        UnhookWindowsHookEx mLngMouseHook
        mLngMouseHook = 0
        mListBoxHwnd = 0
        mbHook = False
    End If
End Sub

#If VBA7 Then
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
#Else
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
#End If
        Dim idx As Long
        On Error GoTo errH
        If (nCode = HC_ACTION) Then
            #If Win64 Then
                If WindowFromPoint(lParam.Pt.XY) = 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
                        If TypeOf mCtl Is Frame Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        ElseIf TypeOf mCtl Is UserForm Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 Then mCtl.ListIndex = idx
                        End If
                    Exit Function
                    End If
                Else
                    UnhookListBoxScroll
                End If
            #Else
                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
                        If TypeOf mCtl Is Frame Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        ElseIf TypeOf mCtl Is UserForm Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 Then mCtl.ListIndex = idx
                        End If
                        Exit Function
                    End If
                Else
                    UnhookListBoxScroll
                End If
            #End If
        End If
        MouseProc = CallNextHookEx(mLngMouseHook, nCode, wParam, ByVal lParam)
        Exit Function
errH:
        UnhookListBoxScroll
End Function

(in the Form)


Private Sub cmbbData_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.cmbbData
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
Dim s As String
        s = "this is line "
        For i = 1 To 50
                        Me.cmbbData.AddItem s & i

        Next
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        UnhookListBoxScroll
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác, để em test thử rồi báo lại nhé
 
Upvote 0
minahnh0011 đã viết:
Trên Social MSMD của microsoft cũng đang bàn tán xôn xao. Thấy có kết quả nên tôi copy code về đây luôn
Nguồn: Link
Mã: 
(in the module)


Option Explicit

#If Win64 Then
    Private Type POINTAPI
       XY As LongLong
    End Type
#Else
    Private Type POINTAPI
           X As Long
           Y As Long
    End Type
#End If

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 LongPtr
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
                                            Alias "GetWindowLongPtrA" ( _
                                                            ByVal hWnd As LongPtr, _
                                                            ByVal nIndex As Long) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" _
                                            Alias "GetWindowLongA" ( _
                                                            ByVal hWnd As LongPtr, _
                                                            ByVal nIndex As Long) As LongPtr
    #End If
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
                                            Alias "SetWindowsHookExA" ( _
                                                            ByVal idHook As Long, _
                                                            ByVal lpfn As LongPtr, _
                                                            ByVal hmod As LongPtr, _
                                                            ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
                                                            ByVal hHook As LongPtr, _
                                                            ByVal nCode As Long, _
                                                            ByVal wParam As LongPtr, _
                                                           lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
                                                            ByVal hHook As LongPtr) As Long
    'Private Declare PtrSafe Function PostMessage Lib "user32.dll" _
    '                                         Alias "PostMessageA" ( _
    '                                                         ByVal hwnd As LongPtr, _
    '                                                         ByVal wMsg As Long, _
    '                                                         ByVal wParam As LongPtr, _
    '                                                         ByVal lParam As LongPtr) As Long
    #If Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                            ByVal Point As LongLong) As LongPtr
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                            ByVal xPoint As Long, _
                                                            ByVal yPoint As Long) As LongPtr
    #End If
    Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
                                                            ByRef lpPoint As POINTAPI) As Long
#Else
    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
#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 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
Dim n As Long
Private mCtl As Object
Private mbHook As Boolean
#If VBA7 Then
    Private mLngMouseHook As LongPtr
    Private mListBoxHwnd As LongPtr
#Else
    Private mLngMouseHook As Long
    Private mListBoxHwnd As Long
#End If

Sub HookListBoxScroll(frm As Object, ctl As Object)
    Dim tPT As POINTAPI
    #If VBA7 Then
        Dim lngAppInst As LongPtr
        Dim hwndUnderCursor As LongPtr
    #Else
        Dim lngAppInst As Long
        Dim hwndUnderCursor As Long
    #End If
    GetCursorPos tPT
    #If Win64 Then
        hwndUnderCursor = WindowFromPoint(tPT.XY)
    #Else
        hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
    #End If
    If TypeOf ctl Is UserForm Then
        If Not frm Is ctl Then
               ctl.SetFocus
        End If
    Else
        If Not frm.ActiveControl Is ctl Then
             ctl.SetFocus
        End If
    End If
    If mListBoxHwnd <> hwndUnderCursor Then
        UnhookListBoxScroll
        Set mCtl = ctl
        mListBoxHwnd = hwndUnderCursor
        #If Win64 Then
            lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
        #Else
            lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
        #End If
        ' 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
        Set mCtl = Nothing
        UnhookWindowsHookEx mLngMouseHook
        mLngMouseHook = 0
        mListBoxHwnd = 0
        mbHook = False
    End If
End Sub

#If VBA7 Then
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
#Else
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
#End If
        Dim idx As Long
        On Error GoTo errH
        If (nCode = HC_ACTION) Then
            #If Win64 Then
                If WindowFromPoint(lParam.Pt.XY) = 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
                        If TypeOf mCtl Is Frame Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        ElseIf TypeOf mCtl Is UserForm Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 Then mCtl.ListIndex = idx
                        End If
                    Exit Function
                    End If
                Else
                    UnhookListBoxScroll
                End If
            #Else
                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
                        If TypeOf mCtl Is Frame Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        ElseIf TypeOf mCtl Is UserForm Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        Else
                            If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                            idx = idx + mCtl.ListIndex
                            If idx >= 0 Then mCtl.ListIndex = idx
                        End If
                        Exit Function
                    End If
                Else
                    UnhookListBoxScroll
                End If
            #End If
        End If
        MouseProc = CallNextHookEx(mLngMouseHook, nCode, wParam, ByVal lParam)
        Exit Function
errH:
        UnhookListBoxScroll
End Function

(in the Form)


Private Sub cmbbData_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.cmbbData
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
Dim s As String
        s = "this is line "
        For i = 1 To 50
                        Me.cmbbData.AddItem s & i

        Next
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        UnhookListBoxScroll
End Sub
Nhấp chuột vào đây để mở rộng...
Em không hiểu sao phải bỏ đoạn code này mới chạy được (em đang test trên 64 bit):
Mã: 
Private Sub UserForm_Initialize()
Dim i As Long
Dim s As String
        s = "this is line "
        For i = 1 To 50
                        Me.cmbbData.AddItem s & i

        Next
End Sub
 
Upvote 0
Thái Phúc đã viết:
Em không hiểu sao phải bỏ đoạn code này mới chạy được (em đang test trên 64 bit):
Mã: 
Private Sub UserForm_Initialize()
Dim i As Long
Dim s As String
        s = "this is line "
        For i = 1 To 50
                        Me.cmbbData.AddItem s & i

        Next
End Sub
Nhấp chuột vào đây để mở rộng...
Cái này là thêm Item bằng vòng lặp. Nếu bạn đã có một NameRange, Array thì bỏ vào
Me - nghĩa là Chính tôi, nếu Form tên gì thì Me đại diện Form đấy
cmbbData - đại diện cho ListBox / ComboBox / TextBox ...
Ví dụ: Me.cmbbData.List = Array(1,2,3,4,5)
FormName.cmbbData.List = Array(1,2,3,4,5)
 
Lần chỉnh sửa cuối:
Upvote 0
Upvote 0
Đào lại bài cách đây 4 năm: một lỗi gặp phải với code scroll mouse listbox khi dùng office 2016 là hay bị đơ, out luôn excel, đành phải gỡ ra dùng 2010. Liệu có phải do ảnh hưởng của hiệu ứng chuyển tiếp cells của phiên bản 2016 không cả nhà???
 
Upvote 0
vu_tuan_manh_linh đã viết:
Đào lại bài cách đây 4 năm: một lỗi gặp phải với code scroll mouse listbox khi dùng office 2016 là hay bị đơ, out luôn excel, đành phải gỡ ra dùng 2010. Liệu có phải do ảnh hưởng của hiệu ứng chuyển tiếp cells của phiên bản 2016 không cả nhà???
Nhấp chuột vào đây để mở rộng...
Việc này hình như anh Tuân xử lý xong lâu rồi.
Hiện đã tải lại theo bài, với Office 2016-64bits, Win10-64bits, chuột chứ không phải touchpad thì vẫn ổn, không lỗi lầm gì cả.
www.giaiphapexcel.com

Scroll Wheel cho ListBox & ComboBox.

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...
www.giaiphapexcel.com www.giaiphapexcel.com
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

L
Làm thế nào in ra tận mép khổ giấy (1 người xem)
Trả lời
18
Đọc
113K
tuananhzj11
tuananhzj11
N
Tạo COM Add-In bằng Visual C++ (1 người xem)
Trả lời
2
Đọc
220
nguyendang95
N
nguyenhoangtuananh9897
Hỏi về nơi tải danh sách xã huyện tỉnh chuẩn
2 3
Trả lời
51
Đọc
3K
ongke0711
ongke0711
Phan Thế Hiệp
Tìm ngày giờ kết thúc dự kiến
    • Thích
    • Yêu thích
2
Trả lời
26
Đọc
1K
Phan Thế Hiệp
Phan Thế Hiệp
1050167
Nhờ tính điểm bình quân môn học theo lớp bằng VBA (2 người xem)
Trả lời
5
Đọc
129
Duy Tùng 9x
Duy Tùng 9x
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (5 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
17 18 19
Trả lời
373
Đọc
42K
haia27
H
Nguyễn Duy Tuân
  • Dán lên cao
Phiên bản mới Add-in A-Tools AI v10 (2024)
    • Thích
2 3
Trả lời
58
Đọc
8K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
Maika8008
Tặng file quản lý vật tư - công nợ (nhập xuất kho hàng và công nợ khách hàng) (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
117
Đọc
28K
Linhtrantxtn
Linhtrantxtn
GPE-Trợ Lý
[ĐÀ NẴNG] ĐĂNG KÝ THAM DỰ SINH NHẬT GIAIPHAPEXCEL LẦN THỨ 19 NGÀY 13/07/2025
    • Thích
Trả lời
7
Đọc
522
PhanTuHuong
PhanTuHuong
K
xin file excel bảng đấu bóng đá (1 người xem)
    • Yêu thích
2 3
Trả lời
42
Đọc
26K
Hoàng Tuấn 868
H
B
Xin cách để hiển thị ra các tiêu đề tương ứng của nội dung trong bảng, 1 tiêu đề có nhiều nội dung
Trả lời
7
Đọc
176
Duy Tùng 9x
Duy Tùng 9x
N
xin các cao thủ chỉ cách gỡ lỗi không khởi động được excel
Trả lời
5
Đọc
683
ELDEST 11
ELDEST 11
Q
  • Question Question
Chèn dòng "--------" và giá trị min, max cho WBS cha, con
Trả lời
0
Đọc
63
quangnn0387
Q
V
Tiện ích in sơ đồ đánh số báo danh cho kỳ thi tuyển sinh vào 10 và tốt nghiệp THPT
Trả lời
0
Đọc
70
vtkmoduc1000
V
P
Xử lý lỗi bị đẩy về sheet đầu trong excel
Trả lời
2
Đọc
404
Hoàng Tuấn 868
H
T
Nhờ hỗ trợ chỉnh phiếu xuất tự động
Trả lời
6
Đọc
175
trungtruong1234
T
Nga1852k
lỗi excel không chèn được dòng và không xóa được dòng
Trả lời
1
Đọc
83
vietduc147258
V
OrangeBee
Xin nhờ anh chị giúp đỡ về CommandButton Userform.
Trả lời
3
Đọc
143
ptm0412
ptm0412
ptm0412
Hình ảnh sinh nhật GPE lần 19 tại HCM (1 người xem)
    • Thích
    • Yêu thích
Trả lời
0
Đọc
105
ptm0412
ptm0412
K
  • Question Question
Viết code cho file lấy dữ liệu in -out từ bảng chấm công
Trả lời
1
Đọc
150
yaaasoo01
Y
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Sinh nhật lần 19 GPE

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom