xquadrant.ctl

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

    prtFitStretched
    prtFitTopLeft
    prtFitTopRight
    prtFitBottomLeft
    prtFitBottomRight
End Enum

Private uPrinterFit As PrinterFitConstants
Private uPrinterOrientation As PrinterObjectConstants
Private uDataFormat       As String       'the data format for numeric values
Private uPicture          As StdPicture   'the background picture
Private uPictureTile      As Boolean      'marker indicating if the background picture must be tiled
                                          '(TRUE) or stretched (FALSE)
Private uAutoRedraw       As Boolean      'indicates 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 uDataTypeY        As Integer      'indicates the data distribution in the Y axis
Private uRangeX           As Integer      'the absolute range between X-axis min. ad max. values
Private uDataTypeX        As Integer      'indicates the data distribution in the X 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 uQuadrantXValue   As Double       'maximum quadrant-x value
Private uQuadrantYValue   As Double       'maximum quadrant-y value
Private uMaxYValue        As Double       'maximum y value
Private uMaxXValue        As Double       'maximum x value
Private uMinYValue        As Double       'minimum y value
Private uMinXValue        As Double       'minimum x value
Private uMarkerColor      As Long         'the color of the symbol
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 picBox background color
Private uInfoForeColor    As Long         'the information picBox 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 uSelectedColumn   As Integer      'marker indicating the selected column
Private uSelectable       As Boolean      'marker indicating whether user can select a column
Private uSelectedColor    As Long         'the selected marker forecolor
Private uInnerColor       As Long         'the inner background color
Private uSaveAsCaption    As String       'the SaveAs dialog picBox caption
Private uOldSelection     As Long

Private uInfoItems        As String       'the information items (to be displayed in the info picBox)
Private Const INFO_ITEMS = "Value XY|Description"

Private uInfoQuadrantBackColor    As Long         'the quadrant information picBox background color
Private uInfoQuadrantForeColor    As Long         'the quadrant information picBox foreground color
Private uInfoQuadrantItems        As String       'the information items (to be displayed in the info picBox)
Private Const INFO_QUADRANT_ITEMS = "Quadrant 1|Quadrant 2|Quadrant 3|Quadrant 4"

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|&Quadrant 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 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_QUAD_INFO = 4
Private Const IDX_LEGEND = 5

Private uColWidth         As Single       'the calculated width of each column
Private uRowHeightPortion As Single       'the minimum height of a column
Private uColWidthPortion  As Single       'the minimum width of a 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 uDisplayDescript  As Boolean      'display description when selectable
Private uDisplayQuadrantDescript As Boolean  'display quadrant description
Private uChartTitle       As String       'chart title
Private uChartSubTitle    As String       'chart sub title
Private uChartAsQuadrant  As Boolean      'chart as quadrant (divide chart into 4 quadrants)
Private uAxisXOn          As Boolean      'marker indicating display of x axis
Private uAxisYOn          As Boolean      'marker indicating display of y axis
Private uIntersectMajorY  As Single       'major intersect value
Private uIntersectMinorY  As Single       'minor intersect value
Private uIntersectMajorX  As Single       'major intersect value
Private uIntersectMinorX  As Single       'minor intersect 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 uHotTracking      As Boolean      'marker indicating use of hot tracking
Private cItems            As Collection   'collection of chart items

Private Const QUADRANT_COLORS = "255|16711680|65280|65535"   'red|blue|green|yellow
Private uQuadrantColor(3) As Long         'the colors of the quadrants
Private uQuadrantColors   As String       'the colors of the quadrants
Private uQuadrantDividerColor As Long     'the color of the quadrant divider
Private uQuadrantColorsOverridePicture As Boolean  'the colors of the quadrants override the back picture

Public Enum MarkerDirectionConstants      'the enumerated for marker direction
    xcMarkerUp = 0
    xcMarkerDown
    xcMarkerRight
    xcMarkerLeft
End Enum

Public Enum MarkerSymbolConstants         'the enumerated for marker symbol
    xcMarkerSymBox = 0
    xcMarkerSymCircle
    xcMarkerSymTriangle
    xcMarkerSymTrapezium
    xcMarkerSymRhombus
End Enum

