captionbar.ctl

人事档案管理系统(PB)/人事工资管理系统/干部信息管理系统/投标报价与合同管理系统/... 超市...

VERSION 5.00
Begin VB.UserControl CaptionBar 
   Alignable       =   -1  'True
   ClientHeight    =   855
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   5790
   ScaleHeight     =   57
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   386
End
Attribute VB_Name = "CaptionBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const mcstrMod$ = "CaptionBar"

'Default Property Values:
Const m_def_SubCaptionForeColor = vbWindowText
Const m_def_Caption = "Cool Caption"
Const m_def_ActiveAsButton = False
Const m_def_SubCaption = ""
Const m_def_CaptionBackColor = vbButtonShadow
Const m_def_Border = 0
Const m_TextBorder = 3

'Property Variables:
Dim m_SubCaptionForeColor As OLE_COLOR
Dim m_SubCaptionFont As Font
Dim m_Caption As String
Dim m_SubCaption As String
Dim m_Picture As Picture
Dim m_CaptionBackColor As OLE_COLOR
Dim m_Border As Long

Private Sub UserControl_Paint()
    On Error GoTo Err_UserControl_Paint
        
    Dim hBr As Long, rc As RECT, rc2 As RECT
    Dim iTextHeight As Integer, iTextWidth As Integer
    Dim m_fnt As IFont, hFontOld As Long
    Dim cMemDC As New cMemDC
    
    
    GetClientRect hwnd, rc
    'create a memory DC to stop flickering.
    cMemDC.Create rc.right - rc.Left, rc.bottom - rc.Top
    SetBkMode cMemDC.hDC, TRANSPARENT
    hBr = CreateSolidBrush(TranslateColor(BackColor))
    FillRect cMemDC.hDC, rc, hBr
    DeleteObject hBr
    Draw3dRect cMemDC.hDC, rc, &H80000014, vbButtonShadow
    
    InflateRect rc, -m_Border, -m_Border
    
    hBr = CreateSolidBrush(TranslateColor(m_CaptionBackColor))
    FillRect cMemDC.hDC, rc, hBr
    DeleteObject hBr
    
    With UserControl
        iTextWidth = .TextWidth(m_Caption)
        iTextHeight = .TextHeight(m_Caption)
        
        rc2.Left = m_Border + m_TextBorder * 2
        rc2.Top = m_Border + m_TextBorder
        rc2.bottom = rc.bottom
        rc2.right = rc2.Left + iTextWidth
        
        Set m_fnt = UserControl.Font
        hFontOld = SelectObject(cMemDC.hDC, m_fnt.hFont)
        SetTextColor cMemDC.hDC, TranslateColor(ForeColor)
        DrawText cMemDC.hDC, Caption, -1, rc2, DT_CENTER Or DT_BOTTOM
        SelectObject cMemDC.hDC, hFontOld
        
        If SubCaption <> vbNullString Then
            Set m_fnt = m_SubCaptionFont
            rc2.Left = m_Border + m_TextBorder * 2 + iTextWidth + 5
            rc2.Top = m_Border + m_TextBorder
            rc2.bottom = rc.bottom - 2
            rc2.right = rc.right
            hFontOld = SelectObject(cMemDC.hDC, m_fnt.hFont)
            SetTextColor cMemDC.hDC, TranslateColor(SubCaptionForeColor)
            DrawText cMemDC.hDC, SubCaption, -1, rc2, DT_SINGLELINE Or DT_LEFT Or DT_BOTTOM
            SelectObject cMemDC.hDC, hFontOld
        End If
        InflateRect rc, m_Border, m_Border
        If Not m_Picture Is Nothing Then
            If m_Picture <> 0 Then
                With m_Picture
                    DrawIconEx cMemDC.hDC, rc.right - UserControl.ScaleX(.width - 2, 8, 3), 1, _
                        .handle, UserControl.ScaleX(.width, 8, 3), _
                        IIf(UserControl.ScaleY(.height, 8, 3) > rc.bottom - 2, rc.bottom - 2, _
                        UserControl.ScaleY(.height, 8, 3)), _
                        0&, 0&, DI_NORMAL
                End With
            End If
        End If
        BitBlt .hDC, 0, 0, rc.right - rc.Left, rc.bottom - rc.Top, _
            cMemDC.hDC, 0, 0, vbSrcCopy
    End With
    
    Exit Sub
Err_UserControl_Paint:
    ErrorMsg Err.Number, Err.Description, "UserControl_Paint", mcstrMod
