xpie.ctl

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

        Next intCount
    End With

End Sub

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

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

Private Function Tracking(X As Single, Y As Single) As Integer
    
    Dim gitem As PieGroup
    Dim oItem As PieSegment
    Dim intSelectedCol As Integer
    
    If Not bProcessingOver Then
        bProcessingOver = True
        intSelectedCol = InSegment(X, Y)
        If (intSelectedCol >= 0) And (intSelectedCol <> uOldSelection) Then
            uSelected = intSelectedCol
            DrawChart
            uOldSelection = uSelected
            If uGroupSegment = False Then
                oItem = cItems(uSelected + 1)
                RaiseEvent ItemClick(oItem)
            Else
                gitem = cGroups(uSelected + 1)
                RaiseEvent ItemGroupClick(gitem)
            End If
        End If
        bProcessingOver = False
    End If
    Tracking = intSelectedCol
    Exit Function
    
Tracking_error:
    Tracking = -1
    Exit Function
    
End Function

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 PieSegment) As Boolean
    
    cItems.Add cItem
    
    dblPieTotal = dblPieTotal + cItem.Value
    Call HandleSegments
    Call GroupSegments
    
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 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 varItems As Variant
    Dim sDescription As String
    Dim dblPercentage As Double
    
    '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
            If uInfoItems = Empty Then uInfoItems = INFO_ITEMS
            varItems = Split(uInfoItems, "|")
            '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 uGroupSegment = False Then
                With cItems.Item(intIdx + 1)
                    sDescription = CStr(varItems(0)) & ": " & Format(.Value, uDataFormat)
                    If Len(.SelectedDescription) > 0 Then
                        sDescription = CStr(varItems(1)) & ": " & .SelectedDescription & vbCrLf & sDescription
                        dblPercentage = cItemsAttributes.Item(intIdx + 1).Percentage
                    End If
                End With
            Else
                With cGroups.Item(intIdx + 1)
                    sDescription = CStr(varItems(0)) & ": " & Format(.Value, uDataFormat)
                    If Len(.Name) > 0 Then
                        sDescription = CStr(varItems(1)) & ": " & .Name & vbCrLf & sDescription
                        dblPercentage = cGroupsAttributes.Item(intIdx + 1).Percentage
                    End If
                End With
            End If
        End If
        If sDescription <> Empty Then
            With lblInfo
                sDescription = sDescription & " (" & Format$(dblPercentage, "#0.00\%") & ")"
                .Caption = sDescription
                .Width = UserControl.TextWidth(sDescription) + 5 * Screen.TwipsPerPixelX
                .Height = UserControl.TextHeight(sDescription) * 1.2
                .Visible = True
            End With
        End If
    End If
    Exit Sub

DrawChart_error:
    uInfoItems = INFO_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 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 Function EditCopy() As Boolean
    Clipboard.SetData UserControl.Image
End Function

Private Sub FixMenu()
    
    '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 FixMenu_error
    
    Dim varItems As Variant
    
    If uMenuItems = Empty Then
        uMenuItems = MENU_ITEMS
    End If
    varItems = Split(uMenuItems, "|")
    
    If varItems(0) <> Empty Then
        mnuMainSaveAs.Caption = CStr(varItems(0))
    Else
        mnuMainSaveAs.Caption = "&Save as..."
    End If
    
    If varItems(1) <> Empty Then
        mnuMainPrint.Caption = CStr(varItems(1))
    Else
        mnuMainPrint.Caption = "&Print"
    End If
    
    If varItems(2) <> Empty Then
        mnuMainCopy.Caption = CStr(varItems(2))
    Else
        mnuMainCopy.Caption = "&Copy"
    End If
    
    If varItems(3) <> Empty Then
        mnuMainSelectionInfo.Caption = CStr(varItems(3))
    Else
        mnuMainSelectionInfo.Caption = "Selection &information"
    End If
    
    If varItems(4) <> Empty Then
        mnuMainViewLegend.Caption = CStr(varItems(4))
    Else
        mnuMainViewLegend.Caption = "&Legend"
    End If
    
    If varItems(5) <> Empty Then
        mnuLegendHide.Caption = CStr(varItems(5))
    Else
        mnuLegendHide.Caption = "&Hide"
    End If

    If uMenuType = xcButtonMenu Then
        picCommands.Visible = True
        picCommands.BackColor = UserControl.BackColor
        picCommands.Move 60, 60
        If lblInfo.Visible = False Then
            lblInfo.Move picCommands.Left + picCommands.ScaleWidth + 60, 60
        End If
    Else
        picCommands.Visible = False
        If lblInfo.Visible = False Then
            lblInfo.Move 60, 60
        End If
    End If
    If picInfoPie.Visible = False Then
        picInfoPie.Move lblInfo.Left, lblInfo.Top + lblInfo.Height + 60
    End If
    Exit Sub
    
FixMenu_error:
    uMenuItems = MENU_ITEMS
    Resume Next

End Sub
Private Sub FixGroupExplodeMenu()
    
    '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 FixMenu_error
    
    Dim stgData As String
    Dim intIdx As Integer
    Dim varItems As Variant
    
    If uGroupExplodeMenuItems = Empty Then
        uGroupExplodeMenuItems = GROUP_EXPLODE_MENU_ITEMS
    Else
        stgData = Empty
        varItems = Split(uGroupExplodeMenuItems, "|")
        
        If varItems(0) <> Empty Then
            stgData = CStr(varItems(0))
        Else
            stgData = "&OK"
        End If
        
        If varItems(1) <> Empty Then
            stgData = stgData & "|" & CStr(varItems(1))
        Else
            stgData = stgData & "|&Print"
        End If
        
        'new errore handling
        On Error Resume Next
        For intIdx = 2 To UBound(varItems)
            stgData = stgData & "|" & CStr(varItems(intIdx))
        Next
        uGroupExplodeMenuItems = stgData
    End If
    Exit Sub
    
FixMenu_error:
    uGroupExplodeMenuItems = GROUP_EXPLODE_MENU_ITEMS
    Resume Next

End Sub


Private Sub FixCustomMenu()
    
    On Error Resume Next
    
    Dim ctl As Control
    Dim intIdx As Integer
    Dim stgItem As String
    Dim varItems As Variant
    Dim intItemCnt As Integer
    
    For Each ctl In mnuMainCustomItems
        ctl.Visible = False
    Next
    If Trim(uCustomMenuItems) <> Empty Then
        varItems = Split(uCustomMenuItems, "|")