bts.ctl

这是一个实际的工程中所用的源程序

VERSION 5.00
Begin VB.UserControl Bts 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   2610
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   FillColor       =   &H00C0C000&
   ScaleHeight     =   2610
   ScaleWidth      =   4800
   Begin VB.Image ImgR 
      Height          =   240
      Left            =   2520
      Picture         =   "Bts.ctx":0000
      Top             =   2040
      Width           =   240
   End
   Begin VB.Image ImgL 
      Height          =   240
      Left            =   1920
      Picture         =   "Bts.ctx":00D6
      Top             =   2160
      Width           =   240
   End
   Begin VB.Image ImgDh 
      Height          =   90
      Left            =   1080
      Picture         =   "Bts.ctx":01AA
      Top             =   1080
      Width           =   150
   End
   Begin VB.Image ImgU 
      Height          =   240
      Left            =   1560
      Picture         =   "Bts.ctx":02AC
      Top             =   1560
      Width           =   240
   End
   Begin VB.Image ImgD 
      Height          =   240
      Left            =   960
      Picture         =   "Bts.ctx":038A
      Top             =   1680
      Width           =   240
   End
   Begin VB.Shape ShpRgt 
      BackStyle       =   1  'Opaque
      FillColor       =   &H00C0C0C0&
      FillStyle       =   0  'Solid
      Height          =   150
      Left            =   3150
      Shape           =   2  'Oval
      Top             =   840
      Width           =   150
   End
   Begin VB.Shape ShpLeft 
      BackStyle       =   1  'Opaque
      FillColor       =   &H00C0C0C0&
      FillStyle       =   0  'Solid
      Height          =   150
      Left            =   720
      Shape           =   2  'Oval
      Top             =   840
      Width           =   150
   End
End
Attribute VB_Name = "Bts"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Enum eOrientation
    Horizontal = -1
    Vertical = 0
End Enum
Public Enum eArrow
    forward = -1
    back = 0
End Enum
Public Enum eRunState
    Runing = -1
    Stoped = 0
End Enum
Const m_def_Orientation = -1
Const m_def_Arrow = -1
Const m_def_RunState = 0

Dim m_Orientation As eOrientation
Dim m_Arrow As eArrow
Dim m_RunState As eRunState

'
Dim ArrowMod As Long '部署
Dim RunWidth As Long '步长
Dim Left1 As Long
Dim Top1 As Long
Dim t As Long '动画循环变量
'注意！不要删除或修改下列被注释的行！
'MemberInfo=14,0,0,0
Public Property Get Orientation() As eOrientation
    Orientation = m_Orientation
End Property

Public Property Let Orientation(ByVal New_Orientation As eOrientation) '方向改变
    m_Orientation = New_Orientation
    Call ResizeDH
    PropertyChanged "Orientation"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=8,0,0,0
Public Property Get Arrow() As eArrow
    Arrow = m_Arrow
End Property

Public Property Let Arrow(ByVal New_Arrow As eArrow) '运动方向
    m_Arrow = New_Arrow
    Call ResizeDH
    PropertyChanged "Arrow"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=14,0,0,0
Public Property Get RunState() As eRunState
    RunState = m_RunState
End Property

Public Property Let RunState(ByVal New_RunState As eRunState) '运动
    m_RunState = New_RunState
    'ImgDh.Visible = m_RunState '使可视
End Property

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    m_Orientation = PropBag.ReadProperty("Orientation", m_def_Orientation)
    m_Arrow = PropBag.ReadProperty("Arrow", m_def_Arrow)
    
    RunWidth = 150 'ImgD.Width \ 144 '=24*2*3
        ShpLeft.Left = 0
        ShpLeft.Top = 0
    If m_Arrow = eArrow.forward Then
        ArrowMod = 12
    Else
        ArrowMod = 9
    End If
'    imgDH.Left = 0: imgDH.Top = 0
    If m_Orientation = eOrientation.Horizontal Then
        ImgDh.Picture = ImgD.Picture
    Else
        ImgDh.Picture = ImgU.Picture
    End If
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &HC0C0C0)
'    ImgDh.Visible = m_RunState
    If UserControl.BackColor <> ColorGray Then
        ImgDh.Visible = True '使可视
    Else
        ImgDh.Visible = False '使可视
    End If
    UserControl.FillColor = PropBag.ReadProperty("FillColor", &HC0C0C0) ' &H0&)
    ShpLeft.FillColor = PropBag.ReadProperty("Lfillcolor", &HC0C0C0)
    ShpRgt.FillColor = PropBag.ReadProperty("Rfillcolor", &HC0C0C0)
