xchart.ctl

来自「多种图表的绘制及其运用」· CTL 代码 · 共 1,923 行 · 第 1/5 页

Private uBarShadowColor   As Long         'the bar shadow color
Private uAutoRedraw       As Boolean      'marker indicating if the chart is auto-redrawn
                                          'upon every property change
Private uRangeY           As Integer      'the absolute range between Y-axis min. ad max. values
Private uDataType         As Integer      'indicates the data distribution in the Y axis
Private Const DT_BOTH = 0                 ' 0 = range(-Y0, +Y1)
Private Const DT_NEG = 1                  ' 1 = range(-Y0, -Y1)
Private Const DT_POS = 2                  ' 2 = range(+Y0, +Y1)

Private uMinYValue        As Double       'minimum y value
Private uLineColor        As Long         'the color of the line
Private uLineStyle        As Integer      'the line style
Private uBarSymbolColor   As Long         'the color of the symbol
Private uBarColor         As Long         'the backcolor of the bars
Private uBarFillStyle     As Integer      'the bars fill style
Private uSelectedBarColor As Long         'the selected bar backcolor
Private uMinorGridColor   As Long         'the minor intersect grid color
Private uMajorGridColor   As Long         'the major intersect grid color
Private uMinorGridOn      As Boolean      'marker indicating display of minor grid
Private uMajorGridOn      As Boolean      'marker indicating display of major grid
Private uLegendBackColor  As Long         'the legend background color
Private uLegendForeColor  As Long         'the legend foreground color
Private uInfoBackColor    As Long         'the information box background color
Private uInfoForeColor    As Long         'the information box foreground color
Private uXAxisLabelColor  As Long         'the X axis label color
Private uYAxisLabelColor  As Long         'the Y axis label color
Private uXAxisItemsColor  As Long         'the X axis items color
Private uYAxisItemsColor  As Long         'the Y axis items color
Private uChartTitleColor  As Long         'the chart title color
Private uChartSubTitleColor As Long       'the chart subtitle color
Private uSaveAsCaption    As String       'the SaveAs dialog box caption
Private uInfoItems        As String       'the information items (to be displayed in the info box)
Private Const INFO_ITEMS = "Value|Description|Mean"

Public Enum ChartMenuConstants             'the enumerated for menu type
    xcPopUpMenu = 0
    xcButtonMenu
End Enum

Private uMenuType         As ChartMenuConstants 'the menu type.
Private uMenuItems        As String       'the menu's items.
Private Const MENU_ITEMS = "&Save as...|&Print|&Copy|Selection &information|&Legend|&Hide"

Private uCustomMenuItems  As String       'the custom menu's items.
Private Const CUSTOM_MENU_ITEMS = Empty

Private uLegendCaption    As String       'the legend's tooltip string
Private Const LEGEND_CAPTION = "Display legend"

Private Const XC_BAR = 1
Private Const XC_SYMBOL = 2
Private Const XC_LINE = 4
Private Const XC_OVAL = 8
Private Const XC_TRIANGLE = 16
Private Const XC_RHOMBUS = 32
Private Const XC_TRAPEZIUM = 64
Public Enum ChartTypeConstants            'the enumerated for chart type
    xcBar = XC_BAR
    xcSymbol = XC_SYMBOL
    xcLine = XC_LINE
    xcBarLine = XC_BAR + XC_LINE
    xcSymbolLine = XC_SYMBOL + XC_LINE
    xcOval = XC_OVAL
    xcOvalLine = XC_OVAL + XC_LINE
    xcTriangle = XC_TRIANGLE
    xcTriangleLine = XC_TRIANGLE + XC_LINE
    xcRhombus = XC_RHOMBUS
    xcRhombusLine = XC_RHOMBUS + XC_LINE
    xcTrapezium = XC_TRAPEZIUM
    xcTrapeziumLine = XC_TRAPEZIUM + XC_LINE
End Enum

