xquadrant.ctl

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

    
    'setup the 4 points of the trapezium
    sngMarkYOff = (uMarkerWidth * Screen.TwipsPerPixelX) / 2 'consider the 50% as Y-offset
    sngMarkXOff = (uMarkerWidth * Screen.TwipsPerPixelX * 2) / 4 'consider the 25% as X-offset
    'set the points anti-clockwise
    '     (1)-----(2)
    '    /           \
    '   /             \
    ' (0)-------------(3)
    
    uaPts(0).X = (sngX - sngMarkXOff * 2) / Screen.TwipsPerPixelX
    uaPts(1).X = (sngX - sngMarkXOff) / Screen.TwipsPerPixelX
    uaPts(2).X = (sngX + sngMarkXOff) / Screen.TwipsPerPixelX
    uaPts(3).X = (sngX + sngMarkXOff * 2) / Screen.TwipsPerPixelX
    
    uaPts(0).Y = (sngY + sngMarkYOff) / Screen.TwipsPerPixelY
    uaPts(1).Y = (sngY - sngMarkYOff) / Screen.TwipsPerPixelY
    uaPts(2).Y = (sngY - sngMarkYOff) / Screen.TwipsPerPixelY
    uaPts(3).Y = (sngY + sngMarkYOff) / Screen.TwipsPerPixelY
    
    'draw the filled trapezium
    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(3).X * Screen.TwipsPerPixelX
    uaPtspicBox(1).Y = uaPts(1).Y * Screen.TwipsPerPixelY
    
    'free the memory
    Erase uaPts
    
    DrawMarkerTrapezium = uaPtspicBox()

End Function

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

Public Property Get LegendPrintMode() As LegendPrintConstants
    LegendPrintMode = uLegendPrintMode
End Property

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

Public Property Get Selectable() As Boolean
    Selectable = uSelectable
End Property
Public Property Get SelectedColor() As OLE_COLOR
    SelectedColor = uSelectedColor
End Property
Public Property Let SelectedColor(lngVal As OLE_COLOR)
    If lngVal <> uSelectedColor Then
        uSelectedColor = lngVal
        PropertyChanged "SelectedColor"
    End If
End Property


Public Function AddItem(cItem As ChartItem) As Boolean
    
    cItems.Add cItem
    
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 MarkerLabelAngle() As Integer
Attribute MarkerLabelAngle.VB_Description = "Returns/sets a value that determines the rotation angle of the marker label."
    
    MarkerLabelAngle = uMarkerLabelAngle

End Property
Public Property Get MarkerLabelDirection() As MarkerDirectionConstants
Attribute MarkerLabelDirection.VB_Description = "Returns/sets a value that determines the direction of the marker label."
    
    MarkerLabelDirection = uMarkerLabelDirection

End Property



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
Attribute PrinterOrientation.VB_Description = "Returns/sets a value that determines the orientation of the output sent to the printer."
    PrinterOrientation = uPrinterOrientation
End Property
Public Property Get PrinterFit() As PrinterFitConstants
    PrinterFit = uPrinterFit
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
Public Property Let PrinterFit(intVal As PrinterFitConstants)
    uPrinterFit = intVal
    PropertyChanged "PrinterFit"
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 DrawChart_error
        
                If uInfoItems = Empty Then uInfoItems = INFO_ITEMS
                varItems = Split(uInfoItems, "|")
                sDescription = CStr(varItems(0)) & ": " & Format(.XValue, uDataFormat) & "/" & Format(.YValue, uDataFormat)
                If Len(.SelectedDescription) > 0 Then
                    sDescription = CStr(varItems(1)) & ": " & .SelectedDescription & vbCrLf & sDescription
                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

DrawChart_error:
    uInfoItems = INFO_ITEMS
    Resume Next

End Sub