Private uMarkerSymbol     As MarkerSymbolConstants  'the marker type to be displayed
Private uMarkerWidth      As Integer     'the marker width
Private uMarkerLabelAngle As Integer     'rotation degree of marker label
Private uMarkerLabelColor As Long        'the color of the marker
Private uMarkerLabelDirection As MarkerDirectionConstants

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
    Description As String
    XValue As Double
    YValue 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 QuadrantX(dblVal As Double)
    If dblVal >= uMinXValue And dblVal <= uMaxXValue Then
        uQuadrantXValue = dblVal
        DrawChart
        PropertyChanged "QuadrantX"
    End If
End Property

Public Property Get QuadrantY() As Double
    QuadrantY = uQuadrantYValue
End Property

Public Property Let QuadrantY(dblVal As Double)
    If dblVal >= uMinYValue And dblVal <= uMaxYValue Then
        uQuadrantYValue = dblVal
        DrawChart
        PropertyChanged "QuadrantY"
    End If
End Property


Public Property Get QuadrantX() As Double
    QuadrantX = uQuadrantXValue
End Property

Private Function DrawMarkerpicBox(sngX As Single, sngY As Single, lngColor As Long) As PointAPI()
    
    Dim uaPts(1) As PointAPI
    Dim sngMarkYOff As Single
    Dim sngMarkXOff As Single
    
    sngMarkYOff = uMarkerWidth / 2 * Screen.TwipsPerPixelY
    sngMarkXOff = uMarkerWidth / 2 * Screen.TwipsPerPixelX
    uaPts(0).X = sngX - sngMarkXOff
    uaPts(1).X = sngX + sngMarkXOff
    uaPts(0).Y = sngY - sngMarkYOff
    uaPts(1).Y = sngY + sngMarkYOff
    UserControl.Line (uaPts(0).X, uaPts(0).Y)-(uaPts(1).X, uaPts(1).Y), lngColor, BF
    
    DrawMarkerpicBox = uaPts()

    'free the memory
    Erase uaPts

End Function

Private Function DrawMarkerCircle(sngX As Single, sngY As Single, lngColor As Long) As PointAPI()

    Dim lngFillColor As Long
    Dim lngFillStyle As Long
    Dim uaPts(1) As PointAPI
    Dim sngMarkYOff As Single
    Dim sngMarkXOff As Single
    
    sngMarkYOff = uMarkerWidth / 2 * Screen.TwipsPerPixelY
    sngMarkXOff = uMarkerWidth / 2 * Screen.TwipsPerPixelX
    With UserControl
        lngFillColor = .FillColor
        lngFillStyle = .FillStyle
        .FillColor = lngColor
        .FillStyle = vbFSSolid
        UserControl.Circle (sngX, sngY), sngMarkXOff, uMarkerColor
        .FillColor = lngFillColor
        .FillStyle = lngFillStyle
    End With
    uaPts(0).X = sngX - sngMarkXOff
    uaPts(1).X = sngX + sngMarkXOff
    uaPts(0).Y = sngY - sngMarkYOff
    uaPts(1).Y = sngY + sngMarkYOff

    DrawMarkerCircle = uaPts()

    'free the memory
    Erase uaPts

End Function

Private Function DrawMarkerTriangle(sngX As Single, sngY As Single, lngColor As Long) As PointAPI()

    'input parameters represent the center of the triangle
    
    On Error Resume Next
    
    Dim lRet As Long
    Dim lngFillColor As Long
    Dim lngFillStyle As Long
    Dim sngMarkYOff As Single
    Dim sngMarkXOff As Single
    Dim intScaleMode As Integer
    Dim uaPts(2) As PointAPI
    Dim uaPtspicBox(1) As PointAPI

    'the polygon function works only with pixels!
    intScaleMode = UserControl.ScaleMode
    UserControl.ScaleMode = vbPixels
    
    'setup the 3 points of the triangle anti-clockwise
    '     (1)
    '    /   \
    '   /     \
    ' (0)-----(2)
    
    sngMarkYOff = uMarkerWidth * Screen.TwipsPerPixelY / 2
    sngMarkXOff = uMarkerWidth * Screen.TwipsPerPixelX / 2
    
    uaPts(0).X = (sngX - sngMarkXOff) / Screen.TwipsPerPixelX
    uaPts(1).X = sngX / Screen.TwipsPerPixelX
    uaPts(2).X = (sngX + sngMarkXOff) / Screen.TwipsPerPixelX
    
    uaPts(0).Y = (sngY + sngMarkYOff) / Screen.TwipsPerPixelY
    uaPts(1).Y = sngY / Screen.TwipsPerPixelY
    uaPts(2).Y = (sngY + sngMarkYOff) / Screen.TwipsPerPixelY
    
    'draw the filled triangle
    lngFillColor = UserControl.FillColor
    lngFillStyle = UserControl.FillStyle
    UserControl.FillStyle = vbSolid
    UserControl.FillColor = lngColor
    lRet = Polygon(UserControl.hDC, uaPts(0), 3)
    UserControl.FillColor = lngFillColor
    UserControl.FillStyle = lngFillStyle
    
    'reset the scalemode
    UserControl.ScaleMode = intScaleMode
    
    'assign return values
    uaPtspicBox(0).X = uaPts(0).X * Screen.TwipsPerPixelX
    uaPtspicBox(0).Y = uaPts(1).Y * Screen.TwipsPerPixelY
    uaPtspicBox(1).X = uaPts(2).X * Screen.TwipsPerPixelX
    uaPtspicBox(1).Y = uaPts(2).Y * Screen.TwipsPerPixelY
    
    'free the memory
    Erase uaPts
    
    DrawMarkerTriangle = uaPtspicBox()
    
