VB6メモ:マウスホイールスクロール(VScrollBar版)

『VB6メモ:マウスホイールスクロール』でMSFlexFridやGridなどのコントロールを
マウスホイールでスクロールさせる方法を紹介しましたが
VScrollBarコントロールでは少々やり方が方法が異なるのでメモしておきます。

MSFlexFrid等と違い、VScrollBarコントロールは別のコントロールと連携して動作させることが必須かと思います。
『VB6メモ:マウスホイールスクロール』で書いた方法では
指定したコントロールの上で発生したマウスホイールイベントを取得するため
VScrollBarコントロールで使用してもVScrollBarコントロールの上でしか動作できません。

このため、【マウスホイールイベントを取得したいコントロール】【スクロールしたいコントロール】
分けて処理する必要があるかと思います。


では、以下に処理の流れを書いておきます。

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

Declare Function 関数()

(2)SetWindowLong関数で【マウスホイールイベントを取得したいコントロール】のウィンドウプロシージャを書き換え

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

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

If メッセージ = WM_MOUSEWHEEL Then

(4)【スクロールしたいコントロール】(VScrollBar)のスクロール処理

VScrollBar.Value = スクロール位置

のような感じになります。
そこまで違いはありませんねw


『VB6メモ:マウスホイールスクロール』と同様ですが、注意点として以下の処理を忘れないよう注意してください。

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

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

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

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

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

この記事はVScrollBarコントロール用に書いていますが、
『VB6メモ:マウスホイールスクロール』の処理と組み合わせれば
「コントロールA上でマウスホイールしたらコントロールBをスクロールさせる」なんてことも可能です。

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



マウスホイールスクロール用モジュール(VScrollBar版):mdlMouseWheelScroll_VScrollBar.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 prScrollCtrl  As Object     'スクロールしたいコントロール
Private prScrollValue As Long       'スクロールさせる移動量


'======ウィンドウプロシージャ======
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
    Dim wBarPos As Long
    Dim wMax As Long
    Dim wMin As Long
On Error GoTo proc_err
    '----------------------------------
    'マウスホイールメッセージ
    If vMsg = WM_MOUSEWHEEL Then
        'メッセージのパラメータからスクロール方向を取得
        wDelta = HIWORD(wParam)
        '----------------------------------
	    With prScrollCtrl
	        '移動先の位置を決定
	        If wDelta < 0 Then
	            wBarPos = .Value + prScrollValue
	        Else
	            wBarPos = .Value - prScrollValue
	        End If
	        '--------------
	        '最小値・最大値を取得(最大がマイナスになることもあるため)
	        If .Min < .Max Then
	            wMin = .Min
	            wMax = .Max
	        Else
	            wMin = .Max
	            wMax = .Min
	        End If
	        '--------------
	        '最小値を下回っていないかチェック
	        If wBarPos < wMin Then
	            wBarPos = wMin
	        End If
	        '--------------
	        '最大値を上回っていないかチェック
	        If wBarPos > wMax Then
	            wBarPos = wMax
	        End If
	        '--------------
	        'スクロールする
	        .Value = wBarPos
	    End With
    End If
    '----------------------------------
    GoTo proc_end
proc_err:
proc_end:
    '通常のメッセージ処理(これを忘れると危険)
    WndProc = CallWindowProc(prOldWndProc, hWnd, vMsg, wParam, lParam)
End Function


'======Public関数定義======
'機能:コントロールにマウスホイールを対応させる
'引数:rTargetCtrl :マウスホイールイベントを取得したいコントロール
'    :rScrollCtrl :実際にスクロールさせるコントロール
'    :vScrollValue:スクロールさせる移動量
'戻値:成否(True/False)
Public Function SetMouseWheelScroll(ByRef rTargetCtrl As Object, ByRef rScrollCtrl As Object, ByVal vScrollValue) As Boolean
    Dim wRet     As Boolean
On Error GoTo proc_err
    wRet = True
    '------------------------------------------------
    'マウスホイールイベントを取得したいコントロール
    Set prCtrl = rTargetCtrl
    'スクロールしたいコントロール
    Set prScrollCtrl = rScrollCtrl
    'スクロールさせる移動量
    prScrollValue = vScrollValue
    
    'ウィンドウプロシージャ書き換え
    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()
    'マウスホイールでのスクロールを登録
    '引数:(1)マウスホイールイベントを取得したいコントロール
    '      (2)実際にスクロールさせるコントロール
    '      (3)スクロールさせる移動量
    If Not SetMouseWheelScroll(Me.Ctrl, Me.VScrollBarCtrl, 10) Then Debug.Print "登録エラー"
End Sub

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


コメント
コメントする








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