ctltabs.ctl

这个是我以前做的一个客户管理系统.包内已经含有源码和所用到的控件.代码是用VB写的,数据库采用MSSQL的.

'----------------------------------------------------------
' SelectedTab
' Currently selected (active) tab
'----------------------------------------------------------
Public Property Get SelectedTab() As Integer
Attribute SelectedTab.VB_Description = "Returns/sets the currently selected tab"
    SelectedTab = propTabSelected
End Property

Public Property Let SelectedTab(ByVal newVal As Integer)
    Dim oldVal As Integer
    
    oldVal = propTabSelected
    propTabSelected = newVal
    
    If propTabSelected < 1 Then         'Range checks
        propTabSelected = 1
    ElseIf propTabSelected > propTabCount Then
        propTabSelected = propTabCount
    End If
    
    PropertyChanged "TABSELECTED"
    DrawTabs
    'Do this here because we want to raise the event
    'AFTER the tabs have been drawn
    RaiseEvent TabClick(oldVal, newVal)
End Property


'----------------------------------------------------------
' UseFocusRect
' Indicates the focus should be shown
'----------------------------------------------------------
Public Property Get UseFocusRect() As Boolean
Attribute UseFocusRect.VB_Description = "Returns/sets whether a focus rectangle will be displayed when a tab has the focus"
    UseFocusRect = propFocusRect
End Property

Public Property Let UseFocusRect(ByVal newVal As Boolean)
    propFocusRect = newVal
    PropertyChanged "FOCUSRECT"
    DrawTabs
End Property


'----------------------------------------------------------
' UserControl Functions
'----------------------------------------------------------

'----------------------------------------------------------
' Changes background color to that of your color scheme
'----------------------------------------------------------
Private Sub UserControl_AmbientChanged(PropertyName As String)
    If PropertyName = "BackColor" Then DrawTabs
End Sub

'----------------------------------------------------------
' Arrow keys can be used to move between tabs
'----------------------------------------------------------
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyLeft, vbKeyUp:    SelectedTab = SelectedTab - 1
        Case vbKeyRight, vbKeyDown: SelectedTab = SelectedTab + 1
    End Select
End Sub

'----------------------------------------------------------
' Handles the focus rectangle
'----------------------------------------------------------
Private Sub UserControl_GotFocus()
    hasFocus = True
    If propFocusRect Then DrawTabs
End Sub

Private Sub UserControl_LostFocus()
    hasFocus = False
    If propFocusRect Then DrawTabs
End Sub

'----------------------------------------------------------
' If you click on one of the tabs, you select that tab
'----------------------------------------------------------
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim t1 As Integer
    For t1 = 1 To propTabCount
        If X >= ClickZone(t1).Left And X <= ClickZone(t1).Right _
        And Y >= ClickZone(t1).Top And Y <= ClickZone(t1).Bottom Then
            SelectedTab = t1
            Exit For
        End If
    Next t1
End Sub

'----------------------------------------------------------
' If your mouse moves over one of the tabs
' the MousePointer becomes a hand pointer
'----------------------------------------------------------
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim t1 As Integer, tPointer As Integer
    
    tPointer = vbDefault
    For t1 = 1 To propTabCount
        If X >= ClickZone(t1).Left And X <= ClickZone(t1).Right _
        And Y >= ClickZone(t1).Top And Y <= ClickZone(t1).Bottom Then
            tPointer = vbCustom
            Exit For
        End If
    Next t1
    UserControl.MousePointer = tPointer
End Sub

Private Sub UserControl_Resize()
    DrawTabs
End Sub

'----------------------------------------------------------
' Initialize - Default values for all properties
'----------------------------------------------------------
Private Sub UserControl_Initialize()
    Dim t1 As Integer
    propTabWide = 70: propTabHigh = 20
    propTabCount = 2
    propTabSelected = 1
    propStyle = [Top Left]
    propCaptionStyle = [cMiddle Center]
    propFocusRect = False
    ReDim propCaption(1 To propTabCount)
    For t1 = 1 To propTabCount
        propCaption(t1) = "Tab " & t1
    Next t1
    Set propTabFont = New StdFont
    AssignFont propTabFont, UserControl.Font
    Set propTabFontActive = New StdFont
    AssignFont propTabFontActive, UserControl.Font
    propTabFontActive.Bold = Not propTabFontActive.Bold
    propTabColor = vbButtonShadow
    propTabColorActive = vbButtonFace
    propTextColor = vb3DHighlight
    propTextColorActive = vbButtonText
End Sub

