flatprogressbar.ctl

超经典的打印预览动态库源码 版权： 本资源版权归作者所有 说明： 本资源由源码天空搜集,仅提供学习参考

VERSION 5.00
Begin VB.UserControl flatProgressBar 
   BackStyle       =   0  '透明
   ClientHeight    =   300
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2790
   DrawMode        =   15  'Merge Pen Not
   ScaleHeight     =   300
   ScaleWidth      =   2790
   ToolboxBitmap   =   "flatProgressBar.ctx":0000
   Begin VB.PictureBox picBoard 
      AutoRedraw      =   -1  'True
      Height          =   285
      Left            =   0
      ScaleHeight     =   225
      ScaleWidth      =   2700
      TabIndex        =   0
      Top             =   0
      Width           =   2760
   End
End
Attribute VB_Name = "flatProgressBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Option Explicit
'缺省属性值:
Const m_def_Style = 1
Const m_def_ForeColor = 0
Const m_def_Value = 0
Const m_def_Max = 100
Const m_def_Min = 0
'属性变量:
Dim m_Style As Boolean
Dim m_ForeColor As OLE_COLOR
Dim m_Value As Integer
Dim m_Max As Integer
Dim m_Min As Integer

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

'注意！不要删除或修改下列被注释的行！
'MappingInfo=picboard,picboard,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
    BackColor = picBoard.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    picBoard.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property


'注意！不要删除或修改下列被注释的行！
'MappingInfo=picboard,picboard,-1,Font
Public Property Get Font() As Font
    Set Font = picBoard.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set picBoard.Font = New_Font
    PropertyChanged "Font"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=picboard,picboard,-1,BorderStyle
Public Property Get BorderStyle() As Integer
    BorderStyle = picBoard.BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    picBoard.BorderStyle() = New_BorderStyle
    PropertyChanged "BorderStyle"
    picBoard.Cls
    Call drawBorder
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=picboard,picboard,-1,Refresh
Public Sub Refresh()
    picBoard.Refresh
End Sub

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

Public Property Let Value(ByVal New_Value As Integer)
Dim mRed As Integer
Dim mYellow As Integer
Dim mBlue As Integer
    If New_Value > Me.Max Or New_Value < Me.Min Then
        New_Value = m_Value
    End If
    m_Value = New_Value
    PropertyChanged "Value"
    '--------// paint the picture box with new value
    Dim i As Long
    Dim iValue As Integer
    Dim lColor As Long
    lColor = Me.ForeColor
    mRed = GetColor(lColor, 1)
    mYellow = GetColor(lColor, 2)
    mBlue = GetColor(lColor, 3)
    picBoard.Cls
    
    If Me.BorderStyle = 0 Then
        If Me.Style Then            '---// this means it is horizon
            For i = 0 To (picBoard.width * New_Value) / 50 / Max - 1
                '---// use the scumble color
                iValue = i * 50 * Max / picBoard.width
                picBoard.ForeColor = RGB(mRed - iValue * (mRed / 2) / Max, mYellow - iValue * (mYellow / 2) / Max, mBlue - iValue * (mBlue / 2) / Max)
                picBoard.Line (i * 50 + 10, 20)-Step(50, picBoard.height - 40), , BF
            Next i
        Else                        '---// this means it is vertical
            For i = 0 To (picBoard.height * New_Value) / 50 / Max - 1
                '---// use the scumble color
                iValue = i * 50 * Max / picBoard.height
                picBoard.ForeColor = RGB(mRed - iValue * (mRed / 2) / Max, mYellow - iValue * (mYellow / 2) / Max, mBlue - iValue * (mBlue / 2) / Max)
                picBoard.Line (20, picBoard.height - i * 50 - 30)-Step(picBoard.width - 40, -50), , BF
            Next i
        End If
        Call drawBorder
    Else
        If Me.Style Then            '---// this means it is horizon
            For i = 0 To (picBoard.width * New_Value) / 50 / Max - 2
                '---// use the scumble color
                iValue = i * 50 * Max / picBoard.width
                picBoard.ForeColor = RGB(mRed - iValue * (mRed / 2) / Max, mYellow - iValue * (mYellow / 2) / Max, mBlue - iValue * (mBlue / 2) / Max)
                picBoard.Line (i * 50, 0)-Step(50, picBoard.height), , BF
            Next i
        Else                        '---// this means it is vertical
            For i = 0 To (picBoard.height * New_Value) / 50 / Max
                '---// use the scumble color
                iValue = i * 50 * Max / picBoard.height
                picBoard.ForeColor = RGB(mRed - iValue * (mRed / 2) / Max, mYellow - iValue * (mYellow / 2) / Max, mBlue - iValue * (mBlue / 2) / Max)
                picBoard.Line (0, picBoard.height - i * 50)-Step(picBoard.width, -50), , BF
            Next i
        End If
    End If
    '---// draw the text in picturebox
    picBoard.ForeColor = vbWhite
    Dim mstr As String
    mstr = CInt(100 * Value / Max) & "%"
    lColor = TextOut(picBoard.hdc, (picBoard.width - GetWidth(mstr, picBoard.Font.Size)) / 30, (picBoard.height - GetHeight(picBoard.Font.Size)) / 30 - 1.5, mstr, GetLen(mstr))
    '---// refresh
    picBoard.Refresh
