progressbar.ctl

漂亮的vb 程序

    m_BorderStyle = Value
    PropertyChanged "BorderStyle"
    Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,vbBlack
Public Property Get BorderColor() As OLE_COLOR
Attribute BorderColor.VB_Description = "Returns/sets the color to use when drawing the singe line border around the progress bar. (Only applies when BorderStyle = scSingle)"
Attribute BorderColor.VB_ProcData.VB_Invoke_Property = ";Appearance"
    BorderColor = m_BorderColor
End Property

Public Property Let BorderColor(ByVal Value As OLE_COLOR)
    m_BorderColor = ConvertColor(Value)
    PropertyChanged "BorderColor"
    Refresh
End Property

Private Sub UserControl_Hide()
    On Error Resume Next
    If m_lHBMP <> 0 Then DeleteObject m_lHBMP: m_lHBMP = 0
    If m_lHDC <> 0 Then DeleteDC m_lHDC: m_lHDC = 0
End Sub

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    On Error Resume Next
    m_Steps = m_def_Steps
    m_FromColor = ConvertColor(m_def_FromColor)
    m_ToColor = ConvertColor(m_def_ToColor)
    m_Value = m_def_Value
    m_BorderStyle = m_def_BorderStyle
    m_BorderColor = ConvertColor(m_def_BorderColor)
    m_Orientation = m_def_Orientation
    UserControl.BackColor = ConvertColor(m_def_BackColor)
    Refresh
End Sub

Private Sub UserControl_Paint()
    'Refresh
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    On Error Resume Next
    With PropBag
        m_Steps = .ReadProperty("Steps", m_def_Steps)
        m_FromColor = ConvertColor(.ReadProperty("FromColor", m_def_FromColor))
        m_ToColor = ConvertColor(.ReadProperty("ToColor", m_def_ToColor))
        m_Value = .ReadProperty("Value", m_def_Value)
        m_BorderStyle = .ReadProperty("BorderStyle", m_def_BorderStyle)
        m_BorderColor = ConvertColor(.ReadProperty("BorderColor", m_def_BorderColor))
        m_Orientation = .ReadProperty("Orientation", m_def_Orientation)
        UserControl.BackColor = ConvertColor(.ReadProperty("BackColor", m_def_BackColor))
    End With
    Refresh
End Sub

Private Sub UserControl_Resize()
    On Error Resume Next
    If m_lHBMP <> 0 Then DeleteObject m_lHBMP: m_lHBMP = 0
    If m_lHDC <> 0 Then DeleteDC m_lHDC: m_lHDC = 0
    Refresh
End Sub

Private Sub UserControl_Show()
    ' Refresh
End Sub

Private Sub UserControl_Terminate()
    On Error Resume Next
    If m_lHBMP <> 0 Then DeleteObject m_lHBMP: m_lHBMP = 0
    If m_lHDC <> 0 Then DeleteDC m_lHDC: m_lHDC = 0
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    On Error Resume Next
    With PropBag
        .WriteProperty "Steps", m_Steps, m_def_Steps
        .WriteProperty "FromColor", m_FromColor, m_def_FromColor
        .WriteProperty "ToColor", m_ToColor, m_def_ToColor
        .WriteProperty "Value", m_Value, m_def_Value
        .WriteProperty "BorderStyle", m_BorderStyle, m_def_BorderStyle
        .WriteProperty "BorderColor", m_BorderColor, m_def_BorderColor
        .WriteProperty "Orientation", m_Orientation, m_def_Orientation
        .WriteProperty "BackColor", UserControl.BackColor, m_def_BackColor
    End With
End Sub

