【VB6メモ】マウスホイールスクロール(複数コントロール対応・縦横ホイール対応)

VB6でのマウスホイールでのスクロールについて、複数コントロール対応について要望があったのでメモしておきます。
技術的には前回のマウスホイールスクロールと同じなので、細かい説明は端折ります。
※今回のサンプルソースは横スクロールも対応していますが、基本は縦スクロールと同じです。

以下の2ファイルを作成して、使用例のように設定を行うと対応することができます。
 (1)clsMouseWheelScroll.cls
 (2)mdlMouseWheelScroll.bas

ウィンドウプロシージャの書換えをするので、 使い方を間違えるとフリーズしたりWindowsが落ちたりするので要注意です。
サンプルソースの使用は自己責任でお願いします。

サンプルソース:マウスホイールスクロール管理クラス(clsMouseWheelScroll.cls)
・前回のマウスホイールスクロールの内容をクラスにしたものです。
・使い方としては、NEWでインスタンスを生成して、マウスホイールでのスクロール対応をしたいコントロールを設定するだけです。
・1インスタンスで1コントロールを管理します。
 複数コントロールのマウスホイールスクロール対応するためには、インスタンスも同じ数だけ生成する必要があります。
※使い終わったら必ず解除処理を行うようにしてください。
clsMouseWheelScroll.cls
'Win32API宣言'
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_MOUSEHWHEEL As Long = &H20E    'マウスホイール(横)'
Private Const WM_VSCROLL     As Long = &H115    '縦スクロール'
Private Const WM_HSCROLL     As Long = &H114    '横スクロール'
'Win32API定数定義'
Private Const SB_LINEUP      As Long = 0        '上に1行スクロール'
Private Const SB_LINEDOWN    As Long = 1        '下に1行スクロール'
Private Const SB_LINELEFT    As Long = 0        '左に1行スクロール'
Private Const SB_LINERIGHT   As Long = 1        '右に1行スクロール'

'メンバ変数定義'
Private prCtrl        As Object
Private prOldWndProc  As Long

'コントロール'
Public Property Set Control(ByVal vCtrl As Object)
    Set prCtrl = vCtrl
End Property
Public Property Get Control() As Object
    Set Control = prCtrl
End Property

'コントロールのハンドル'
Public Property Get HWnd() As Long
    If Not Me.Control Is Nothing Then
        HWnd = Me.Control.HWnd
    Else
        HWnd = 0
    End If
End Property

'サブクラス化前のウィンドウプロシージャ'
Public Property Let OldProc(ByVal vOldProc As Long)
    prOldWndProc = vOldProc
End Property
Public Property Get OldProc() As Long
    OldProc = prOldWndProc
End Property

'コントロールにマウスホイールスクロールを設定'
Public Function SetMouseWheelScroll(ByRef rCtrl As Object) As Boolean
    Dim wRet     As Boolean
On Error GoTo proc_err
    wRet = True
    '------------------------------------------------'
    Set Me.Control = rCtrl
    
    'ウィンドウプロシージャ書き換え'
    wRet = SetSubProc(Me)
    '------------------------------------------------'
    GoTo proc_end
proc_err:
    wRet = False
proc_end:
    SetMouseWheelScroll = wRet
End Function

'コントロールにマウスホイールスクロールを解除'
Public Function UnSetMouseWheelScroll() As Boolean
    Dim wRet As Boolean
On Error GoTo proc_err
    wRet = True
    '------------------------------------------------'
    'マウスホイールでのスクロールを解除(これを忘れると危険)'
    wRet = UnSetSubProc(Me)
    '------------------------------------------------'
    GoTo proc_end
proc_err:
    wRet = False
proc_end:
    UnSetMouseWheelScroll = wRet
End Function

