pressbar.ctl

来自「非常漂亮的VB控件」· CTL 代码 · 共 320 行

VERSION 5.00
Begin VB.UserControl NicePressBar 
   Alignable       =   -1  'True
   AutoRedraw      =   -1  'True
   BackColor       =   &H00E0E0E0&
   CanGetFocus     =   0   'False
   ClientHeight    =   2715
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   5310
   ScaleHeight     =   2715
   ScaleWidth      =   5310
   ToolboxBitmap   =   "PressBar.ctx":0000
   Begin VB.Label Lt 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "0%"
      ForeColor       =   &H00000000&
      Height          =   180
      Left            =   960
      TabIndex        =   0
      Top             =   0
      Width           =   180
   End
   Begin VB.Image PF 
      Height          =   255
      Left            =   15
      Picture         =   "PressBar.ctx":0312
      Stretch         =   -1  'True
      Top             =   0
      Width           =   1500
   End
   Begin VB.Shape Sh 
      BorderColor     =   &H00000000&
      FillColor       =   &H00E0E0E0&
      FillStyle       =   0  'Solid
      Height          =   255
      Left            =   0
      Shape           =   4  'Rounded Rectangle
      Top             =   0
      Width           =   2295
   End
End
Attribute VB_Name = "NicePressBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'缺省属性值:
'Const m_def_BorderStyle = 0
Const m_def_Style = 0
'Const m_def_BackColor = 0
Const m_def_Value = 0
Const m_def_Max = 100
Const m_def_Min = 0
'属性变量:
'Dim m_BorderStyle As Variant
Dim m_Style As Integer
'Dim m_BackColor As OLE_COLOR
Dim m_Value As Long
Dim m_Max As Long
Dim m_Min As Long
Private bN As Long
Public Enum BdStyle
    [Transparents ] = 0
    [Solid] = 1
    [Dash] = 2
    [Dot] = 3
    [Dash -Dot] = 4
    [Dash -Dot- Dot] = 5
    [Inside Solid] = 6
End Enum
Public Enum BackStyles
    [Transparents ] = 0
    [Solid] = 1
End Enum
Public Enum FillStyleS
    [Solid] = 0
    [Transparents] = 1
    [Horizontal line] = 2
    [Vertical Line] = 3
    [Upward Diagonal] = 4
    [DownWard Diagonal] = 5
    [Cross] = 6
    [Diagonal Cross] = 7
End Enum
Public Enum Shapes
    [Rectangle] = 0
    [Square] = 1
    [Oval] = 2
    [Circle] = 3
    [Rounded Rectangle] = 4
    [Rounded Square] = 5
End Enum
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long


'注意！不要删除或修改下列被注释的行！
'MemberInfo=8,0,0,0
Public Property Get Value() As Long
Attribute Value.VB_Description = "进度条的当前值"
    Value = m_Value
End Property

Public Property Let Value(ByVal New_Value As Long)
bN = UserControl.Width / Max
    m_Value = New_Value
    PF.Width = Value * bN
    Lt.Caption = Str(Value) & "%"
    Ptxt 1
    PropertyChanged "Value"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=8,0,0,100
Public Property Get Max() As Long
Attribute Max.VB_Description = "进度条的最大值"
    Max = m_Max
End Property

Public Property Let Max(ByVal New_Max As Long)
    m_Max = New_Max
    PropertyChanged "Max"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=8,0,0,0
Public Property Get Min() As Long
Attribute Min.VB_Description = "进度条的最小值"
    Min = m_Min
End Property

Public Property Let Min(ByVal New_Min As Long)
    m_Min = New_Min
    PropertyChanged "Min"
End Property

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_Value = m_def_Value
    m_Max = m_def_Max
    m_Min = m_def_Min
    
'    m_BackColor = m_def_BackColor
    m_Style = m_def_Style
'    m_BorderStyle = m_def_BorderStyle
End Sub

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

    m_Value = PropBag.ReadProperty("Value", m_def_Value)
    m_Max = PropBag.ReadProperty("Max", m_def_Max)
    m_Min = PropBag.ReadProperty("Min", m_def_Min)
'    m_BackColor = PropBag.ReadProperty("BackColor", m_def_BackColor)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    m_Style = PropBag.ReadProperty("Style", m_def_Style)
'    m_BorderStyle = PropBag.ReadProperty("BorderStyle", m_def_BorderStyle)
    Sh.BorderStyle = PropBag.ReadProperty("BorderStyle", 1)
    Sh.BackStyle = PropBag.ReadProperty("BackStyle", 0)
    Sh.BorderColor = PropBag.ReadProperty("BorderColor", -2147483647)
    Sh.BorderWidth = PropBag.ReadProperty("BorderWidth", 1)
    Sh.FillColor = PropBag.ReadProperty("FillColor", &H0&)
    Sh.FillStyle = PropBag.ReadProperty("FillStyle", 3)
    Sh.Shape = PropBag.ReadProperty("Shape", 4)
    Lt.ForeColor = PropBag.ReadProperty("ForeColor", &HFFFFFF)
    PF.Picture = LoadResPicture(3000 + m_Style, 0)