End Sub
'

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_Border = m_def_Border
    m_CaptionBackColor = m_def_CaptionBackColor
    Set m_Picture = LoadPicture("")
    m_Caption = m_def_Caption
    m_SubCaption = m_def_SubCaption
    Set UserControl.Font = Ambient.Font
    Set m_SubCaptionFont = Ambient.Font
    m_SubCaptionForeColor = m_def_SubCaptionForeColor
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    m_Border = PropBag.ReadProperty("Border", m_def_Border)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    m_CaptionBackColor = PropBag.ReadProperty("CaptionBackColor", m_def_CaptionBackColor)
    UserControl.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    Set m_Picture = PropBag.ReadProperty("Picture", Nothing)
    m_Caption = PropBag.ReadProperty("Caption", m_def_Caption)
    m_SubCaption = PropBag.ReadProperty("SubCaption", m_def_SubCaption)
    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
    Set m_SubCaptionFont = PropBag.ReadProperty("SubCaptionFont", Ambient.Font)
    m_SubCaptionForeColor = PropBag.ReadProperty("SubCaptionForeColor", m_def_SubCaptionForeColor)
    
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("Border", m_Border, m_def_Border)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("CaptionBackColor", m_CaptionBackColor, m_def_CaptionBackColor)
    Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &H80000012)
    Call PropBag.WriteProperty("Picture", m_Picture, Nothing)
    Call PropBag.WriteProperty("Caption", m_Caption, m_def_Caption)
    Call PropBag.WriteProperty("SubCaption", m_SubCaption, m_def_SubCaption)
    Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
    Call PropBag.WriteProperty("SubCaptionFont", m_SubCaptionFont, Ambient.Font)
    Call PropBag.WriteProperty("SubCaptionForeColor", m_SubCaptionForeColor, m_def_SubCaptionForeColor)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get Border() As Long
    Border = m_Border
End Property

Public Property Let Border(ByVal New_Border As Long)
    m_Border = New_Border
    UserControl_Paint
    PropertyChanged "Border"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Returns/sets the background color used To display text and graphics In an object."
    BackColor = UserControl.BackColor
End Property

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

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get CaptionBackColor() As OLE_COLOR
    CaptionBackColor = m_CaptionBackColor
End Property

Public Property Let CaptionBackColor(ByVal New_CaptionBackColor As OLE_COLOR)
    m_CaptionBackColor = New_CaptionBackColor
    UserControl_Paint
    PropertyChanged "CaptionBackColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
Attribute ForeColor.VB_Description = "Returns/sets the foreground color used To display text and graphics In an object."
    ForeColor = UserControl.ForeColor
End Property

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

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=11,0,0,0
Public Property Get Picture() As Picture
Attribute Picture.VB_Description = "Returns/sets a graphic To be displayed In a control."
    Set Picture = m_Picture
End Property

Public Property Set Picture(ByVal New_Picture As Picture)
    Set m_Picture = New_Picture
    UserControl_Paint
    PropertyChanged "Picture"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,Cool Caption
Public Property Get Caption() As String
    Caption = m_Caption
End Property

Public Property Let Caption(ByVal New_Caption As String)
    m_Caption = New_Caption
    UserControl_Paint
    PropertyChanged "Caption"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,
Public Property Get SubCaption() As String
    SubCaption = m_SubCaption
End Property

Public Property Let SubCaption(ByVal New_SubCaption As String)
    m_SubCaption = New_SubCaption
    UserControl_Paint
    PropertyChanged "SubCaption"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Font
Public Property Get Font() As Font
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_UserMemId = -512
    Set Font = UserControl.Font
End Property

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

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=6,0,0,0
Public Property Get SubCaptionFont() As Font
    Set SubCaptionFont = m_SubCaptionFont
End Property

Public Property Set SubCaptionFont(ByVal New_SubCaptionFont As Font)
    Set m_SubCaptionFont = New_SubCaptionFont
    UserControl_Paint
    PropertyChanged "SubCaptionFont"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get SubCaptionForeColor() As OLE_COLOR
    SubCaptionForeColor = m_SubCaptionForeColor
End Property

Public Property Let SubCaptionForeColor(ByVal New_SubCaptionForeColor As OLE_COLOR)
    m_SubCaptionForeColor = New_SubCaptionForeColor
    UserControl_Paint
    PropertyChanged "SubCaptionForeColor"
End Property