Option Explicit

'-- API 定数宣言
Private Const GWL_STYLE = (-16)
Private Const GWL_WNDPROC = (-4)

Private Const WM_MOUSEWHEEL = &H20A
Private Const WM_VSCROLL = &H115
Private Const SB_LINEDOWN = 1
Private Const SB_LINEUP = 0
Private Const SB_VERT = 1
Private Const SIF_RANGE = &H1
Private Const SIF_PAGE = &H2
Private Const SIF_POS = &H4
Private Const SIF_DISABLENOSCROLL = &H8
Private Const SIF_TRACKPOS = &H10
Private Const SIF_ALL = SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS

'-- API 型宣言
Private Type SCROLLINFO
    cbSize As Long
    fMask As Long
    nMin As Long
    nMax As Long
    nPage As Long
    nPos As Long
    nTrackPos As Long
End Type

'-- API 関数宣言
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
    ByVal hWnd As Long, _
    ByVal nIndex As Long _
) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
    ByVal hWnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long _
) As Long
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

Private Declare Function SendMessageByNum Lib "user32" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long _
) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
    ByVal hWnd1 As Long, _
    ByVal hWnd2 As Long, _
    ByVal lpsz1 As String, _
    ByVal lpsz2 As String _
) As Long

Private Declare Function GetScrollInfo Lib "user32" ( _
    ByVal hWnd As Long, _
    ByVal n As Long, _
    lpScrollInfo As SCROLLINFO _
) As Long

Private Declare Function SetProp Lib "user32" Alias "SetPropA" ( _
    ByVal hWnd As Long, _
    ByVal lpString As String, _
    ByVal hData As Long _
) As Long

Private Declare Function GetProp Lib "user32" Alias "GetPropA" ( _
    ByVal hWnd As Long, _
    ByVal lpString As String _
) As Long

'-- パブリック変数

'-- プライベート定数
Private Const PROPNAME As String = "HFGSubClassDefProc"

'サブクラス化開始関数
Public Function SubClass(hWnd As Long) As Boolean
    On Error GoTo ErrorHandle
    
    'デフォルトのウィンドウプロシージャのアドレスの保存と新しいウィンドウプロシージャの登録
    Dim nDefProc As Long
    nDefProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf MainFormWindowProc)
    If nDefProc = 0 Then GoTo ErrorHandle
    SubClass = True
    Call SetProp(hWnd, PROPNAME, nDefProc)
    
    Exit Function
ErrorHandle:
    SubClass = False
End Function

'サブクラス化終了関数
Public Function UnSubClass(hWnd As Long) As Boolean
    Dim lngX As Long     '戻り値を格納
    
    On Error GoTo ErrorHandle
    Dim nDefProc As Long
    nDefProc = GetProp(hWnd, PROPNAME)
    'サブクラス化していないときは処理を行わない
    If nDefProc <> 0 Then
        'ウィンドウプロシージャをデフォルトに戻す
        lngX = SetWindowLong(hWnd, GWL_WNDPROC, nDefProc)
        If lngX = 0 Then GoTo ErrorHandle
        nDefProc = 0
    End If
    
    UnSubClass = True
    Exit Function
ErrorHandle:
    UnSubClass = False
End Function

'自前のウィンドウプロシージャ
Public Function MainFormWindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim nKeys As Long
    Dim nDelta As Long
    Dim nX As Long
    Dim nY As Long
    Dim sbiInfo As SCROLLINFO
    
    'Debug.Print Hex(hwnd), Hex(uMsg), Hex(wParam), Hex(lParam)     'すべてのメッセージを表示(結構楽しい(^_^))
    
    On Error GoTo ErrorHandle
    
    Select Case uMsg
    Case WM_MOUSEWHEEL
        Debug.Print "WM_MOUSEWHEEL"
        nKeys = LOWORD(wParam)
        nDelta = HIWORD(wParam)
        nX = LOWORD(lParam)
        nY = HIWORD(lParam)
'
        sbiInfo.cbSize = LenB(sbiInfo)
        sbiInfo.fMask = SIF_ALL
        If 0 <> GetScrollInfo(hWnd, SB_VERT, sbiInfo) Then
            Call SendMessageByNum(hWnd, WM_VSCROLL, IIf(nDelta > 0, SB_LINEUP, SB_LINEDOWN), 0)
        End If
    
    End Select
    
    'デフォルトのウィンドウプロシージャを呼び出す
    Dim nDefProc As Long
    nDefProc = GetProp(hWnd, PROPNAME)
    If nDefProc <> 0 Then
        MainFormWindowProc = CallWindowProc(nDefProc, hWnd, uMsg, wParam, lParam)
    End If
    
    Exit Function
    
ErrorHandle:
    Debug.Print Err.Number & " : " & Err.Description
    Resume Next
End Function