Attribute VB_Name = "modMouseWheel"
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal cbSrc As Long)
Public 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong 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 SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Public Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Private Const GWL_WNDPROC = (-4)
Private Const WM_MOUSEWHEEL = &H20A
Private Const WHEEL_DELTA = 120
Private Const MK_LBUTTON = &H1
Private Const MK_RBUTTON = &H2
Private Const MK_SHIFT = &H4
Private Const MK_CONTROL = &H8
Private Const MK_MBUTTON = &H10
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_MBUTTONDBLCLK = &H209

Private Const WM_MOUSELEAVE     As Long = &H2A3
Private Const WM_MOUSEMOVE      As Long = &H200
Private Const WM_MOUSEHOVER     As Long = &H2A1
'Private Const WM_MOUSEWHEEL     As Long = &H20A
Private Const WM_VSCROLL        As Long = &H115
Private Const WM_HSCROLL        As Long = &H114
Private Const WM_THEMECHANGED   As Long = &H31A

Private lpPrevWndProc As Long
Public WheelPos As Long
Public CallFunc As String
Public OwnerObj As Object
Public HookWnd As Long
Function LoWord(ByVal dwDoubleWord As Long) As Integer
    Call CopyMemory(LoWord, dwDoubleWord, 2)
End Function

Function HiWord(ByVal dwDoubleWord As Long) As Integer
    Call CopyMemory(HiWord, ByVal VarPtr(dwDoubleWord) + 2, 2)
End Function

Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim fwKeys As Integer, zDelta As Integer, sMsg As String
        Dim OldProc As Long
            OldProc = GetProp(hwnd, "OldProc")
            
    Select Case uMsg
    Case WM_MBUTTONDOWN
        sMsg = "The Wheel button is down!"
    Case WM_MBUTTONUP
        sMsg = "The Wheel button isn't down anymore!"
    Case WM_MBUTTONDBLCLK
        sMsg = "The Wheel button has been double-clicked!"
    Case WM_MOUSEWHEEL
        fwKeys = LoWord(wParam)
        zDelta = HiWord(wParam) / WHEEL_DELTA
'            frmMixer.Caption = zDelta
        CallByName OwnerObj, CallFunc, VbMethod, IIf(zDelta > 0, True, False)
        'sMsg = "Wheel rotated " & Abs(zDelta) & " ticks " & IIf(zDelta > 0, "forward!", "backward!")
        If (fwKeys And MK_LBUTTON) = MK_LBUTTON Then sMsg = sMsg & vbNewLine & "The left button was down!"
        If (fwKeys And MK_RBUTTON) = MK_RBUTTON Then sMsg = sMsg & vbNewLine & "The right button was down!"
        If (fwKeys And MK_SHIFT) = MK_SHIFT Then sMsg = sMsg & vbNewLine & "The shift key was down!"
        If (fwKeys And MK_CONTROL) = MK_CONTROL Then sMsg = sMsg & vbNewLine & "The ctrl key was down!"
        If (fwKeys And MK_MBUTTON) = MK_MBUTTON Then sMsg = sMsg & vbNewLine & "The Wheel button was down!"
'    If Len(sMsg) > 0 Then frmMixer.Caption = sMsg 'Debug.Print sMsg
'        If frmMain.Sets = True Then
'            If frmMain.SliderVol.Value < frmMain.vol.VolumeMin Then
'                'frmMain.SliderVol.Value = frmMain.vol.VolumeMin
'                frmMain.SliderVol.Value = frmMain.SliderVol.Value + 50
'                Exit Function
'            ElseIf frmMain.SliderVol.Value > frmMain.vol.VolumeMax Then
'                'frmMain.SliderVol.Value = frmMain.vol.VolumeMax
'                frmMain.SliderVol.Value = frmMain.SliderVol.Value - 50
'                Exit Function
'            ElseIf Not frmMain.SliderVol.Value < frmMain.vol.VolumeMin Or Not frmMain.SliderVol.Value > frmMain.vol.VolumeMax Then
'                frmMain.SliderVol.Value = frmMain.SliderVol.Value + zDelta * -1500
'            End If
'        Else
'            If frmMain.SliderVol.Value > frmMain.SliderVol.Min Then
'                frmMain.SliderVol.Value = frmMain.SliderVol.Value + 10
'                Exit Function
'            ElseIf frmMain.SliderVol.Value < frmMain.SliderVol.Max Then
'                frmMain.SliderVol.Value = frmMain.SliderVol.Value - 10
'                Exit Function
'            End If
'        End If
    Case WM_MOUSEHOVER
    
    Case WM_MOUSELEAVE
        
        Unhook HookWnd
            Exit Function
    End Select
'WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam)
WindowProc = CallWindowProc(OldProc, hwnd, uMsg, wParam, lParam)
End Function

Public Sub Hook(ByVal hwnd As Long)
        HookWnd = hwnd
    lpPrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
        SetProp hwnd, "OldProc", lpPrevWndProc
End Sub

Public Sub Unhook(Optional ByVal hwnd As Long)
            If HookWnd = 0 Then Exit Sub
                lpPrevWndProc = GetProp(hwnd, "OldProc")
    Call SetWindowLong(hwnd, GWL_WNDPROC, lpPrevWndProc)
        HookWnd = 0
        RemoveProp hwnd, "OldProc"
End Sub
