bang.ctl

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

VERSION 5.00
Begin VB.UserControl bang 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   Begin VB.Shape Shape2 
      BackStyle       =   1  'Opaque
      FillColor       =   &H00C0C0C0&
      FillStyle       =   0  'Solid
      Height          =   135
      Left            =   720
      Top             =   360
      Width           =   615
   End
   Begin VB.Shape Shape1 
      BackStyle       =   1  'Opaque
      FillColor       =   &H00C0C0C0&
      FillStyle       =   0  'Solid
      Height          =   555
      Left            =   360
      Top             =   360
      Width           =   135
   End
End
Attribute VB_Name = "bang"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'缺省属性值:
Const m_def_MovePos = 0
'属性变量:
Dim m_MovePos As Integer

Const m_def_RunState = 0

Dim m_RunState As eRunState

Dim t As Long '动画循环变量


'注意！不要删除或修改下列被注释的行！
'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
End Property

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

Public Property Let Sfillcolor(ByVal New_Sfillcolor As OLE_COLOR)
    Shape1.FillColor() = New_Sfillcolor
    Shape2.FillColor() = New_Sfillcolor
    PropertyChanged "Sfillcolor"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get MovePos() As Integer
    MovePos = m_MovePos
End Property

Public Property Let MovePos(ByVal New_MovePos As Integer)
    m_MovePos = New_MovePos
    PropertyChanged "MovePos"
End Property

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_MovePos = m_def_MovePos
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    UserControl.FillColor = PropBag.ReadProperty("FillColor", &H0&)
    Shape1.FillColor = PropBag.ReadProperty("Sfillcolor", &H0&)
    Shape2.FillColor = PropBag.ReadProperty("Sfillcolor", &H0&)
    m_MovePos = PropBag.ReadProperty("MovePos", m_def_MovePos)
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("FillColor", UserControl.FillColor, &H0&)
    Call PropBag.WriteProperty("Sfillcolor", Shape1.FillColor, &H0&)
    Call PropBag.WriteProperty("MovePos", m_MovePos, m_def_MovePos)
End Sub

Private Sub UserControl_Resize()
    Call ResizeDH
End Sub

Private Sub ResizeDH()
    On Error Resume Next
    
    If m_MovePos = 0 Then
       If UserControl.Height > UserControl.Width Then
         UserControl.Width = UserControl.Height
       Else
         UserControl.Height = UserControl.Width
       End If
       
        Shape1.Height = UserControl.Height
        Shape2.Width = UserControl.Height
        
        Shape1.Left = 0
        Shape1.Top = 0
        Shape1.Visible = True
        
        Shape2.Left = 0
        Shape2.Top = 0
        Shape2.Visible = False
    
    Else
       
        Shape1.Height = UserControl.Height \ 2
        Shape2.Height = Shape1.Height
        Shape2.Width = Shape1.Width
        
        Shape1.Left = 0
        Shape1.Top = UserControl.Height \ 2
        Shape1.Visible = True
        
        Shape2.Left = 0
        Shape2.Top = 0
        Shape2.Visible = False
        
    End If

End Sub

Public Sub TimerRun()
'static t as Long
If m_RunState = eRunState.Runing Then
   t = (t + 1) Mod 2
   If t = 0 Then
    Shape1.Visible = True
    Shape2.Visible = False
   Else
    Shape1.Visible = False
    Shape2.Visible = True
   End If
End If
End Sub