wheeltrack.frm

利用VB及API控制鼠标的滚轮行为

End Sub

Sub WheelAction(hClient As Long, wParam)
Dim iKey As Integer
Dim iDir As Integer

'===============================================================
' We get wheel direction (left half of wParams)
' and Keys pressed while 'wheeling' (right half of wParams)
'===============================================================
iKey = CInt("&H" & (Right(Hex(wParam), 4)))
iDir = Sgn(wParam \ 32767)
                
'========================================================
' Generic code to get mouse buttons and keys information
'========================================================
'If iKey And MK_LBUTTON Then    - Left Button code -
'If iKey And MK_RBUTTON Then    - Right Button code -
'If iKey And MK_MBUTTON Then    - Middle Button code -

'If iKey And MK_SHIFT Then      - ShiftKey code -
'If iKey And MK_CONTROL Then    - ControlKey code -

Select Case hClient
    Case Picture1.hwnd
        '========================================================
        ' CtrlKey used to change scroll to be modified:
        ' on => Scroll_H  off => Scroll_V
        '========================================================
        
        If iKey And MK_CONTROL Then
            '============================
            ' ShiftKey used as multiplier
            '============================
            If iKey And MK_SHIFT Then
                m_sScaleValue_H = m_sScaleValue_H + iDir * m_sScaleMultiplier_H
            Else
                 m_sScaleValue_H = m_sScaleValue_H + iDir
            End If
            
            '============================
            ' Check limits
            '============================
            If m_sScaleValue_H <= m_sScaleMin_H Then m_sScaleValue_H = m_sScaleMin_H
            If m_sScaleValue_H >= m_sScaleMax_H Then m_sScaleValue_H = m_sScaleMax_H
        
            Picture3.Left = Picture1.Left + Picture1.Width - m_sCurOffset - m_sScaleValue_H * (Picture1.Width / m_sScaleMax_H)
        Else
            '============================
            ' CtrlKey used as multiplier
            '============================
            If iKey And MK_SHIFT Then
                m_sScaleValue_V = m_sScaleValue_V + iDir * m_sScaleMultiplier_V
            Else
                 m_sScaleValue_V = m_sScaleValue_V + iDir
            End If
            
            '============================
            ' Check limits
            '============================
            If m_sScaleValue_V <= m_sScaleMin_V Then m_sScaleValue_V = m_sScaleMin_V
            If m_sScaleValue_V >= m_sScaleMax_V Then m_sScaleValue_V = m_sScaleMax_V
        
            Picture2.Top = Picture1.Top + Picture1.Height - m_sCurOffset - m_sScaleValue_V * (Picture1.Height / m_sScaleMax_V)
        End If
        
    Case Text1.hwnd
        '================================
        ' CtrlKey used as 100x multiplier
        ' ShiftKey used as 10x multiplier
        '================================
        If iKey And MK_CONTROL Then
            m_lSampleValue = m_lSampleValue + m_lWalkWay * iDir * m_lMutiplier_Large
            
        ElseIf iKey And MK_SHIFT Then
            m_lSampleValue = m_lSampleValue + m_lWalkWay * iDir * m_lMutiplier_Small
            
        Else
            m_lSampleValue = m_lSampleValue + m_lWalkWay * iDir
            
        End If
        
        Text1 = Trim(Str(m_lSampleValue))
    
    
'    Case Your_Next_Hwnd
        '
        '
'    Case Your_Last_Hwnd
        
End Select


End Sub

Sub initialize()
Dim i As Integer

'=================================
' Mouse section : check for wheel
'=================================
    m_blnWheelPresent = GetSystemMetrics(SM_MOUSEWHEELPRESENT)



'********************************************
' Begin Custom section
'
'********************************************

'================================================
' Drawing cursor shapes in picture2 and picture3
'================================================

Picture1.Move 240, 240, 3015, 1935

Picture1.ScaleMode = vbPixels
Picture1.AutoRedraw = True