'----------------------------------------------------------
' ReadProperties
'----------------------------------------------------------
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Dim t1 As Integer
    With PropBag
        propTabWide = .ReadProperty("TABWIDE", 70)
        propTabHigh = .ReadProperty("TABHIGH", 20)
        propTabCount = .ReadProperty("TABCOUNT", 2)
        propTabSelected = .ReadProperty("TABSELECTED", 1)
        propStyle = .ReadProperty("TABSTYLE", [Top Left])
        propCaptionStyle = .ReadProperty("CAPTIONSTYLE", [cMiddle Center])
        propFocusRect = .ReadProperty("FOCUSRECT", False)
        ReDim Preserve propCaption(1 To propTabCount)
        For t1 = 1 To propTabCount
            propCaption(t1) = .ReadProperty("TABCAPTION" & t1, "")
        Next t1
        Set propTabFont = .ReadProperty("TABFONT", UserControl.Font)
        Set propTabFontActive = .ReadProperty("TABFONTACTIVE", UserControl.Font)
        propTabColor = .ReadProperty("TABCOLOR", vbButtonShadow)
        propTabColorActive = .ReadProperty("TABCOLORACTIVE", vbButtonFace)
        propTextColor = .ReadProperty("TEXTCOLOR", vb3DHighlight)
        propTextColorActive = .ReadProperty("TEXTCOLORACTIVE", vbButtonText)
    End With
    DrawTabs
End Sub

'----------------------------------------------------------
' WriteProperties
'----------------------------------------------------------
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Dim t1 As Integer
    With PropBag
        .WriteProperty "TABWIDE", propTabWide
        .WriteProperty "TABHIGH", propTabHigh
        .WriteProperty "TABCOUNT", propTabCount
        .WriteProperty "TABSELECTED", propTabSelected
        .WriteProperty "TABSTYLE", propStyle
        .WriteProperty "CAPTIONSTYLE", propCaptionStyle
        .WriteProperty "FOCUSRECT", propFocusRect
        For t1 = 1 To propTabCount
            .WriteProperty "TABCAPTION" & t1, propCaption(t1), ""
        Next t1
        .WriteProperty "TABFONT", propTabFont
        .WriteProperty "TABFONTACTIVE", propTabFontActive
        .WriteProperty "TABCOLOR", propTabColor
        .WriteProperty "TABCOLORACTIVE", propTabColorActive
        .WriteProperty "TEXTCOLOR", propTextColor
        .WriteProperty "TEXTCOLORACTIVE", propTextColorActive
    End With
End Sub


