NonSoft - MSFLXGRDのマウスホイールによるスクロールのサンプル(VB6)

MSFLXGRDのマウスホイールによるスクロールのサンプル(VB6)

サンプルソース

＜このサンプルの概要＞
MSFLXGRD.OCXは、Windows 2000やXPの標準ではマウスホイールによるスクロールが出来ま
せん。色々調べましたがどうやらIntelliPointのバージョンを4.12に下げるとスクロール
するようです。ＶＢ６のコード編集ウィンドウも同様のようです。しかし、その為にバー
ジョンを下げるのも怖いので自力でスクロールする処理を考えてみました。

仕様としては、マウスホイールのイベントを取得して、MSFLXGRDコントロールにスクロー
ルのイベント（メッセージ）送信するというものです。マウスホイールのイベントの取得
はDirectXEvent8を使用しています。MSFLXGRDコントロールにSendMessageを使用していま
す。

このサンプルでは、「このプログラムでマウスホイール制御するかどうか」と「スクロー
ル行数」の設定をするフォームも付いています。このプログラムは「テキスト差分表示ツ
ール」と「フォルダ内のファイル比較ツール」で使用されています。

★MSFLXGRDのマウスホイールによるスクロールのサンプル(MouseWheel.frm)

'**********************************************************************
' 機能名    : マウスホイールによるスクロール
'
' 機能説明  : マウスホイールによるスクロールが出来無いコントロールをス
'           : クロール制御する
'
' 備考      : MSFLXGRD.OCXをマウスホイールによりスクロールするために作
'           : 成しました。通常は、IntelliPoint4.12等をインストールして
'           : スクロール出来るようにすべきなのかもしれません。
'
' 著作権    : Copyright(C) 2007 のん All right reserved
'           : このプログラムは、日本国著作権法および国際条約により保護
'           : されています。このプログラムの全部または一部を無断で複製
'           : したり、無断で複製物を頒布すると、著作権の侵害となります
'           : のでご注意ください。
'           : ただし、個人使用目的に限りカスタマイズ可能とします。
'**********************************************************************
' API定義--------------------------------------------------------------
Private Declare Function GetPrivateProfileString Lib _
    "kernel32.dll" Alias "GetPrivateProfileStringA" ( _
    ByVal lpSectName As String, ByVal lpKeyName As Any, _
    ByVal lpDefault As String, ByVal lpReturnedString As String, _
    ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetActiveWindow Lib "USER32" () As Long
Private Const WM_VSCROLL = 277
Private Const SB_LINEUP = 0
Private Const SB_LINEDOWN = 1
Private Declare Function SendMessage Lib _
    "USER32" Alias "SendMessageA" ( _
    ByVal hWnd As Long, ByVal wMsg As Long, _
    ByVal wParam As Long, lParam As Any) As Long

' DirectX定義----------------------------------------------------------
Implements DirectXEvent8
Private ObjDx As DirectX8
Private ObjDi As DxVBLibA.DirectInput8
Private ObjDiD As DxVBLibA.DirectInputDevice8
Private EventI As Long

' その他の定義---------------------------------------------------------
Private CtrlHWnd As Long
Private FormHWnd As Long
Private IniFilePath As String
Private WheelEnable As Long
Private WheelLine As Long

' ---------------------------------------------------------------------
' 関数名    : Initialize
' 返り値    : 無し
' 引き数    : 無し
' 機能説明  : マウスホイール処理初期化
' 著作権    : Copyright(C) 2006 のん All right reserved
Public Sub Initialize()
    On Error Resume Next
    ApplyIniInfo
    If WheelEnable = 0 Then
        Exit Sub
    End If
    
    Set ObjDx = New DxVBLibA.DirectX8
    Set ObjDi = ObjDx.DirectInputCreate()
    If ObjDi Is Nothing Then
        Exit Sub
    End If
    Set ObjDiD = ObjDi.CreateDevice("guid_SysMouse")
    If ObjDiD Is Nothing Then
        Exit Sub
    End If
    ObjDiD.SetCommonDataFormat DIFORMAT_MOUSE2
    ObjDiD.SetCooperativeLevel Me.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
    Dim dip As DxVBLibA.DIPROPLONG
    dip.lHow = DIPH_DEVICE
    dip.lData = 10
    dip.lObj = 0
    ObjDiD.SetProperty "DIPROP_BUFFERSIZE", dip
    EventI = ObjDx.CreateEvent(Me)
    ObjDiD.SetEventNotification EventI
    ObjDiD.Acquire
End Sub

' 関数名    : Destroy
' 返り値    : 無し
' 引き数    : 無し
' 機能説明  : マウスホイール処理破棄
' 著作権    : Copyright(C) 2006 のん All right reserved
Public Sub Destroy()
    On Error Resume Next
    If ObjDiD Is Nothing = False Then
        ObjDiD.Unacquire
    End If
    Set ObjDiD = Nothing
    Set ObjDi = Nothing
    Set ObjDx = Nothing
End Sub

' 関数名    : StartWheel
' 返り値    : 無し
' 引き数    : fHWnd(i) : マウスホイールするウィンドウ
'           : cHWnd(i) : マウスホイールするコントロール
' 機能説明  : マウスホイール開始
' 著作権    : Copyright(C) 2006 のん All right reserved
Public Sub StartWheel(ByVal fHWnd As Long, ByVal cHWnd As Long)
    On Error Resume Next
    If fHWnd <> 0 Then
        FormHWnd = fHWnd
    End If
    If cHWnd <> 0 Then
        CtrlHWnd = cHWnd
    End If
    If WheelEnable <> 0 Then
        If ObjDiD Is Nothing = False Then
            ObjDiD.Acquire
        End If
    End If
End Sub

' 関数名    : EndWheel
' 返り値    : 無し
' 引き数    : 無し
' 機能説明  : マウスホイール終了
' 著作権    : Copyright(C) 2006 のん All right reserved
Public Sub EndWheel()
    On Error Resume Next
    CtrlHWnd = 0
    If ObjDiD Is Nothing = False Then
        ObjDiD.Unacquire
    End If
End Sub

' 関数名    : DirectXEvent8_DXCallback
' 返り値    : 無し
' 引き数    : evId(i) : イベントID
' 機能説明  : マウスイベントコールバック処理
' 著作権    : Copyright(C) 2006 のん All right reserved
Private Sub DirectXEvent8_DXCallback(ByVal evId As Long)
    On Error Resume Next
    Dim dev(9) As DxVBLibA.DIDEVICEOBJECTDATA
    Dim i, j, c As Long
    If FormHWnd <> GetActiveWindow Or CtrlHWnd = 0 Then
        Exit Sub
    End If
    If EventI <> evId Then
        Exit Sub
    End If
    c = ObjDiD.GetDeviceData(dev, DIGDD_DEFAULT)
    If c = 0 Or Err Then
        ObjDiD.Acquire
        Exit Sub
    End If
    For i = 0 To c - 1
        If dev(i).lOfs = DIMOFS_Z Then
            For j = 1 To WheelLine
                If dev(i).lData < 0 Then
                    SendMessage CtrlHWnd, WM_VSCROLL, SB_LINEDOWN, ByVal 0
                Else
                    SendMessage CtrlHWnd, WM_VSCROLL, SB_LINEUP, ByVal 0
                End If
            Next j
        End If
    Next i
End Sub

' 関数名    : ApplyIniInfo
' 返り値    : 無し
' 引き数    : 無し
' 機能説明  : iniファイルの情報を適用する
' 著作権    : Copyright(C) 2006 のん All right reserved
Private Sub ApplyIniInfo()
    On Error Resume Next
    Dim sBuf As String
    Dim lRes As Long
    IniFilePath = App.Path & "\" & App.EXEName & ".ini"
    sBuf = Space(1024 + 1)
    lRes = GetPrivateProfileString("MouseWheel", "Enable", "0", sBuf, 1024, IniFilePath)
    WheelEnable = StrConv(LeftB$(StrConv(sBuf, vbFromUnicode), lRes), vbUnicode)
    lRes = GetPrivateProfileString("MouseWheel", "Line", "2", sBuf, 1024, IniFilePath)
    WheelLine = StrConv(LeftB$(StrConv(sBuf, vbFromUnicode), lRes), vbUnicode)
End Sub

★MSFLXGRDのマウスホイールによるスクロールのサンプル(MouseWheelD.frm)

'**********************************************************************
' 機能名    : マウスホイールによるスクロール設定画面
'
' 機能説明  : マウスホイールによるスクロール制御の有無やスクロール行数
'           : を設定する画面です。
'
' 著作権    : Copyright(C) 2007 のん All right reserved
'           : このプログラムは、日本国著作権法および国際条約により保護
'           : されています。このプログラムの全部または一部を無断で複製
'           : したり、無断で複製物を頒布すると、著作権の侵害となります
'           : のでご注意ください。
'           : ただし、個人使用目的に限りカスタマイズ可能とします。
'**********************************************************************
' API定義--------------------------------------------------------------
Private Declare Function GetPrivateProfileString Lib _
    "kernel32.dll" Alias "GetPrivateProfileStringA" ( _
    ByVal lpSectName As String, ByVal lpKeyName As Any, _
    ByVal lpDefault As String, ByVal lpReturnedString As String, _
    ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function SetPrivateProfileString Lib _
    "kernel32.dll" Alias "WritePrivateProfileStringA" ( _
    ByVal lpSection As String, ByVal lpKeyName As String, _
    ByVal lpValue As String, ByVal lpFileName As String) As Long

' その他の定義---------------------------------------------------------
Private IniFilePath As String

' ---------------------------------------------------------------------
' 関数名    : Form_Load
' 返り値    : 無し
' 引き数    : 無し
' 機能説明  : フォームロード時の処理
' 著作権    : Copyright(C) 2006 のん All right reserved
Private Sub Form_Load()
    On Error Resume Next
    Dim sBuf As String
    Dim lRes As Long
    IniFilePath = App.Path & "\" & App.EXEName & ".ini"
    sBuf = Space(1024 + 1)
    lRes = GetPrivateProfileString("MouseWheel", "Enable", "0", sBuf, 1024, IniFilePath)
    Chk_MouseWheel.Value = StrConv(LeftB$(StrConv(sBuf, vbFromUnicode), lRes), vbUnicode)
    lRes = GetPrivateProfileString("MouseWheel", "Line", "2", sBuf, 1024, IniFilePath)
    Cmb_WheelLine.Text = StrConv(LeftB$(StrConv(sBuf, vbFromUnicode), lRes), vbUnicode)
End Sub

' 関数名    : Btn_Ok_Click
' 返り値    : 無し
' 引き数    : 無し
' 機能説明  : 設定ボタンクリック時の処理
' 著作権    : Copyright(C) 2006 のん All right reserved
Private Sub Btn_Ok_Click()
    On Error Resume Next
    Me.Visible = False
    DoEvents
    SetPrivateProfileString "MouseWheel", "Enable", Chk_MouseWheel.Value, IniFilePath
    SetPrivateProfileString "MouseWheel", "Line", Cmb_WheelLine.Text, IniFilePath
    If Chk_MouseWheel.Value <> 0 Then
        MouseWheel.Initialize
    Else
        MouseWheel.Destroy
    End If
    Unload Me
End Sub

' 関数名    : Form_Unload
' 返り値    : 無し
' 引き数    : Cancel(i) : キャンセル=1
' 機能説明  : フォームアンロード時の処理
' 著作権    : Copyright(C) 2006 のん All right reserved
Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Me.Visible = False
End Sub

トップページ

ダウンロード

サンプルソース

ち～な～み～に～

その他のおすすめソフト