Public Sub Refresh()
Attribute Refresh.VB_UserMemId = -550

    On Error GoTo ErrHandler
    
    Dim lBrush As Long
    Dim lPen As Long
    Dim r As RECT
    Dim sz As SIZE
    Dim mm As Long
    Dim i As Long
    Dim pt As POINTAPI
    Dim dStep As Double
    Dim dDelta(1 To 3) As Double
    Dim dColor(1 To 3) As Long
    
    Static amDoing As Boolean
    If amDoing Then Exit Sub
    amDoing = True
    
    With UserControl
    
        .AutoRedraw = True
    
        ' This section is used to create the initial bitmap
        ' and offscreen DC that's used. Only happens when
        ' the size changes or when the object is first created
        If m_lHDC = 0 Then
    
            ' always do drawings in pixels
            .ScaleMode = vbPixels
    
            RealizePalette .hdc
    
            m_lHDC = CreateCompatibleDC(.hdc)
            m_lHBMP = CreateCompatibleBitmap(.hdc, .ScaleWidth, .ScaleHeight)
    
            SelectObject m_lHDC, m_lHBMP
    
        End If
        
        ' Basically just to clear the drawing by painting the whole
        ' area, the background color.
        lPen = CreatePen(PS_SOLID, 1, BackColor)
        lBrush = CreateSolidBrush(BackColor)
        SelectObject m_lHDC, lPen
        SelectObject m_lHDC, lBrush
        Rectangle m_lHDC, 0, 0, .ScaleWidth, .ScaleHeight
        SelectObject m_lHDC, GetStockObject(NULL_PEN)
        SelectObject m_lHDC, GetStockObject(NULL_BRUSH)
        DeleteObject lPen
        DeleteObject lBrush
    
        ' This section is used to break down the FromColor
        ' into its constituent RGB values and to determine
        ' the amount of change to each R-G-B value, so that
        ' the color transition will be a smooth one.
        dColor(1) = FromColor And &HFF0000  ' Blue
        dColor(2) = FromColor And &HFF00&  ' Green
        dColor(3) = FromColor And &HFF& ' Red
        If dColor(1) > 0 Then dColor(1) = dColor(1) / &H10000
        If dColor(2) > 0 Then dColor(2) = dColor(2) / &H100&
        dDelta(1) = ToColor And &HFF0000
        dDelta(2) = ToColor And &HFF00&
        dDelta(3) = ToColor And &HFF&
        If dDelta(1) > 0 Then dDelta(1) = dDelta(1) / &H10000
        If dDelta(2) > 0 Then dDelta(2) = dDelta(2) / &H100&
        
        dDelta(1) = dDelta(1) - dColor(1)
        If dDelta(1) <> 0 Then dDelta(1) = dDelta(1) / 255&
        dDelta(2) = dDelta(2) - dColor(2)
        If dDelta(2) <> 0 Then dDelta(2) = dDelta(2) / 255&
        dDelta(3) = dDelta(3) - dColor(3)
        If dDelta(3) <> 0 Then dDelta(3) = dDelta(3) / 255&
        
        ' Set the map mode such that the height or width (based
        ' on orientation) is seen as 255 "units". In each unit or height
        ' or width, you'll draw one shade of the colors such that
        ' the color smoothly transitions from the "FromColor"
        ' to the "ToColor"
        mm = SetMapMode(m_lHDC, MM_ANISOTROPIC)
        If m_Orientation = ocB2T Or m_Orientation = ocT2B Then
            SetWindowExtEx m_lHDC, .ScaleWidth, 255, sz
            SetViewportExtEx m_lHDC, .ScaleWidth, .ScaleHeight, sz
        Else
            SetWindowExtEx m_lHDC, 255, .ScaleHeight, sz
            SetViewportExtEx m_lHDC, .ScaleWidth, .ScaleHeight, sz
        End If
        
        ' Determine just how many "units" each step should cover
        dStep = Min(Steps, 1) / 255&
        
        For i = 0 To 255
    
            If i * dStep > Value Or Value = 0 Then Exit For
    
            ' have to use a wide pen to avoid ugliness
            lPen = CreatePen(PS_SOLID, 3, RGB((dColor(3) + (dDelta(3) * i)) And &HFF&, _
                                              (dColor(2) + (dDelta(2) * i)) And &HFF&, _
                                              (dColor(1) + (dDelta(1) * i)) And &HFF&))
            SelectObject m_lHDC, lPen

            Select Case m_Orientation
            Case ocB2T
                MoveToEx m_lHDC, 0, Abs(256 - i), pt
                LineTo m_lHDC, .ScaleWidth, Abs(256 - i)
            Case ocT2B
                MoveToEx m_lHDC, 0, i - 1, pt
                LineTo m_lHDC, .ScaleWidth, i - 1
            Case ocR2L
                MoveToEx m_lHDC, Abs(256 - i), 0, pt
                LineTo m_lHDC, Abs(256 - i), .ScaleHeight
            Case Else ' ocL2R
                MoveToEx m_lHDC, i - 1, 0, pt
                LineTo m_lHDC, i - 1, .ScaleHeight
            End Select
    
            SelectObject m_lHDC, GetStockObject(NULL_PEN)
            DeleteObject lPen
            
        Next
        
        ' Return the map mode to original setting
        SetMapMode m_lHDC, mm
    
        ' put the border coords in a RECT structure
        SetRect r, 0&, 0&, .ScaleWidth, .ScaleHeight
    
        ' Draw the border (if any)
        Select Case (BorderStyle)
        Case scBump
            DrawEdge m_lHDC, r, EDGE_BUMP, BF_RECT
        Case scEtched
            DrawEdge m_lHDC, r, EDGE_ETCHED, BF_RECT
        Case scRaised
            DrawEdge m_lHDC, r, EDGE_RAISED, BF_RECT
        Case scSingle
            lBrush = CreateSolidBrush(BorderColor)
            SelectObject m_lHDC, lBrush
            FrameRect m_lHDC, r, lBrush
            SelectObject m_lHDC, GetStockObject(NULL_BRUSH)
            DeleteObject lBrush
        Case scSunken
            DrawEdge m_lHDC, r, EDGE_SUNKEN, BF_RECT
        Case Else ' StyleConstants.scNone
        End Select
    
        ' Make sure it refreshes the whole area
        InvalidateRect .hWnd, r, 0&

        ' Place the new drawing back into the UserControl
        BitBlt .hdc, 0&, 0&, .ScaleWidth, .ScaleHeight, _
            m_lHDC, 0&, 0&, SRCCOPY
        
        .AutoRedraw = False
        
    End With
    
    amDoing = False
    
Exit Sub
ErrHandler:

    amDoing = False

    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext

End Sub