'----------------------------------------------------------
' DrawTabs
' The main routine which draws everything on the control
'----------------------------------------------------------
Private Sub DrawTabs()
    Dim tPoint As POINTAPI, trect As RECT, tRectIn As RECT
    Dim tBorderButton As Integer
    Dim t1 As Integer, tCaption As String
    Dim tCol As Long, hBrushInactive As Long, hBrushActive As Long
    Dim tTextCol As Long, tTextActive As Long
    
    Dim tCtlHeight As Long, tCtlWidth As Long   'Control's height/width in pixels
    
    'Color translation is required - eg to convert 'Button Text'
    'to the RGB value used by your Windows theme
    OleTranslateColor propTextColor, 0, tTextCol
    OleTranslateColor propTextColorActive, 0, tTextActive
    
    'Brushes used to draw filled rectangles
    OleTranslateColor propTabColor, 0, tCol:        hBrushInactive = CreateSolidBrush(tCol)
    OleTranslateColor propTabColorActive, 0, tCol:  hBrushActive = CreateSolidBrush(tCol)
    
    With UserControl
        tCtlWidth = .Width / Screen.TwipsPerPixelX
        tCtlHeight = .Height / Screen.TwipsPerPixelY
        
        .BackColor = UserControl.Ambient.BackColor      'Non-tabs area matches your Windows theme
        .Cls
        
        '----------------------------------------------------------
        ' Draw rectangle for the main container area
        '----------------------------------------------------------
        trect.Left = 0
        trect.Right = tCtlWidth
        trect.Top = 0
        trect.Bottom = tCtlHeight
        
        'tBorderButton - these styles indicate rectangles with one side missing
        Select Case propStyle
            Case [Top Left], [Top Right]
                trect.Top = propTabHigh
                tBorderButton = BF_RECT - BF_BOTTOM
            
            Case [Bottom Left], [Bottom Right]
                trect.Bottom = tCtlHeight - propTabHigh
                tBorderButton = BF_RECT - BF_TOP
            
            Case [Left Top], [Left Bottom]
                trect.Left = propTabWide
                tBorderButton = BF_RECT - BF_RIGHT
            
            Case [Right Top], [Right Bottom]
                trect.Right = tCtlWidth - propTabWide
                tBorderButton = BF_RECT - BF_LEFT
        End Select
        
        FillRect .hDC, trect, hBrushActive              'Filled rectangle
        DrawEdge .hDC, trect, BDR_RAISEDINNER, BF_RECT  'Surround with 3D edge
        
        '----------------------------------------------------------
        ' Draw each tab onto the remainder of the control
        '----------------------------------------------------------
        ReDim ClickZone(1 To propTabCount)  'Stored the coords of each tab
        
        For t1 = 1 To propTabCount
            Select Case propStyle
                Case [Top Left]
                    trect.Left = (t1 - 1) * propTabWide
                    trect.Top = 0
                
                Case [Top Right]
                    trect.Left = tCtlWidth - propTabCount * propTabWide + (t1 - 1) * propTabWide - 1
                    trect.Top = 0
                
                Case [Bottom Left]
                    trect.Left = (t1 - 1) * propTabWide
                    trect.Top = tCtlHeight - propTabHigh - 1
                
                Case [Bottom Right]
                    trect.Left = tCtlWidth - propTabCount * propTabWide + (t1 - 1) * propTabWide - 1
                    trect.Top = tCtlHeight - propTabHigh - 1
                
                Case [Left Top]
                    trect.Left = 0
                    trect.Top = (t1 - 1) * propTabHigh
                
                Case [Left Bottom]
                    trect.Left = 0
                    trect.Top = tCtlHeight - propTabCount * propTabHigh + (t1 - 1) * propTabHigh - 1
            
                Case [Right Top]
                    trect.Left = tCtlWidth - propTabWide - 1
                    trect.Top = (t1 - 1) * propTabHigh
                
                Case [Right Bottom]
                    trect.Left = tCtlWidth - propTabWide - 1
                    trect.Top = tCtlHeight - propTabCount * propTabHigh + (t1 - 1) * propTabHigh - 1
            
            End Select
            trect.Right = trect.Left + propTabWide + 1
            trect.Bottom = trect.Top + propTabHigh + 1
            
            '----------------------------------------------------------
            ' Draw the selected (active) tab
            '----------------------------------------------------------
            If t1 = propTabSelected Then
                FillRect .hDC, trect, hBrushActive
                DrawEdge .hDC, trect, BDR_RAISEDINNER, tBorderButton
                ClickZone(t1) = trect
                If propFocusRect And hasFocus Then
                    tRectIn.Left = trect.Left + 2       'Focus rectangle
                    tRectIn.Right = trect.Right - 2
                    tRectIn.Top = trect.Top + 2
                    tRectIn.Bottom = trect.Bottom - 2
                    DrawFocusRect .hDC, tRectIn
                End If
                AssignFont .Font, propTabFontActive
                .ForeColor = propTextColorActive
            '----------------------------------------------------------
            ' Draw the inactive tabs
            '----------------------------------------------------------
            Else
                tRectIn.Left = trect.Left + 1           'Rectangle for inactive tabs is smaller
                tRectIn.Right = trect.Right - 1
                tRectIn.Top = trect.Top + 1
                tRectIn.Bottom = trect.Bottom - 1
                FillRect .hDC, tRectIn, hBrushInactive
                ClickZone(t1) = tRectIn
                AssignFont .Font, propTabFont
                .ForeColor = propTextColor
            End If
            
            '----------------------------------------------------------
            ' Draw the caption on each tab
            '----------------------------------------------------------
            tCaption = propCaption(t1)
            Select Case propCaptionStyle    'X coord
                Case 0, 3, 6:   .CurrentX = trect.Left + 3
                Case 1, 4, 7:   .CurrentX = (trect.Right - trect.Left) / 2 + trect.Left - .TextWidth(tCaption) / 2 - 1
                Case 2, 5, 8:   .CurrentX = trect.Right - .TextWidth(tCaption) - 4
            End Select
            Select Case propCaptionStyle    'Y coord
                Case 0, 1, 2:   .CurrentY = trect.Top + 2
                Case 3, 4, 5:   .CurrentY = (trect.Bottom - trect.Top) / 2 + trect.Top - .TextHeight(tCaption) / 2 - 1
                Case 6, 7, 8:   .CurrentY = (trect.Bottom) - .TextHeight(tCaption) - 2
            End Select
            
            UserControl.Print tCaption
            
        Next t1
    End With

    DeleteObject hBrushInactive
    DeleteObject hBrushActive
End Sub


'----------------------------------------------------------
' AssignFont
' Copy the attributes of one font object to another
'----------------------------------------------------------
Private Sub AssignFont(ByRef tFont1 As StdFont, ByVal tfont2 As StdFont)
    With tFont1
        .Bold = tfont2.Bold
        .Charset = tfont2.Charset
        .Italic = tfont2.Italic
        .Name = tfont2.Name
        .Size = tfont2.Size
        .Strikethrough = tfont2.Strikethrough
        .Underline = tfont2.Underline
        .Weight = tfont2.Weight
    End With
End Sub