End Sub
Private Sub ResizeDH()
    On Error Resume Next
    
    If m_Orientation = eOrientation.Horizontal Then '水平

        If m_Arrow = eArrow.forward Then
            ImgDh.Picture = ImgL.Picture
            Left1 = 200
            ImgDh.Left = Left1
        Else
            ImgDh.Picture = ImgR.Picture
            Left1 = UserControl.Width - 350
            ImgDh.Left = Left1
        End If
        
        ImgDh.Top = (UserControl.ScaleHeight - ImgDh.Height) / 2
'        ImgDh.Visible = True
        
        ShpLeft.Height = UserControl.ScaleHeight
        
        ShpRgt.Left = UserControl.ScaleWidth - 150
        ShpRgt.Top = 0
        ShpRgt.Height = UserControl.ScaleHeight
        
    Else '垂直

        If m_Arrow = eArrow.forward Then
            ImgDh.Picture = ImgU.Picture
            Top1 = 200
            ImgDh.Top = Top1
        Else
            ImgDh.Picture = ImgD.Picture
            Top1 = UserControl.Height - 350
            ImgDh.Top = Top1
        End If

        ImgDh.Left = (UserControl.ScaleWidth - ImgDh.Width) / 2

        ShpLeft.Width = UserControl.ScaleWidth
        
        ShpRgt.Left = 0
        ShpRgt.Top = UserControl.ScaleHeight - 150
        ShpRgt.Width = UserControl.ScaleWidth

    End If
End Sub
Private Sub UserControl_Resize()
    If m_Orientation = eOrientation.Horizontal Then '水平
        UserControl.Height = 150 'ImgD.Height
    Else '垂直
        UserControl.Width = 150 ' imgu.Width
    End If
    Call ResizeDH
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("Orientation", m_Orientation, m_def_Orientation)
    Call PropBag.WriteProperty("Arrow", m_Arrow, m_def_Arrow)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &HC0C0C0)
    Call PropBag.WriteProperty("FillColor", UserControl.FillColor, &HC0C0C0) '&H0&)
    Call PropBag.WriteProperty("Lfillcolor", ShpLeft.FillColor, &HC0C0C0)
    Call PropBag.WriteProperty("Rfillcolor", ShpRgt.FillColor, &HC0C0C0)
End Sub
Public Sub TimerRun()
'static t as Long
If m_RunState = eRunState.Runing Then
   t = (t + 1) Mod ArrowMod
   If m_Orientation = eOrientation.Horizontal Then
       If m_Arrow = eArrow.forward Then
           ImgDh.Left = Left1 + t * RunWidth
       Else
           ImgDh.Left = Left1 - t * RunWidth
       End If
   Else
       If m_Arrow = eArrow.forward Then
           ImgDh.Top = Top1 + t * RunWidth
       Else
           ImgDh.Top = Top1 - t * RunWidth
       End If
   End If
End If
End Sub
'

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "返回/设置对象中文本和图形的背景色。"
    BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    UserControl.BackColor() = New_BackColor
    If UserControl.BackColor <> ColorGray Then
        ImgDh.Visible = True '使可视
    Else
        ImgDh.Visible = False '使可视
    End If
    PropertyChanged "BackColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=UserControl,UserControl,-1,FillColor
Public Property Get FillColor() As OLE_COLOR
Attribute FillColor.VB_Description = "返回/设置填充形状、圆环和方框所使用的颜色。"
    FillColor = UserControl.FillColor
End Property

Public Property Let FillColor(ByVal New_FillColor As OLE_COLOR)
    UserControl.FillColor() = New_FillColor
    PropertyChanged "FillColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=ShpLeft,ShpLeft,-1,FillColor
Public Property Get Lfillcolor() As OLE_COLOR
Attribute Lfillcolor.VB_Description = "返回/设置填充形状、圆环和方框所使用的颜色。"
    Lfillcolor = ShpLeft.FillColor
End Property

Public Property Let Lfillcolor(ByVal New_Lfillcolor As OLE_COLOR)
    ShpLeft.FillColor() = New_Lfillcolor
    PropertyChanged "Lfillcolor"
End Property
'

'注意！不要删除或修改下列被注释的行！
'MappingInfo=ShpRgt,ShpRgt,-1,FillColor
Public Property Get Rfillcolor() As OLE_COLOR
Attribute Rfillcolor.VB_Description = "返回/设置填充形状、圆环和方框所使用的颜色。"
    Rfillcolor = ShpRgt.FillColor
End Property

Public Property Let Rfillcolor(ByVal New_Rfillcolor As OLE_COLOR)
    ShpRgt.FillColor() = New_Rfillcolor
    PropertyChanged "Rfillcolor"
End Property