TL;DR

VB6でホイール対応を求められた場合の方法。過去記事（停止済みサービス利用）からの転載
- http://homepage.mac.com/t_fukumori/iblog/C1746881529/E2116345545/index.html
現在は不要な方法。基本的には.NETへの乗り換えを提案しましょう。用途は、極々ニッチな社内アプリケーションなどで今さら追加で求められた場合などのみ

概要

VB 6(Visual Basic)ではホイールのイベント（ホイール回転、ホイールボタン押下など）を標準では捕まえることができない。（.NETでは標準機能）
こちらをWindow Messageを利用して捕まえることができるようにしてみた。

使用方法

FormのLoadとUnloadに少々コードを書くことで、イベントを捕まえることができる

注意点

サブクラス化を利用しているので、デバッグモード中に停止させたりすると IDEごと落ちることがある（Form_Unload、Class_Terminateイベントが実行されない）。

ソース

clsWheelMouse.cls

'@(s)
'
' 概要：    ホイールのイベントをつかまえるクラス
'
' 備考：    宣言文：        本クラスは、WithEventsをつけて、メンバ変数で宣言して
'                           使用します。
'                           ex) Private WithEvents m_CWheel As clsWheelMouse
'
'           初期化の手順：  Form_Loadにて本クラスのインスタンスを作成し、
'                           Initializeプロシージャを呼び出し、ボタンを捕まえたい
'                           コントロールのハンドルを渡す
'                           ex) Set m_CWheel = New clsWheelMouse
'                               Call m_CWheel.Initialize(picView.hWnd)
'
'           後始末の手順：  Form_UnloadにてTerminateプロシージャを呼び出し、
'                           インスタンスの削除を行う
'                           ex) m_CWheel.Terminate
'                               Set m_CWheel = Nothing
'

Option Explicit

' [イベント]
Public Event MouseWheel(ByVal iniVector As Integer)
    '' iniVector:   -1;ホイールが奥に回転した場合
    ''               1;ホイールが手前に回転した場合
Public Event MouseWheelButtonUp(ByVal X As Single, ByVal Y As Single)
Public Event MouseWheelButtonDown(ByVal X As Single, ByVal Y As Single)
    '' XとYはTwipsで返却される

' [変数]
Private m_OwnerhWnd As Long '' イベントを捕まえるフォーム、もしくはコントロール
Private m_Initlalized As Boolean    '' 初期化されたか

Public Property Get OwnerhWnd() As Long
    OwnerhWnd = m_OwnerhWnd
End Property

Public Function Initialize(ByVal inlOwnerhWnd As Long) As Boolean
    Initialize = False

    '' ガード条件
    If m_Initlalized Then Exit Function
    If inlOwnerhWnd = 0 Then Exit Function

    m_OwnerhWnd = inlOwnerhWnd
    If Not WheelClassInitialise(Me, m_OwnerhWnd) Then Exit Function

    '' 初期化成功
    m_Initlalized = True
    Initialize = True
End Function

Public Function Terminate()
    Call WheelClassTerminate(m_OwnerhWnd)
    SetWindowLong m_OwnerhWnd, GWL_WNDPROC, _
                GetWindowLong(m_OwnerhWnd, GWL_USERDATA)
    m_Initlalized = False
End Function

Private Sub Class_Initialize()
    m_OwnerhWnd = 0&
    m_Initlalized = False
End Sub

Private Sub Class_Terminate()
    If Not m_Initlalized Then Exit Sub

    '' 終了処理が終わっていない場合には、終了処理を呼び出す
    Call Terminate
End Sub

Public Sub raiseMyEvent(ByVal iniOption As Integer, _
            ByVal iniVector As Integer, ByVal insX As Single, ByVal insY As Single)
    Select Case iniOption
        Case 1: RaiseEvent MouseWheelButtonDown(insX, insY)
        Case 2: RaiseEvent MouseWheelButtonUp(insX, insY)
        Case 3: RaiseEvent MouseWheel(iniVector)
    End Select
End Sub

modWheelMouse.bas

' @(s)
'
' 概要：    ホイール標準モジュール。ホイールクラスとセットで使用
'

Option Explicit

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
            (ByVal lpPrevWndFunc As Long, _
            ByVal hWnd As Long, ByVal Msg As Long, _
            ByVal wParam As Long, ByVal lParam As Long) _
            As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
            (ByVal hWnd As Long, _
            ByVal nIndex As Long) _
            As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
            (ByVal hWnd As Long, _
            ByVal nIndex As Long, _
            ByVal dwNewLong As Long) _
            As Long

Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)

Private Const WM_LBUTTONDOWN = &H201;
Private Const WM_LBUTTONUP = &H202;
Private Const WM_MBUTTONDOWN = &H207;
Private Const WM_MBUTTONUP = &H208;
Private Const WM_RBUTTONDOWN = &H204;
Private Const WM_RBUTTONUP = &H205;
Private Const WM_MOUSEWHEEL = &H20A;

Private m_ColCWhell As Collection

