2017年3月30日木曜日

ListBoxがマウスのスクロール対応していない?!

やってみたら本当だ。
幸いソリューションは既にありました。ありがとうございます。
参照: https://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
Private Sub ListBox1_MouseMove( _
             ByVal Button As Integer, ByVal Shift As Integer, _
             ByVal x As Single, ByVal y As Single)
' start tthe hook
     HookListBoxScroll
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     UnhookListBoxScroll
End Sub
''''''' end Userform code

''''''' normal module code
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 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 'Resume Next
        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

0 件のコメント:

コメントを投稿