VB6メモ:マウスホイールスクロール

VB6以前の古いMSFlexFridやGridなどのコントロールを使用すると、
マウスホイールでのスクロールに対応していない場合があります。

これではユーザーのマウスに折角ホイールが付いていてもスクロールができず、
使い勝手も悪く感じてしまうのでマウスホイールでスクロールさせる方法についてメモしておきます。

マウスホイールをさせるためにはWin32APIを使用する必要があります。
流れとしては、

(1)DeclareでWin32APIの関数を宣言

Declare Function 関数()

(2)SetWindowLong関数でコントロールのウィンドウプロシージャを書き換え

書き換え前のウィンドウプロシージャ = SetWindowLong(コントロールのハンドル, GWL_WNDPROC, AddressOf ウィンドウプロシージャ)

(3)マウスホイールのメッセージ(WM_MOUSEWHEEL)の処理を感知したら

If メッセージ = WM_MOUSEWHEEL Then

(4)PostMessage関数でコントロールにスクロールのメッセージ(WM_VSCROLL)を送信する

PostMessage(コントロールのハンドル, WM_VSCROLL, IIf(wDelta > 0, SB_LINEUP, SB_LINEDOWN), 0)


のような感じになります。
VC(Win32)でコーディングの経験がある方はすぐ理解できるのではないかと思います。
わからない方はWin32APIについて調べてください。

なお、注意点として以下の処理を忘れないよう注意してください。

(※1)ウィンドウプロシージャではCallWindowProc関数で必ず書き換え前のウィンドウプロシージャに処理を戻すこと

WndProc = CallWindowProc(書き換え前のウィンドウプロシージャ , コントロールのハンドル, vMsg, wParam, lParam)

(※2)終了時は必ずSetWindowLongでウィンドウプロシージャを元に戻すこと

Call SetWindowLong(コントロールのハンドル, GWL_WNDPROC, 書き換え前のウィンドウプロシージャ)

 
以下に私が作ってみたコードを記載しておきます。
ただしこのコードだけでは1つのコントロールまでしか同時にしようできません。(希望があれば複数使用のコードも追記します)

【追記】複数コントロール対応版を更新しました。
マウスホイールスクロール(複数コントロール対応・縦横ホイール対応)
ついでに横スクロールも対応しています。


GridとMSFlexGridについては動作確認できていますが、
プロパティに「hWnd」(ウィンドウハンドル)が存在していれているコントロールであれば使用可能だとは思います。

※VScrollBarコントロールで使用する際は少し処理が変わります。マウスホイールスクロール(VScrollBar版)

なお、使用は自己責任でお願いします。(下記コードの赤字の箇所は特に注意してください)


マウスホイールスクロール用モジュール:mdlMouseWheelScroll.bas