Private uChartType        As ChartTypeConstants 'the chart type.
Private uBarSymbol        As String * 1   'the symbol to be displayed when uChartType=xcSymbol
Private uBarWidthPercentage As Integer    'the column width (in percentage) just for bar type
Private uLineWidth        As Integer      'the line width (used when uChartType=xcLine and for bar border in case of uChartType=xcBar)

Private Const IDX_SAVE = 0                'the command buttons' indexs
Private Const IDX_PRINT = 1
Private Const IDX_COPY = 2
Private Const IDX_INFO = 3
Private Const IDX_LEGEND = 4
'--------------------------------------------------------------------------------

Private uColWidth         As Single       'the calculated width of each column
Private uRowHeight        As Single       'the calculated height of each column
Private uTopMargin        As Single       '--------------------------------------
Private uBottomMargin     As Single       'margins used around the chart content
Private uLeftMargin       As Single       '
Private uRightMargin      As Single
Private uRightMarginOrg   As Single       '--------------------------------------
Private uContentBorder    As Boolean      'border around the chart content?
Private uSelectable       As Boolean      'marker indicating whether user can select a column
Private uHotTracking      As Boolean      'marker indicating use of hot tracking
Private uSelectedColumn   As Integer      'marker indicating the selected column
Private uOldSelection     As Long
Private uDisplayDescript  As Boolean      'display description when selectable
Private uChartTitle       As String       'chart title
Private uChartSubTitle    As String       'chart sub title
Private uAxisXOn          As Boolean      'marker indicating display of x axis
Private uAxisYOn          As Boolean      'marker indicating display of y axis
Private uColorBars        As Boolean      'marker indicating use of different coloured bars
Private uIntersectMajor   As Single       'major intersect value
Private uIntersectMinor   As Single       'minor intersect value
Private uMaxYValue        As Double       'maximum y value
Private uXAxisLabel       As String       'label to be displayed below the X-Axis
Private uYAxisLabel       As String       'label to be displayed left of the Y-Axis
Private cItems            As Collection   'collection of chart items

Private offsetX           As Long
Private offsetY           As Long

Private bLegendAdded      As Boolean
Private bLegendClicked    As Boolean
Private bDisplayLegend    As Boolean
Private bResize           As Boolean
Private bResizeLegend     As Boolean

Private bProcessingOver   As Boolean      'marker to speed up mouse over effects

Public Type ChartItem
    ItemID As String
    SelectedDescription As String
    LegendDescription As String
    XAxisDescription As String
    Value As Double
End Type

Public Event ItemClick(cItem As ChartItem)
Public Event MenuItemClick(intMenuItemIndex As Integer, stgMenuItemCaption As String)
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

'-----------------------------------------------
' for Ballon ToolTip
'-----------------------------------------------
Private ttpBalloon As New Tooltip

Public Property Let LegendPrintMode(val As LegendPrintConstants)
    uLegendPrintMode = val
    PropertyChanged "LegendPrintMode"
End Property
Public Property Get LegendPrintMode() As LegendPrintConstants
    LegendPrintMode = uLegendPrintMode
End Property

Public Function AddItem(cItem As ChartItem) As Boolean
    
    Dim oChartItem As ChartItem
    
    If uMeanOn = True Then
        If cItems.Count > 0 Then
            cItems.Remove (cItems.Count)
        End If
    End If

    cItems.Add cItem
    
    If uMeanOn = True Then
        CalcMean
        If uMeanCaption = Empty Then uMeanCaption = MEAN_CAPTION
        With oChartItem
            .Value = dblMeanValue
            .ItemID = uMeanCaption
            .XAxisDescription = uMeanCaption
            .SelectedDescription = uMeanCaption
            .LegendDescription = uMeanCaption
        End With
        cItems.Add oChartItem
    End If
    
End Function

