Visual Basic Controls/Visual Basic Controls.iso/vbcontrol/weelactx/wheel.ctl

Visual Basic Form | 1997-09-25 | 10.0 KB | 296 lines

VERSION 5.00
Begin VB.UserControl Wheel
   ClientHeight    =   2160
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1035
   ScaleHeight     =   2160
   ScaleWidth      =   1035
   ToolboxBitmap   =   "Wheel.ctx":0000
   Begin VB.Image Image1
      Height          =   1650
      Left            =   0
      Picture         =   "Wheel.ctx":00FA
      Top             =   0
      Width           =   180
   End
Attribute VB_Name = "Wheel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
'Default Property Values:
Const m_def_Enabled = True
Const m_def_Style = 0
Const LIMIT = 1650
Const LO_LIMIT = LIMIT / 2 - 50
Const HI_LIMIT = LIMIT / 2 + 50
'Property Variables:
Dim m_Enabled As Boolean
Dim m_Style As Integer
'Event Declarations:
Event Wheel(Direction As Direction)
Public Enum Direction
    wheelUp = 0
    wheelDown
    wheelLeft
    wheelRight
End Enum
Public Enum WheelStyle
    wheelVertical = 0
    wheelHorizontal
End Enum
Private Counter As Integer
Private currY As Single
Private currX As Single
Private bCancel As Boolean
Private lDelay As Long
Private iDirection As Single
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
    Enabled = m_Enabled
End Property
Private Function GetResPic() As IPictureDisp
    If m_Style = wheelVertical Then
        Select Case Counter
            Case 0
                Set GetResPic = LoadResPicture(101, vbResBitmap)
            Case 1
                Set GetResPic = LoadResPicture(102, vbResBitmap)
            Case 2
                Set GetResPic = LoadResPicture(103, vbResBitmap)
            Case 3
                Set GetResPic = LoadResPicture(104, vbResBitmap)
        End Select
    Else
        Select Case Counter
            Case 0
                Set GetResPic = LoadResPicture(105, vbResBitmap)
            Case 1
                Set GetResPic = LoadResPicture(106, vbResBitmap)
            Case 2
                Set GetResPic = LoadResPicture(107, vbResBitmap)
            Case 3
                Set GetResPic = LoadResPicture(108, vbResBitmap)
        End Select
    End If
End Function
Public Property Get WheelStyle() As WheelStyle
    WheelStyle = m_Style
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
    m_Enabled = New_Enabled
    PropertyChanged "Enabled"
End Property
Public Property Let WheelStyle(ByVal New_Style As WheelStyle)
    m_Style = New_Style
    UserControl_Resize
End Property
Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If m_Enabled Then
        If Button = vbLeftButton Then
            currY = Y
            currX = X
        End If


        '*********
        If Button = vbRightButton Then
            If m_Style = wheelVertical Then
                If Y < LO_LIMIT Then
                    iDirection = 1
                    bCancel = False
                    lDelay = 3 * Y / Screen.TwipsPerPixelY
                ElseIf Y > HI_LIMIT Then
                    iDirection = -1
                    bCancel = False
                    lDelay = 3 * (LIMIT - Y) / Screen.TwipsPerPixelY
                End If

                Do Until bCancel

                        Counter = Counter + iDirection

                        If Counter > 3 Then
                            Counter = 0
                        End If

                        If Counter < 0 Then
                            Counter = 3
                        End If


                        Image1.Picture = GetResPic()
                        If iDirection = 1 Then
                            RaiseEvent Wheel(wheelUp)
                        ElseIf iDirection = -1 Then
                            RaiseEvent Wheel(wheelDown)
                        End If

                        DoEvents
                        Sleep lDelay
                Loop

            ElseIf m_Style = wheelHorizontal Then
                If X < LO_LIMIT Then
                    iDirection = -1
                    bCancel = False
                    lDelay = 3 * X / Screen.TwipsPerPixelX
                ElseIf X > HI_LIMIT Then
                    iDirection = 1
                    bCancel = False
                    lDelay = 3 * (LIMIT - X) / Screen.TwipsPerPixelX
                End If

                Do Until bCancel


                        Counter = Counter + iDirection

                        If Counter > 3 Then
                            Counter = 0
                        End If

                        If Counter < 0 Then
                            Counter = 3
                        End If


                        Image1.Picture = GetResPic()
                        If iDirection = 1 Then
                            RaiseEvent Wheel(wheelRight)
                        ElseIf iDirection = -1 Then
                            RaiseEvent Wheel(wheelLeft)
                        End If

                        DoEvents
                        Sleep lDelay
                Loop

            End If
        End If





    End If