'======Win32API関数宣言======
'ウィンドウにデータをセット
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" _
            (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'メッセージを指定のウィンドウプロシージャに渡す
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" _
            (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, _
             ByVal wParam As Long, ByVal lParam 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 Boolean

'======Win32API定数定義======
'メッセージ
Private Const WM_MOUSEWHEEL As Long = &H20A       'マウスホイール
Private Const WM_VSCROLL As Integer = &H115       '縦スクロール
'-----
Private Const GWL_WNDPROC As Long = (-4)        'ウィンドウ関数のアドレス
Private Const SB_LINEUP = 0                     '上に1行スクロール
Private Const SB_LINEDOWN = 1                   '下に1行スクロール

'======モジュール変数定義======
Private prOldWndProc  As Long
Private prCtrl        As Object


'======ウィンドウプロシージャ======
Private Function WndProc(ByVal hWnd As Long, ByVal vMsg As Long, _
                          ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim wDelta As Long
On Error GoTo proc_err
    '----------------------------------
    'マウスホイールメッセージ
    If vMsg = WM_MOUSEWHEEL Then
        'メッセージのパラメータからスクロール方向を取得
        wDelta = HIWORD(wParam)
        '----------------------------------
        'スクロールさせる為、コントロールにWM_VSCROLLメッセージを送信
        If Not PostMessage(prCtrl.hWnd, WM_VSCROLL, IIf(wDelta > 0, SB_LINEUP, SB_LINEDOWN), 0) Then
            'メッセージ送信エラー
            GoTo proc_err
        End If
    End If
    '----------------------------------
    GoTo proc_end
proc_err:
proc_end:
    '通常のメッセージ処理(これを忘れると危険)
    WndProc = CallWindowProc(prOldWndProc, hWnd, vMsg, wParam, lParam)
End Function


'======Public関数定義======
'機能:コントロールにマウスホイールを対応させる
'引数:rCtrl:マウスホイールでスクロールさせるコントロール
'戻値:成否(True/False)
Public Function SetMouseWheelScroll(ByRef rCtrl As Object) As Boolean
    Dim wRet     As Boolean
On Error GoTo proc_err
    wRet = True
    '------------------------------------------------
    'マウスホイールでスクロールさせるコントロール
    Set prCtrl = rCtrl
    
    'ウィンドウプロシージャ書き換え
    prOldWndProc = SetWindowLong(prCtrl.hWnd, GWL_WNDPROC, AddressOf WndProc)
    '------------------------------------------------
    GoTo proc_end
proc_err:
    wRet = False
proc_end:
    SetMouseWheelScroll = wRet
End Function

'機能:コントロールのマウスホイールを解除する
'引数:なし
'戻値:成否(True/False)
Public Function UnSetMouseWheelScroll() As Boolean
    Dim wRet As Boolean
On Error GoTo proc_err
    wRet = True
    '------------------------------------------------
    'マウスホイールでのスクロールを解除(これを忘れると危険)
    Call SetWindowLong(prCtrl.hWnd, GWL_WNDPROC, prOldWndProc)
    '------------------------------------------------
    GoTo proc_end
proc_err:
    wRet = False
proc_end:
    UnSetMouseWheelScroll = wRet
End Function


'======メッセージ処理関数======
Private Function HIWORD(ByVal vParam As Long) As Long
    Dim wHex As String
    Dim wRet As Long
On Error GoTo proc_err
    '------------------------------
    wHex = Hex(vParam)
    '-------------
    If Len(wHex) > 4 Then
        wRet = Val("&H" & Left(wHex, Len(wHex) - 4))
    Else
        wRet = 0
    End If
    '------------------------------
    GoTo proc_end
proc_err:
    wRet = -1
proc_end:
    HIWORD = wRet
End Function

Private Function LOWORD(ByVal vParam As Long) As Long
    Dim wHex As String
    Dim wRet As Long
On Error GoTo proc_err
    '------------------------------
    wHex = Hex(vParam)
    '-------------
    If Len(wHex) > 4 Then
        wRet = Val("&H" & Right(wHex, 4))
    Else
        wRet = Val("&H" & wHex)
    End If
    '------------------------------
    GoTo proc_end
proc_err:
    wRet = -1
proc_end:
    LOWORD = wRet
End Function

フォーム:form.frm
'フォームロードイベント処理
Private Sub Form_Load()
    Dim i As Long
    '--------------------
    'グリッドに文字を表示
    For i = 0 To 100
        With Grid1
            .AddItem (i)
            .Col = 1: .Row = i + 1: .Text = Chr(Asc("あ") + i)
        End With
    Next i
    '-----
    'マウスホイールでのスクロールを登録
    If Not SetMouseWheelScroll(Me.Grid1) Then Debug.Print "登録エラー"
End Sub

'フォームアンロードイベント処理
Private Sub Form_Unload(Cancel As Integer)
    'マウスホイールでのスクロールを解除(これを忘れると危険)
    If Not UnSetMouseWheelScroll() Then Debug.Print "解除エラー"
End Sub


コメント
はじめまして
前に作ったVB6のアプリがWIN7になったため
マウスホイールスクロールが動作しなくなっていたのですが
こちらの記事を参考にさせて頂き、無事動作するようになりました
ありがとうございます

ご質問なのですが
このコードを利用してVScrollBarでマウシホイールを動作させる事は可能でしょうか
勝手なお願いで申し訳ありませんが、もしよろしければお教え下さい。
よろしくお願い致します。
  • suzy
  • 2012/01/10 12:06 AM
>suzyさん
このコードではVScrollBarのスクロールはできません。
ただし、応用することで対応することはできます。(仕事でやったことあります)

ざっと書きますが、サンプルコードではSetMouseWheelScroll関数内では
「スクロールしたいコントロール」のhWndを取得してSetWindowLong関数に渡していますが、

これを「マウスホイールイベントを取得したいコントロール」のhWndを設定するように変更します。

次にWndProc関数内でPostMessage関数を実行している場所で
VScrollBarコントロールのValueプロパティ等を変更させる処理を書けば対応できるはずです。

コメント欄だけだと説明が難しいですね…;
VScrollBar対応版の記事書きましょうか?
ただし来週くらいまで待って頂くことになると思いますが…;
ご返事ありがとうございます。
Win32APIはさっぱり解らないので
もし教えて頂ければ非常に有りがたいです
急ぎませんので、ご都合の良い時にお願い致します
よろしくお願い致します。
  • suzy
  • 2012/01/10 10:15 PM
VScrollBar用の記事を書きました。確認をお願いします。

『VB6メモ:マウスホイールスクロール(VScrollBar版)』
http://note.phyllo.net/?eid=1106164

ただ、現在私のPCにVB6が入っていない為、
まだサンプルコードの動作確認ができていません。
たぶん大丈夫だとは思いますが…

一応、月曜に職場のPCで確認します…;
VScrollBar版のコード有難う御座いました
先程、試してみましたら問題無く動作しました
本当に助かりました

XP環境ではMSのマウス(intelli mouse)に付属しているソフトを
インストールすればFocusに関係なくスクロールしていたのですが
WIN7になってからインストール出来なくなり諦めていたのですが
これでスクロールさせる事が出来ます
本当に助かりました
  • suzy
  • 2012/01/15 2:32 PM
はじめまして

こちらのサイトを参考に
マウスホイールスクロール動作の
プログラムを作成しています。

1画面での操作なら思うように動いてくれるのですが
親画面から呼び出した画面のGridや
RepeatListも同様にスクロールしたい場合
フォーカスを親画面に戻しているのに
子画面のGrid等がスクロールされてしまいます。

コントロールがactiveになった時に動作
Deactiveになった時に解放の処理としたのですが
途中で固まってしまい動かなくなってしまいます。
APIをあまり理解できていませんが
アドバイス等をご教授いただけたら助かります
  • himasaburou
  • 2012/10/30 2:43 PM
すみません、追記です。

RepeatListを持つ画面での設定を外すと動きます。
RepeatListにhWndを持っていないからだと思いますが
対処方法はありますか?
  • himasaburou
  • 2012/10/30 3:19 PM
APIを利用してリッチテキストボックスでのマウススクロールは機能していたのですが、画面解像度が不足するディスプレイの為にフォームにスクロールバーを試しています。マウスホイールスクロールを実行するとフォームがスクロールしてしまい、リッチテキストボックスのスクロールが機能してくれません。複数使用のコードも追記しますと記述されていますので、大変申し訳ございませんが、複数使用のコードを記述願えませんか。
  • robinosuke
  • 2015/05/14 12:05 PM
>robinosukeさん
遅くなってしまい申し訳ありません。
(忙しくてあまりコメントチェックと記事更新の時間が取れませんでした;)

2か月もたってしまったので、見られないかもしれませんが、、、
複数コントロール対応版の記事を作成しました。

『マウスホイールスクロール(複数コントロール対応・縦横ホイール対応)』
http://note.phyllo.net/?eid=1106273
>himasaburouさん
ごめんなさい。2年半も前のコメントなのに今気づきました。。。;
これは複数のコントロールを同じウィンドウプロシージャで処理しているため、
処理が混同してしまったんでしょうね。
解放処理のタイミングの問題かもしれません。
これも複数コントロール対応版で解決できるかと思います。

『マウスホイールスクロール(複数コントロール対応・縦横ホイール対応)』
http://note.phyllo.net/?eid=1106273

あと、すみませんが、RepeatListというものが私には何なのかわからないので
回答することができません。。。
コメントする








    
この記事のトラックバックURL
トラックバック