[[20141022104627]]　『コンボボックスをマウスホイールで上下させたい』（たまやん）　ページの最後に飛ぶ

『コンボボックスをマウスホイールで上下させたい』（たまやん）

 こんにちは。
 VBAの件で質問お願い致します。

 コンボボックスのデータを見るときにマウスホイールで移動させるには
 どのような設定、またはコードを書けばいいのでしょうか？

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 標準機能では出来ないので、外部機能を利用することになるかと思います。

 下記は Access の記事ですが、基本的には同じ考え方になるでしょうか。
http://www.f3.dion.ne.jp/~element/msaccess/AcTipsFrmMouseWheelEvent.html

 下記の「VBA、VB6 で、マウスホイールによるスクロールを可能にする方法、ソフト」
 あたりも見てみてください。
https://ittechinf.wiki.zoho.com/VBA.html
（Mook） 2014/10/22(水) 11:09

 Mookさん

 ありがとうございますm(__)m
 なかなか難しそうですが、チャレンジしてみます。
（たまやん） 2014/10/22(水) 11:15

 横から失礼します。

 コンボボックスのデータを見ることが目的でしたら、
 クリックイベントで新しいフォームを立ち上げて、リストボックスコントロールに表示させる
 などはいかがでしょう？

 マウスホイールの読んでみたけど、私には出来そうにないなぁ・・・。
（稲葉） 2014/10/22(水) 12:53

 以前、Access でやってみたことがありましたが、1日がかりでした。
 結構コードも書いた気がするので、ある程度 VB やイベントの理解がないと
 大変かもしれません。

 稲葉さんだったら、やる気になれば出来ると思いますけれど。
（Mook） 2014/10/22(水) 13:01

 有り難いお言葉ですが、買いかぶりすぎです！
 精々提供されたDLLに繋いでイベントを拾ったとしても、
 コンボボックスをクリックしたときに出てくるスクロールバーがついた一覧のコントロールに
 プロパティがあるのかすら調べられませんでした・・・

 なのでやっぱり簡単な方法があるならそちらを選んでしまいますねぇ・・・。

（稲葉） 2014/10/22(水) 14:32

 色々調べてみて、それらしいことは出来ましたので、参考までに・・・
 4. マウスの低レベルフック(グローバルフック)