'サブクラス化したウィンドウプロシージャから呼ばれる処理'
Public 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 wDirection As Long
On Error GoTo proc_err
    '----------------------------------'
    'マウスホイール(縦)メッセージ'
    If vMsg = WM_MOUSEWHEEL Then
        'メッセージのパラメータからスクロール方向を取得'
        wDelta = HIWORD(wParam)
        '----------------------------------'
        'スクロールさせる為、コントロールにWM_VSCROLLメッセージを送信'
        wDirection = IIf(wDelta > 0, SB_LINEUP, SB_LINEDOWN)
        If Not PostMessage(prCtrl.HWnd, WM_VSCROLL, wDirection, 0) Then
            'メッセージ送信エラー'
            GoTo proc_err
        End If
    'マウスホイール(横)メッセージ'
    ElseIf vMsg = WM_MOUSEHWHEEL Then
        'メッセージのパラメータからスクロール方向を取得'
        wDelta = HIWORD(wParam)
        '----------------------------------'
        'スクロールさせる為、コントロールにWM_HSCROLLメッセージを送信'
        wDirection = IIf(wDelta > 0, SB_LINERIGHT, SB_LINELEFT)
        If Not PostMessage(prCtrl.HWnd, WM_HSCROLL, wDirection, 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

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
サンプルソース:ウィンドウプロシージャ管理モジュール(mdlMouseWheelScroll.bas)
・ウィンドウプロシージャのサブクラス化に関してだけは、VB6の制限でクラスにすることができなかったので、
 モジュールとしてclsMouseWheelScrollクラスと処理を分けています。
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

'Win32APIメッセージ定義'
Private Const GWL_WNDPROC As Long = (-4)        'ウィンドウ関数のアドレス'

'マウスホイールスクロール管理インスタンス配列'
Private prScrolls As New Collection

'サブクラス化したウィンドウプロシージャ'
Private Function SubProc(ByVal HWnd As Long, ByVal vMsg As Long, _
                         ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim wScroll As clsMouseWheelScroll
On Error GoTo proc_err
    '----------------------------------'
    Set wScroll = prScrolls(CStr(HWnd))
    SubProc = wScroll.WndProc(HWnd, vMsg, wParam, lParam)
    '----------------------------------'
    GoTo proc_end
proc_err:
proc_end:
    Set wScroll = Nothing
End Function

'コントロールのウィンドウプロシージャをサブクラス化'
Public Function SetSubProc(ByRef rScroll As clsMouseWheelScroll) As Boolean
    Dim wRet     As Boolean
On Error GoTo proc_err
    wRet = True
    '------------------------------------------------'
    If rScroll.HWnd > 0 Then
        'ウィンドウプロシージャ書き換え'
        rScroll.OldProc = SetWindowLong(rScroll.HWnd, GWL_WNDPROC, AddressOf SubProc)
    
        'マウスホイールスクロール管理インスタンス配列に追加'
        Call prScrolls.Add(rScroll, CStr(rScroll.HWnd))
    End If
    '------------------------------------------------'
    GoTo proc_end
proc_err:
    wRet = False
proc_end:
    SetSubProc = wRet
End Function

'コントロールのウィンドウプロシージャのサブクラス化を解除'
Public Function UnSetSubProc(ByRef rScroll As clsMouseWheelScroll) As Boolean
    Dim wRet As Boolean
On Error GoTo proc_err
    wRet = True
    '------------------------------------------------'
    If rScroll.HWnd > 0 Then
        'マウスホイールでのスクロールを解除(これを忘れると危険)'
        Call SetWindowLong(rScroll.HWnd, GWL_WNDPROC, rScroll.OldProc)
        
        'マウスホイールスクロール管理インスタンス配列から削除'
        Call prScrolls.Remove(CStr(rScroll.HWnd))
    End If
    '------------------------------------------------'
    GoTo proc_end
proc_err:
    wRet = False
proc_end:
    UnSetSubProc = wRet
End Function
使用例:マウスホイールでのスクロール(複数コントロール対応・縦横ホイール対応)
マウスホイールスクロール対応サンプル
このサンプルではMsFlexGridでGrid(0)〜(3)を画面に設置しています。

それぞれのグリッドがフォーカス取得状態の場合に
縦マウスホイールで縦スクロール、
横マウスホイールで横スクロールの動作をするようになります。

画面起動時にマウスホイールスクロールを設定し、
画面終了時にマウスホイールスクロールを解除しています。
FrmTest.frm
'マウスホイールスクロール管理インスタンス配列'
Private prScrolls As New Collection

'フォームロードイベント処理'
Private Sub Form_Load()
    Dim wIdxGrid As Long
    Dim wIdxItem As Long
    Dim wScroll  As clsMouseWheelScroll
    '--------------------'
    For wIdxGrid = Grid.LBound To Grid.UBound
        With Grid(wIdxGrid)
            'グリッドに文字を表示'
            .Cols = 4
            For wIdxItem = 0 To 100
                .AddItem (wIdxItem)
                .Col = 0: .Row = wIdxItem + 1: .Text = wIdxItem + 1
                .Col = 1: .Row = wIdxItem + 1: .Text = Chr(Asc("あ") + wIdxItem)
                .Col = 2: .Row = wIdxItem + 1: .Text = Chr(Asc("a") + wIdxItem)
                .Col = 3: .Row = wIdxItem + 1: .Text = Chr(Asc("A") + wIdxItem)
            Next wIdxItem
            
            Set wScroll = New clsMouseWheelScroll
            
            'マウスホイールでのスクロールを登録'
            Call wScroll.SetMouseWheelScroll(Grid(wIdxGrid))
            Call prScrolls.Add(wScroll)
        End With
    Next wIdxGrid
End Sub

'フォームアンロードイベント処理'
Private Sub Form_Unload(Cancel As Integer)
    Dim wIdx     As Long
    Dim wScroll  As clsMouseWheelScroll
    '--------------------'
    For wIdx = 1 To prScrolls.Count
        Set wScroll = prScrolls(wIdx)
        
        'マウスホイールでのスクロールを解除(これを忘れると危険)'
        Call wScroll.UnSetMouseWheelScroll
    Next wIdx
End Sub


コメント
コメントする








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