End Function


Private Function DrawMarkerRhombus(sngX As Single, sngY As Single, lngColor As Long) As PointAPI()

    'input parameters represent the center of the rhombus
    
    On Error Resume Next
    
    Dim lRet As Long
    Dim lngFillStyle As Long
    Dim lngFillColor As Long
    Dim sngMarkYOff As Single
    Dim sngMarkXOff As Single
    Dim intScaleMode As Integer
    Dim uaPts(3) As PointAPI
    Dim uaPtspicBox(1) As PointAPI
    
    sngMarkXOff = (uMarkerWidth * 2 * Screen.TwipsPerPixelX) / 4    'consider the 25% as X-offset
    sngMarkYOff = uMarkerWidth / 2 * Screen.TwipsPerPixelY          'consider the 50% as Y-offset
    
    'the polygon function works only with pixels!
    intScaleMode = UserControl.ScaleMode
    UserControl.ScaleMode = vbPixels
    
    'setup the 4 points of the Rhombus anti-clockwise
    '     (1)
    '    /   \
    '   /     \
    ' (0)     (2)
    '   \     /
    '    \   /
    '     (3)
    
    uaPts(0).X = (sngX - sngMarkXOff) / Screen.TwipsPerPixelX
    uaPts(1).X = sngX / Screen.TwipsPerPixelX
    uaPts(2).X = (sngX + sngMarkXOff) / Screen.TwipsPerPixelX
    uaPts(3).X = sngX / Screen.TwipsPerPixelX
    
    uaPts(0).Y = sngY / Screen.TwipsPerPixelY
    uaPts(1).Y = (sngY - sngMarkYOff) / Screen.TwipsPerPixelY
    uaPts(2).Y = sngY / Screen.TwipsPerPixelY
    uaPts(3).Y = (sngY + sngMarkYOff) / Screen.TwipsPerPixelY
    
    'draw the filled Rhombus
    lngFillColor = UserControl.FillColor
    lngFillStyle = UserControl.FillStyle
    UserControl.FillStyle = vbSolid
    UserControl.FillColor = lngColor
    lRet = Polygon(UserControl.hDC, uaPts(0), 4)
    UserControl.FillColor = lngFillColor
    UserControl.FillStyle = lngFillStyle
    
    'reset the scalemode
    UserControl.ScaleMode = intScaleMode
    
    'assign return values
    uaPtspicBox(0).X = uaPts(0).X * Screen.TwipsPerPixelX
    uaPtspicBox(0).Y = uaPts(1).Y * Screen.TwipsPerPixelY
    uaPtspicBox(1).X = uaPts(2).X * Screen.TwipsPerPixelX
    uaPtspicBox(1).Y = uaPts(3).Y * Screen.TwipsPerPixelY
    
    'free the memory
    Erase uaPts
    
    DrawMarkerRhombus = uaPtspicBox()

End Function


Private Function DrawMarkerTrapezium(sngX As Single, sngY As Single, lngColor As Long) As PointAPI()

    'input parameters represent the center of the trapezium
    
    On Error Resume Next
    
    Dim lRet As Long
    Dim lngFillStyle As Long
    Dim lngFillColor As Long
    Dim sngMarkYOff As Single
    Dim sngMarkXOff As Single
    Dim intScaleMode As Integer
    Dim uaPts(3) As PointAPI
    Dim uaPtspicBox(1) As PointAPI
    
    'the polygon function works only with pixels!
    intScaleMode = UserControl.ScaleMode
    UserControl.ScaleMode = vbPixels