http://veaba.keemoosoft.com/2013/11/728/
 こちらのコードをそのまま使用させていただきました。

 １）ユーザーフォームを作成し、名前をUserForm1にします。
 ２）ユーザーフォームにコンボボックスを作成し、名前をComboBox1にします。
 ３）クラスモジュールを作成し、名前をMouseEventHookとします。
 ４）標準モジュールを作成し、名前は作られたときのままでＯＫです。
 ５）ユーザーフォームに以下のコードを貼り付けてください。
    Option Explicit
    Public M_Over As String
    Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        M_Over = "CB1"
    End Sub
    Private Sub UserForm_Initialize()
        ComboBox1.RowSource = "A1:A100"
        Call MouseEventHook.Start
    End Sub
    Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        M_Over = ""
    End Sub
    Private Sub UserForm_Terminate()
        MouseEventHook.Terminate
    End Sub

 ６）クラスモジュールに以下のコードを貼り付けてください
    Option Explicit

    Private Declare Function SetWindowsHookEx Lib _
    "User32.dll" Alias "SetWindowsHookExA" _
    (ByVal idHook As Long, ByVal lpfn As Long, _
    ByVal hMod As Long, ByVal dwThreadId As Long) As Long
    Private Const WH_MOUSE_LL As Long = 14

    Private Declare Function UnhookWindowsHookEx Lib _
    "User32.dll" (ByVal hhk As Long) As Long

    Private Declare Function CallNextHookEx Lib _
    "User32.dll" (ByVal hhk As Long, ByVal nCode As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long

    Private Declare Function GetWindowLong Lib _
    "User32.dll" Alias "GetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Const GWL_HINSTANCE As Long = -6

    Private Declare Sub CopyMemory Lib _
    "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)

    Private Type Point
        X As Long
        Y As Long
    End Type
    Private Type MouseLLHookStruct
        Point As Point
        mouseData As Long
        flags As Long
        time As Long
        dwExtraInfo As Long
    End Type

    Private pv_IsRunning As Boolean
    Private pv_WindowHandle As Long
    Private pv_MouseHookHandle As Long

    Public Sub Start()
        If pv_IsRunning = False Then
            pv_WindowHandle = Application.hWnd
            pv_MouseHookHandle = SetWindowsHookEx(WH_MOUSE_LL, _
                  AddressOf MouseEventHookHandler, _
                        GetWindowLong(pv_WindowHandle, GWL_HINSTANCE), 0)
            If pv_MouseHookHandle = 0 Then
                Debug.Print ("マウスメッセージフックのインストールが失敗しました。")
            Else
                Debug.Print ("マウスメッセージフックのインストールが成功しました。")
                pv_IsRunning = True
            End If
        End If
    End Sub

    Public Function MouseLLHookProc(ByVal nCode As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim m_Return As Long
        Dim m_MouseLLHookStruct As MouseLLHookStruct

        On Error GoTo ErrorHandler
        Select Case wParam
    '        Case 512 '[MouseMove]
    '            CopyMemory m_MouseLLHookStruct.Point.X, ByVal lParam, LenB(m_MouseLLHookStruct)
    '            With m_MouseLLHookStruct
    '                Debug.Print "MouseMove(x=" & .Point.X & ",y=" & .Point.Y & ")"
    '            End With
    '        Case 513: Debug.Print "LeftDown"
    '        Case 514: Debug.Print "LeftUp"
    '        Case 516: Debug.Print "RightDown"
    '        Case 517: Debug.Print "RightUp"
    '        Case 519: Debug.Print "MidDown"
    '        Case 520: Debug.Print "MidUp"
            Case 522: '[MouseWheel]
                CopyMemory m_MouseLLHookStruct.Point.X, ByVal lParam, LenB(m_MouseLLHookStruct)
                With m_MouseLLHookStruct
                    Select Case .mouseData
                        Case Is > 0: SendKeys "{UP}", True
                        Case Is < 0: SendKeys "{DOWN}", True
                    End Select
                    'Debug.Print "MouseWheel(" & .mouseData & ")"
                End With
        End Select

ErrorHandler:

        m_Return = CallNextHookEx(pv_MouseHookHandle, nCode, wParam, lParam)

        MouseLLHookProc = m_Return
    End Function

    Public Sub Terminate()
        If pv_IsRunning Then
            Call UnhookWindowsHookEx(pv_MouseHookHandle)
            Debug.Print ("マウスメッセージフックのアンインストールが完了しました。")
            pv_IsRunning = False
        End If
    End Sub

 ７）標準モジュールに以下のコードを貼り付けてください。
    Option Explicit
    Public MouseEventHook As New MouseEventHook
    Public Function MouseEventHookHandler(ByVal uMsg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long
        On Error GoTo ErrorHandler
        If UserForm1.M_Over = "CB1" Then
            Call MouseEventHook.MouseLLHookProc(uMsg, wParam, lParam)
        End If
    ErrorHandler:
    End Function

 結局SendKeysに逃げています・・・
 コンボボックスのスクロールはどうすればいいんですか・・・
 マウスオーバーもなく、マウスムーブだし、VBAだけだと難しいんですねぇ。
（稲葉） 2014/10/22(水) 15:59

コメント返信：

[ 一覧(最新更新順) ]

[[20141022104627]] 『コンボボックスをマウスホイールで上下させたい』（たまやん） ページの最後に飛ぶ

[[20141022104627]]　『コンボボックスをマウスホイールで上下させたい』（たまやん）　ページの最後に飛ぶ