Private Sub DisplayQuadrantInfo()

    Dim x1 As Single
    Dim y1 As Single
    Dim sngY As Single
    Dim intIdx As Integer
    Dim varItems As Variant
    Dim sDescription As String

    'it's important to let the info label invisible at beginning to avoid flickering effect
    picInfoQuadrant.Visible = False
    If uDisplayQuadrantDescript Then
        '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 DisplayQuadrantInfo_error
    
        If uInfoQuadrantItems = Empty Then uInfoQuadrantItems = INFO_QUADRANT_ITEMS
        varItems = Split(uInfoQuadrantItems, "|")
        For intIdx = 0 To UBound(varItems)
            sDescription = sDescription & CStr(varItems(intIdx)) & vbCrLf
        Next
        If sDescription <> Empty Then
            With picInfoQuadrant
                .BackColor = uInfoQuadrantBackColor
                .ForeColor = uInfoQuadrantForeColor
                .Cls
                .Width = .TextWidth(sDescription) + 15 * Screen.TwipsPerPixelX
                .Height = (UBound(varItems) + 1) * .TextHeight("A") + 5 * Screen.TwipsPerPixelY
                sngY = 2 * Screen.TwipsPerPixelY
                For intIdx = 0 To UBound(varItems)
                    x1 = 3 * Screen.TwipsPerPixelX
                    y1 = sngY + 4 * Screen.TwipsPerPixelY
                    .CurrentY = sngY
                    .CurrentX = 10 * Screen.TwipsPerPixelX
                    picInfoQuadrant.Print CStr(varItems(intIdx))
                    sngY = .CurrentY
                    picInfoQuadrant.Line (x1, y1)-(x1 + 3 * Screen.TwipsPerPixelX, y1 + 3 * Screen.TwipsPerPixelY), uQuadrantColor(intIdx), BF
                Next
                .Visible = True
            End With
        End If
    End If
    Exit Sub

DisplayQuadrantInfo_error:
    uInfoQuadrantItems = INFO_QUADRANT_ITEMS
    Resume Next

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
        UserControl.PaintPicture pic, _
                            sngX1, sngY1, _
                            IIf((sngX2 - sngX1) < Screen.TwipsPerPixelX, Screen.TwipsPerPixelX, (sngX2 - sngX1)), _
                            IIf((sngY2 - sngY1) < Screen.TwipsPerPixelY, Screen.TwipsPerPixelY, (sngY2 - sngY1))
    End If

End Sub

Private Sub FixLegendCaption()
    uLegendCaption = IIf(uLegendCaption = Empty, LEGEND_CAPTION, uLegendCaption)
End Sub

Public Property Let LegendCaption(stgVal As String)
    uLegendCaption = stgVal
    FixLegendCaption
End Property

Public Property Let MarkerWidth(intVal As Integer)
    
    If intVal <> uMarkerWidth Then
        If intVal > 0 And intVal <= 16 Then
            uMarkerWidth = intVal
            DrawChart
            PropertyChanged "MarkerWidth"
        End If
    End If

End Property

Public Property Get MarkerWidth() As Integer
Attribute MarkerWidth.VB_Description = "Returns/sets the width of the line displayed in the chart."
    MarkerWidth = uMarkerWidth
End Property
Public Property Get MinorGridOn() As Boolean
Attribute MinorGridOn.VB_Description = "Returns/sets a value that determines if the minor grid is visible or hidden."
    MinorGridOn = uMinorGridOn
End Property

Public Property Get MajorGridOn() As Boolean
Attribute MajorGridOn.VB_Description = "Returns/sets a value that determines if the major grid is visible or hidden."
    MajorGridOn = uMajorGridOn
End Property

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

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

Public Property Set Picture(ByVal picVal As StdPicture)
    Set uPicture = picVal
    DrawChart
End Property


Public Property Get Picture() As Picture
Attribute Picture.VB_Description = "Returns/sets a graphic to be displayed as background of the chart."
    Set Picture = uPicture
End Property

Public Property Get MarkerSymbol() As MarkerSymbolConstants
Attribute MarkerSymbol.VB_Description = "Returns/sets the character to be displayed in place of the bar."
    MarkerSymbol = uMarkerSymbol
End Property

Public Property Let MarkerSymbol(intVal As MarkerSymbolConstants)
    If intVal <> uMarkerSymbol Then
        uMarkerSymbol = intVal
        DrawChart
        PropertyChanged "MarkerSymbol"
    End If
End Property

Public Function EditCopy() As Boolean
    Clipboard.SetData UserControl.Image
End Function

Private Sub FixData()

    If uMinYValue < 0 And uMaxYValue < 0 Then
        uDataTypeY = DT_NEG
        uRangeY = (Abs(uMinYValue) - Abs(uMaxYValue))
    ElseIf uMinYValue >= 0 And uMaxYValue >= 0 Then
        uDataTypeY = DT_POS
        uRangeY = (Abs(uMaxYValue) - Abs(uMinYValue))
    Else
        uDataTypeY = DT_BOTH
        uRangeY = (Abs(uMaxYValue) + Abs(uMinYValue))
    End If

    If uRangeY = 0 Then uRangeY = 1
    If uIntersectMajorY = 0 Then uIntersectMajorY = uRangeY / 10