End Property


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

Public Property Let Max(ByVal New_Max As Integer)
    If New_Max > 1 And New_Max > Me.Min And New_Max < 10000 Then
        m_Max = New_Max
        PropertyChanged "Max"
    End If
End Property

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

Public Property Let Min(ByVal New_Min As Integer)
    If New_Min > 0 And New_Min < Me.Max And New_Min < 10000 Then
        m_Min = New_Min
        PropertyChanged "Min"
    End If
End Property

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

Private Sub UserControl_Paint()
    picBoard.Cls
    Call drawBorder
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    picBoard.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    Set picBoard.Font = PropBag.ReadProperty("Font", Ambient.Font)
    picBoard.BorderStyle = PropBag.ReadProperty("BorderStyle", 1)
    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_ForeColor = PropBag.ReadProperty("ForeColor", m_def_ForeColor)
    m_Style = PropBag.ReadProperty("Style", m_def_Style)
End Sub

Private Sub UserControl_Resize()
'---------------------// make the picturebox fit the contain
    picBoard.width = UserControl.width
    picBoard.height = UserControl.height
    picBoard.Cls
    Call drawBorder
    Call drawText
End Sub

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

    Call PropBag.WriteProperty("BackColor", picBoard.BackColor, &H8000000F)
    Call PropBag.WriteProperty("Font", picBoard.Font, Ambient.Font)
    Call PropBag.WriteProperty("BorderStyle", picBoard.BorderStyle, 1)
    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("ForeColor", m_ForeColor, m_def_ForeColor)
    Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
End Sub

Private Function GetColor(mColor As Long, mType As Integer) As Integer
'-----------// get the heft of color
Dim mRed As Long
Dim mYellow As Long
Dim mBlue As Long
Dim s As Double
    s = mColor / 65536
    mBlue = CInt(s)
    If mBlue > s Then
        mBlue = mBlue - 1
    End If
    s = (mColor - mBlue * 65536) / 256
    mYellow = CInt(s)
    If mYellow > s Then
        mYellow = mYellow - 1
    End If
    s = mColor - mBlue * 65536 - mYellow * 256
    mRed = CInt(s)
    If mRed > s Then
        mRed = mRed - 1
    End If
    Select Case mType
        Case 1      '---------// the red heft
            GetColor = mRed
        Case 2      '---------// the yellow heft
            GetColor = mYellow
        Case 3      '---------// the blue heft
            GetColor = mBlue
    End Select
End Function

'注意！不要删除或修改下列被注释的行！
'MemberInfo=10,0,0,0
Public Property Get ForeColor() As OLE_COLOR
    ForeColor = m_ForeColor
End Property

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

Private Sub drawBorder()
    If Me.BorderStyle = 0 Then
        picBoard.ForeColor = &H808080
        picBoard.Line (0, 5)-Step(picBoard.width, 0)
        picBoard.Line (0, 5)-Step(0, picBoard.height)
        picBoard.ForeColor = vbWhite
        picBoard.Line (picBoard.width - 10, 0)-Step(0, picBoard.height)
        picBoard.Line (0, picBoard.height - 10)-Step(picBoard.width, 0)
    End If
End Sub

Private Sub drawText()
Dim l As Long
Dim mstr As String
    picBoard.ForeColor = Me.ForeColor
    mstr = "flatProgressBar"
    l = TextOut(picBoard.hdc, (picBoard.width - GetWidth(mstr, Me.Font.Size)) / 30, (picBoard.height - GetHeight(Me.Font.Size)) / 30, mstr, Len(mstr))
End Sub

Private Function GetWidth(mstr As String, fontsize As Single) As Single
'-----------get the width of string in screen or printer
Dim i As Integer
    GetWidth = 0
    For i = 1 To Len(mstr)
        If Asc(Mid(mstr, i, 1)) < 0 Then
            GetWidth = GetWidth + fontsize * 20
        Else
            GetWidth = GetWidth + fontsize * 10
        End If
    Next i
End Function

Private Function GetHeight(fontsize As Single) As Single
'-----------get the height of string in screen or printer
    GetHeight = fontsize * 20
End Function

Private Function GetLen(mstr As String) As Integer
'----------------get the unicode length of string
'----------------every chinese char be 2 length
'----------------every english char be 1 length
'----------------the ascii value of chinese char must <0
'----------------the ascii value of english char must >=0
Dim i As Integer
    GetLen = 0
    For i = 1 To Len(mstr)
        If Asc(Mid(mstr, i, 1)) < 0 Then
            GetLen = GetLen + 2
        Else
            GetLen = GetLen + 1
        End If
    Next i
End Function
'注意！不要删除或修改下列被注释的行！
'MemberInfo=0,0,0,0
Public Property Get Style() As Boolean
    Style = m_Style
End Property

Public Property Let Style(ByVal New_Style As Boolean)
    m_Style = New_Style
    PropertyChanged "Style"
End Property