Public Function WheelClassInitialise(ByRef inoWheel As clsWheelMouse, _
                                        ByVal inlOwnerhWnd As Long) As Boolean
    Dim i As Long

    WheelClassInitialise = False

    If m_ColCWhell Is Nothing Then
        Set m_ColCWhell = New Collection
    End If

    '' ガード条件：ハンドルが0の場合は終了
    If inlOwnerhWnd = 0 Then Exit Function
    '' ガード条件：既に同じハンドルが登録されている場合には、終了
    For i = 1 To m_ColCWhell.Count
        If m_ColCWhell(i).OwnerhWnd = inlOwnerhWnd Then
            Exit Function
        End If
    Next i

    m_ColCWhell.Add inoWheel

    SetWindowLong inlOwnerhWnd, GWL_USERDATA, _
                SetWindowLong(inlOwnerhWnd, GWL_WNDPROC, AddressOf SubClassProc)

    WheelClassInitialise = True
End Function

Public Sub WheelClassTerminate(ByVal inlOwnerhWnd As Long)
    Dim i As Long

    If m_ColCWhell Is Nothing Then Exit Sub

    For i = 1 To m_ColCWhell.Count
        If m_ColCWhell(i).OwnerhWnd = inlOwnerhWnd Then
            m_ColCWhell.Remove i
            Exit For
        End If
    Next i
End Sub

Private Function SubClassProc(ByVal hwndx As Long, _
                                ByVal uMsg As Long, _
                                ByVal wParam As Long, _
                                ByVal lParam As Long) As Long
    Dim i As Long
    Dim Index As Long
    Dim zDelta As Integer
    Dim sngX As Single
    Dim sngY As Single
    Dim intHiWord As Integer
    Dim intLowWord As Integer

    If m_ColCWhell Is Nothing Then Exit Function
    If m_ColCWhell.Count = 0 Then Exit Function

    Static Calling As Boolean
    If Not Calling Then
        Index = 0
        For i = 1 To m_ColCWhell.Count
            If m_ColCWhell(i).OwnerhWnd = hwndx Then
                Index = i
                Exit For
            End If
        Next i
        If Index <> 0 Then
            Calling = True
            Select Case uMsg
            Case WM_MBUTTONDOWN, WM_MBUTTONUP   '' 中ボタンをDownもしくはUp
                '' ダブルワードを分割
                Call DWordToWord(lParam, intHiWord, intLowWord)
                '' 上位ワードがY座標：ピクセルをTwipsに変換
                sngY = CSng(intHiWord) * Screen.TwipsPerPixelY
                '' 下位ワードがX座標
                sngX = CSng(intLowWord) * Screen.TwipsPerPixelX
                If (uMsg = WM_MBUTTONDOWN) Then
                    m_ColCWhell(i).raiseMyEvent 1, 0, sngX, sngY
                Else
                    m_ColCWhell(i).raiseMyEvent 2, 0, sngX, sngY
                End If

            Case WM_MOUSEWHEEL  '' Wheelを回した
                zDelta = CInt(wParam / 2 ^ 16)
                If zDelta < 0 Then
                    '' ホイールが奥に回転した場合
                    m_ColCWhell(i).raiseMyEvent 3, -1, 0, 0
                Else
                    '' ホイールが手前に回転した場合
                    m_ColCWhell(i).raiseMyEvent 3, 1, 0, 0
                End If
            End Select
        End If
        Calling = False
    End If
    SubClassProc = CallWindowProc(GetWindowLong(hwndx, GWL_USERDATA), _
                hwndx, uMsg, wParam, lParam)
End Function

' @(f)
'
' 機能：ダブルワードを上位ワードと下位ワードに分割
'
Private Sub DWordToWord(ByVal inlDoubleWord As Long, _
                        ByRef iniHiWord As Integer, _
                        ByRef iniLowWord As Integer)
    If (inlDoubleWord And &HFFFF;&) > &H7FFF; Then
        iniLowWord = (inlDoubleWord And &HFFFF;&) - &H10000;
    Else
        iniLowWord = inlDoubleWord And &HFFFF;&
    End If

    iniHiWord = (inlDoubleWord And &HFFFF0000;) \ &H10000;
End Sub

frmMain.frm

Option Explicit

Private WithEvents m_CWheel As clsWheelMouse

Private Sub Form_Load()
    Set m_CWheel = New clsWheelMouse
    Call m_CWheel.Initialize(picMain.hWnd)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    m_CWheel.Terminate
    Set m_CWheel = Nothing
End Sub

Private Sub m_CWheel_MouseWheel(ByVal iniVector As Integer)
    lblView.Caption = "MouseWheel"
End Sub

Private Sub m_CWheel_MouseWheelButtonDown(ByVal X As Single, ByVal Y As Single)
    lblView.Caption = "MouseWheelButtonDown " & X & ";" & Y
End Sub

Private Sub m_CWheel_MouseWheelButtonUp(ByVal X As Single, ByVal Y As Single)
    lblView.Caption = "MouseWheelButtonUp " & X & ";" & Y
End Sub

VB6でホイールマウスのイベントを捕まえる

TL;DR

概要

使用方法

注意点

ソース