End Sub

Private Sub UserControl_Resize()
PF.Width = 0
PF.Left = 15
PF.Top = 15
PF.Height = UserControl.Height - 30
Sh.Height = UserControl.Height
Sh.Width = UserControl.Width
Lt.Top = UserControl.Height / 2 - Lt.Height / 2
Lt.Left = UserControl.Width / 2 - Lt.Width / 2
End Sub

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

    Call PropBag.WriteProperty("Value", m_Value, m_def_Value)
    Call PropBag.WriteProperty("Max", m_Max, m_def_Max)
    Call PropBag.WriteProperty("Min", m_Min, m_def_Min)
'    Call PropBag.WriteProperty("BackColor", m_BackColor, m_def_BackColor)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
'    Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, m_def_BorderStyle)
    Call PropBag.WriteProperty("BorderStyle", Sh.BorderStyle, 1)
    Call PropBag.WriteProperty("BackStyle", Sh.BackStyle, 0)
    Call PropBag.WriteProperty("BorderColor", Sh.BorderColor, -2147483647)
    Call PropBag.WriteProperty("BorderWidth", Sh.BorderWidth, 1)
    Call PropBag.WriteProperty("FillColor", Sh.FillColor, &H0&)
    Call PropBag.WriteProperty("FillStyle", Sh.FillStyle, 3)
    Call PropBag.WriteProperty("Shape", Sh.Shape, 4)
    Call PropBag.WriteProperty("ForeColor", Lt.ForeColor, &HFFFFFF)
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
    PropertyChanged "BackColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=14,0,0,0
Public Property Get Style() As MnuStyle
Attribute Style.VB_Description = "进度条样式"
    Style = m_Style
End Property

Public Property Let Style(ByVal New_Style As MnuStyle)
    m_Style = New_Style
    PF.Picture = LoadResPicture(3000 + m_Style, 0)
    PropertyChanged "Style"
End Property
'
'注意！不要删除或修改下列被注释的行！
'MappingInfo=Sh,Sh,-1,BorderStyle
Public Property Get BorderStyle() As BdStyle
Attribute BorderStyle.VB_Description = "返回/设置对象的边框样式。"
    BorderStyle = Sh.BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As BdStyle)
    Sh.BorderStyle() = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Sh,Sh,-1,BackStyle
Public Property Get BackStyle() As BackStyles
Attribute BackStyle.VB_Description = "指出 Label 或 Shape 的背景样式是透明的还是不透明的。"
    BackStyle = Sh.BackStyle
End Property

Public Property Let BackStyle(ByVal New_BackStyle As BackStyles)
    Sh.BackStyle() = New_BackStyle
    PropertyChanged "BackStyle"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Sh,Sh,-1,BorderColor
Public Property Get BorderColor() As OLE_COLOR
Attribute BorderColor.VB_Description = "返回/设置对象的边框颜色。"
    BorderColor = Sh.BorderColor
End Property

Public Property Let BorderColor(ByVal New_BorderColor As OLE_COLOR)
    Sh.BorderColor() = New_BorderColor
    PropertyChanged "BorderColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Sh,Sh,-1,BorderWidth
Public Property Get BorderWidth() As Integer
Attribute BorderWidth.VB_Description = "返回/设置控件的边框宽度。"
    BorderWidth = Sh.BorderWidth
End Property

Public Property Let BorderWidth(ByVal New_BorderWidth As Integer)
    Sh.BorderWidth() = New_BorderWidth
    PropertyChanged "BorderWidth"
End Property

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

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

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Sh,Sh,-1,FillStyle
Public Property Get FillStyle() As FillStyleS
Attribute FillStyle.VB_Description = "返回/设置一个 shape 控件的填充样式。"
    FillStyle = Sh.FillStyle
End Property

Public Property Let FillStyle(ByVal New_FillStyle As FillStyleS)
    Sh.FillStyle() = New_FillStyle
    PropertyChanged "FillStyle"
End Property


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

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    Lt.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property

Private Sub Ptxt(Value As Integer)
Dim tRect As RECT
tRect.Left = Lt.Left
tRect.Top = Lt.Top
tRect.Bottom = Lt.Left + Lt.Height
tRect.Left = Lt.Left + Lt.Width
DrawText UserControl.hdc, Lt.Caption, Len(Lt.Caption), tRect, 0
End Sub