For i = 255 To 0 Step -1
    Picture1.Line ((Picture1.ScaleWidth / 255) * i, (Picture1.ScaleHeight / 255) * i)- _
                  (Picture1.ScaleWidth, Picture1.ScaleHeight), _
                   RGB(i, i / 2, i / 2), B
Next i


With Picture2               '   Right cursor
    .AutoRedraw = True
    .Appearance = 0
    .BorderStyle = 0
    .BackColor = &H8000000F
    .ScaleMode = vbPixels
    .Height = 225
    .Left = Picture1.Left + Picture1.Width
    .Width = 225
End With

With Picture3               '   Bottom cursor
    .AutoRedraw = True
    .Appearance = 0
    .BorderStyle = 0
    .BackColor = &H8000000F
    .ScaleMode = vbPixels
    .Height = 225
    .Top = Picture1.Top + Picture1.Height
    .Width = 225
End With


For i = 0 To 7
    Picture2.Line (i, 7 - i)-(i, 7 + i)
    Picture3.Line (7 - i, i)-(7 + i, i)
Next i



'================================
' Picture1  PseudoScrolls section
'================================
    
    m_sScaleMultiplier_H = 10
    m_sScaleMax_H = 150
    m_sScaleMin_H = 0
    m_sScaleValue_H = m_sScaleMax_H / 2
    
    m_sScaleMultiplier_V = 10
    m_sScaleMax_V = 100
    m_sScaleMin_V = 0
    m_sScaleValue_V = m_sScaleMax_V / 2

    Picture2.Top = Picture1.Top + Picture1.Height - m_sCurOffset - m_sScaleValue_V * (Picture1.Height / m_sScaleMax_V)
    Picture3.Left = Picture1.Left + Picture1.Width - m_sCurOffset - m_sScaleValue_H * (Picture1.Width / m_sScaleMax_H)

'=========================
' Text1 section
'=========================
    m_lWalkWay = m_WheelForward
    m_lMutiplier_Small = 10
    m_lMutiplier_Large = 100
    m_lSampleValue = 100
    
    Text1.Move 3720, 240
    Text1 = Trim(Str(m_lSampleValue))



'=========================
' ToolTipText section
'=========================
Picture1.ToolTipText = "Ctrl = Scroll Horizontal  Shift = 10x speed "
Text1.ToolTipText = "Click to enable   Ctrl = 100x   Shift = 10x   Return to validate Keyboad value entry"

End Sub

Private Sub Form_Click()

m_blnKeepSpinnig = False
DoEvents

End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

m_blnKeepSpinnig = False
DoEvents

If m_blnWheelPresent Then
    If Not m_blnWheelTracking Then Call WatchForWheel(Picture1.hwnd)
End If

End Sub

Private Sub Text1_Click()

'**********************************************************
'   if blnWheelArround is set to 'True', we can
'   spin value even mouse away from text box
'   but it seems to be difficult to use any other
'   application (in fact we have to 'Ctrl-Alt-Del' VB to stop
'   if we try to activate other apps)
'
'   - if U know how to make it safe, please let me know -
'
'**********************************************************

If m_blnWheelPresent Then
    If Not m_blnWheelTracking Then Call WatchForWheel(Text1.hwnd, False)
End If

End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)

'=================================================
'   Kills "No Default Key" Error beep when
'   Keying 'Return' to validate new  keyboard value
'=================================================

If KeyAscii = vbKeyReturn Then KeyAscii = 0

End Sub

Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)

    If KeyCode = vbKeyReturn Then
        On Error Resume Next
            m_lSampleValue = CLng(Text1.Text)
    End If

End Sub

Private Sub Text1_LostFocus()

m_blnKeepSpinnig = False
DoEvents

End Sub

Private Sub Form_Load()
initialize
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

m_blnKeepSpinnig = False
m_blnWheelTracking = False

     DoEvents

End Sub

Private Sub Form_Unload(Cancel As Integer)

m_blnKeepSpinnig = False
m_blnWheelTracking = False

     DoEvents

End Sub