End Sub
Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If m_Enabled Then
        If Button = vbLeftButton Then
            If m_Style = wheelVertical Then
                If Y < currY Then
                    currY = Y
                    Counter = Counter + 1
                    If Counter > 3 Then
                        Counter = 0
                    End If
                    Image1.Picture = GetResPic()
                    RaiseEvent Wheel(wheelUp)
                ElseIf Y > currY Then
                    currY = Y
                    Counter = Counter - 1
                    If Counter < 0 Then
                        Counter = 3
                    End If
                    Image1.Picture = GetResPic()
                    RaiseEvent Wheel(wheelDown)
                End If
            Else
                If X > currX Then
                    currX = X
                    Counter = Counter + 1
                    If Counter > 3 Then
                        Counter = 0
                    End If
                    Image1.Picture = GetResPic()
                    RaiseEvent Wheel(wheelRight)
                ElseIf X < currX Then
                    currX = X
                    Counter = Counter - 1
                    If Counter < 0 Then
                        Counter = 3
                    End If
                    Image1.Picture = GetResPic()
                    RaiseEvent Wheel(wheelLeft)
                End If
            End If
        End If

        'Continous scroll
        If Button = vbRightButton Then
            If m_Style = wheelVertical Then
                If Y < LO_LIMIT Then
                    lDelay = 3 * Y / Screen.TwipsPerPixelY
                    iDirection = 1
                ElseIf Y > HI_LIMIT Then
                    lDelay = 3 * (LIMIT - Y) / Screen.TwipsPerPixelY
                    iDirection = -1
                Else
                    iDirection = 0
                End If
            ElseIf m_Style = wheelHorizontal Then
                If X < LO_LIMIT Then
                    lDelay = 3 * X / Screen.TwipsPerPixelX
                    iDirection = -1
                ElseIf X > HI_LIMIT Then
                    lDelay = 3 * (LIMIT - X) / Screen.TwipsPerPixelX
                    iDirection = 1
                Else
                    iDirection = 0
                End If
            End If

            If lDelay < 5 Then
                lDelay = 5
            End If

        End If

    End If
End Sub
Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    bCancel = True
End Sub
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_Enabled = m_def_Enabled
    m_Style = m_def_Style
    Counter = 0
    Image1.Picture = GetResPic()
End Sub
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
    m_Style = PropBag.ReadProperty("Style", m_def_Style)
    Image1.ToolTipText = PropBag.ReadProperty("ToolTipText", "")
End Sub
Private Sub UserControl_Resize()
    Image1.Picture = GetResPic()
    With UserControl
        .Width = Image1.Width
        .Height = Image1.Height
    End With
End Sub
Private Sub UserControl_Show()
    UserControl_Resize
End Sub
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled)
    Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
    Call PropBag.WriteProperty("ToolTipText", Image1.ToolTipText, "")
End Sub
Public Sub About()
Attribute About.VB_UserMemId = -552
    MsgBox "Created by Jaroslaw Zwierz" & vbCr & _
        "[e-mail]" & vbCr & vbCr & _
        "(c)1997 by AVE Inc." & vbCr & _
        "Poland" & vbCr & vbCr & _
        "This control is a freeware." _
        , vbInformation, "Information"
End Sub