Public Property Let AutoRedraw(blnVal As Boolean)
    If blnVal <> uAutoRedraw Then
        uAutoRedraw = blnVal
        DrawChart
        PropertyChanged "AutoRedraw"
    End If
End Property

Public Property Get AutoRedraw() As Boolean
Attribute AutoRedraw.VB_Description = "Returns/sets the option to force the chart redrawing upon each change."
AutoRedraw = uAutoRedraw
End Property

Public Property Get BarShadow() As Boolean
Attribute BarShadow.VB_Description = "Determines if the bar must have the shadow."
    BarShadow = uBarShadow
End Property

Public Property Get BarShadowColor() As OLE_COLOR
Attribute BarShadowColor.VB_Description = "Returns/sets the color used to display the bar shadow."
    BarShadowColor = uBarShadowColor
End Property

Public Property Let BarShadow(blnVal As Boolean)
    If blnVal <> uBarShadow Then
        uBarShadow = blnVal
        DrawChart
        PropertyChanged "BarShadow"
    End If
End Property

Public Property Let BarShadowColor(lngVal As OLE_COLOR)
    If lngVal <> uBarShadowColor Then
        uBarShadowColor = lngVal
        DrawChart
        PropertyChanged "BarShadowColor"
    End If
End Property

Private Sub CalcMean()
    
    On Error Resume Next
    
    Dim intIdx As Integer
    
    dblMeanValue = 0
    For intIdx = 1 To cItems.Count
        dblMeanValue = dblMeanValue + cItems.Item(intIdx).Value
    Next
    dblMeanValue = dblMeanValue / cItems.Count
    
End Sub

Public Property Get DataFormat() As String
Attribute DataFormat.VB_Description = "Determines the format which the Y-values are displayed with."
    DataFormat = uDataFormat
End Property

Public Property Get PrinterOrientation() As PrinterObjectConstants
    PrinterOrientation = uPrinterOrientation
End Property


Public Property Let DataFormat(stgVal As String)
    uDataFormat = stgVal
    PropertyChanged "DataFormat"
End Property

Public Property Let PrinterOrientation(intVal As PrinterObjectConstants)
    If intVal = vbPRORLandscape Or intVal = vbPRORPortrait Then
        uPrinterOrientation = intVal
        PropertyChanged "PrinterOrientation"
    End If
End Property


Private Sub DisplayInfo(intIdx As Integer)

    Dim sDescription    As String
    Dim varItems        As Variant
    
    'it's important to let the info label invisible at beginning to avoid flickering effect
    lblInfo.Visible = False
    If uDisplayDescript Then
        If intIdx > -1 Then
            With cItems.Item(intIdx + 1)
                'this kind of error trapping is useful in case the user
                'did not define any item in the menu items string, so the default is used
                On Error GoTo DisplayInfo_error
        
                If uInfoItems = Empty Then uInfoItems = INFO_ITEMS
                varItems = Split(uInfoItems, "|")
                sDescription = CStr(varItems(0)) & ": " & Format(.Value, uDataFormat)
                If Len(.SelectedDescription) > 0 Then
                    sDescription = CStr(varItems(1)) & ": " & .SelectedDescription & vbCrLf & sDescription
                End If
                If (uMeanOn = True) And (intIdx < cItems.Count - 1) Then
                    sDescription = sDescription & vbCrLf & CStr(varItems(2)) & ": " & Format(dblMeanValue, uDataFormat)
                End If
            End With
        End If
        If sDescription <> Empty Then
            lblInfo.Caption = sDescription
            lblInfo.Width = UserControl.TextWidth(sDescription) + 5 * Screen.TwipsPerPixelX
            lblInfo.Height = UserControl.TextHeight(sDescription) * 1.2
            lblInfo.Visible = True
        End If
    End If
    Exit Sub

DisplayInfo_error:
    uInfoItems = INFO_ITEMS
    Resume Next

End Sub

Private Sub DrawOval(sngX1 As Single, sngX2 As Single, sngY1 As Single, sngY2 As Single, sngBase As Single, sngHeight As Single, lngBorderColor As Long)
    
    On Error Resume Next
    
    Dim x1 As Single
    Dim y1 As Single
    Dim x2 As Single
    Dim y2 As Single
    Dim sngH As Single
    Dim sngW As Single
    Dim lngFillColor As Long

    x1 = sngX1
    y1 = sngY1
    x2 = sngX2
    y2 = sngY2
    sngW = sngBase
    sngH = sngHeight
    x1 = x1 + (sngW / 2)
    y1 = y1 + (sngH / 2)
    If uBarShadow = True Then
        lngFillColor = UserControl.FillColor
        UserControl.FillStyle = vbFSSolid
        UserControl.FillColor = uBarShadowColor
        UserControl.Circle (x1, y1), sngH / 2, uBarShadowColor, , , _
                            IIf((sngH > sngW), (sngH / sngW), (sngW / sngH))
        UserControl.FillColor = lngFillColor
        UserControl.FillStyle = uBarFillStyle
        x1 = x1 - 2 * Screen.TwipsPerPixelX
        sngW = sngW - 2 * Screen.TwipsPerPixelX
        sngH = sngH - 2 * Screen.TwipsPerPixelX
    End If
    'the aspect ratio depend on whether the base is greater than the height
    UserControl.Circle (x1, y1), sngH / 2, lngBorderColor, , , _
                        IIf((sngH > sngW), (sngH / sngW), (sngW / sngH))
    
End Sub

Private Sub DrawPicture(sngX1 As Single, sngX2 As Single, sngY1 As Single, sngY2 As Single, blnTile As Boolean, pic As StdPicture)

    On Error Resume Next
    
    Dim x1 As Single
    Dim x2 As Single
    Dim y1 As Single
    Dim y2 As Single
    Dim sngH As Single
    Dim sngW As Single
    Dim xTemp As Single
    Dim yTemp As Single
    
    If blnTile = True Then
        'I found the ratio of 1.75 to adjust size, but I really don't know why!!!
        sngH = Round(pic.Height / 1.75)
        sngW = Round(pic.Width / 1.75)
        If (sngH Mod Screen.TwipsPerPixelY) <> 0 Then
            sngH = Round(sngH / Screen.TwipsPerPixelY) * Screen.TwipsPerPixelY
        End If
        If (sngW Mod Screen.TwipsPerPixelX) <> 0 Then
            sngW = Round(sngW / Screen.TwipsPerPixelX) * Screen.TwipsPerPixelX
        End If
        y1 = sngY1
        y2 = sngY2
        x2 = sngX2
        Do While y1 < y2
            x1 = sngX1
            Do While x1 < x2
                If (x1 + sngW) > x2 Then
                    xTemp = (x2 - x1)
                Else
                    xTemp = sngW
                End If
                xTemp = IIf(xTemp < Screen.TwipsPerPixelX, Screen.TwipsPerPixelX, xTemp)
                If (y1 + sngH) > y2 Then
                    yTemp = (y2 - y1)
                Else
                    yTemp = sngH
                End If
                yTemp = IIf(yTemp < Screen.TwipsPerPixelY, Screen.TwipsPerPixelY, yTemp)
'If (yTemp Mod Screen.TwipsPerPixelY) <> 0 Then
'    yTemp = Round(yTemp / Screen.TwipsPerPixelY) * Screen.TwipsPerPixelY
'End If
'If (xTemp Mod Screen.TwipsPerPixelX) <> 0 Then
'    xTemp = Round(xTemp / Screen.TwipsPerPixelX) * Screen.TwipsPerPixelX
'End If
                UserControl.PaintPicture pic, _
                            x1, y1, _
                            xTemp, _
                            yTemp, _
                            0, 0, xTemp, yTemp
                x1 = (x1 + sngW)
            Loop
            y1 = (y1 + sngH)
        Loop
    Else
        'stretch the picture