xpie.ctl

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

Private uSaveAsCaption    As String       'the SaveAs dialog picBox caption
Private uOldSelection     As Long
Private uGroupSegment     As Boolean      'indicates if the pie's segments must be grouped
                                          '(Group property of PieSegment type) or not
Private uGroupExplode           As Boolean 'indicates if the group must be exploded (meaningful only if uGroupSegment=True)
Private uGroupExplodeBackColor  As Long   'the group explosion form's backcolor
Private uGroupExplodeForeColor  As Long   'the group explosion form's forecolor
Private uGroupExplodeTitleColor As Long   'the group explosion form's title color
Private uGroupExplodeMenuItems  As String 'the menu's items in the group explosion form
Private uGroupExplodeAllowCommands As Boolean 'indicates if the command buttons in the group form are allowed (meaningful only if uGroupExplode=True)
Private Const GROUP_EXPLODE_MENU_ITEMS = "&OK|&Print"

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

Private uInfoPieBackColor       As Long    'the group information picBox background color
Private uInfoPieForeColor       As Long    'the group information picBox foreground color

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 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 uTopMargin        As Single       '--------------------------------------
Private uBottomMargin     As Single       'margins used around the pie content
Private uLeftMargin       As Single       '
Private uRightMargin      As Single
Private uRightMarginOrg   As Single       '--------------------------------------
Private uDisplayDescript  As Boolean      'display description when selectable
Private uChartTitle       As String       'chart title
Private uChartSubTitle    As String       'chart sub title
Private uHotTracking      As Boolean      'marker indicating use of hot tracking

Private offsetX           As Long
Private offsetY           As Long
Private sngRadius         As Single
Private sngPieXCenter     As Single
Private sngPieYCenter     As Single
Private dblPieTotal       As Double

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 CoordConv
    X As Single
    Y As Single
    Angle As Double
    Radius As Double
End Type

Public Type PieSegment
    ItemID As String
    Group As String
    GroupColor As Long
    SelectedDescription As String
    LegendDescription As String
    Description As String
    Value As Double
    Color As Long
End Type
Private cItems As Collection   'collection of chart items

Public Type PieSegmentAttributes
    AngleFrom As Single
    AngleTo As Single
    Percentage As Double
End Type
Private cItemsAttributes As Collection

Public Type PieGroup
    Value As Double
    Name As String
    Color As Long
End Type
Private cGroups As Collection   'collection of pie groups

Public Type PieGroupAttributes
    AngleFrom As Single
    AngleTo As Single
    Percentage As Double
End Type
Private cGroupsAttributes As Collection

Public Event ItemClick(cItem As PieSegment)
Public Event ItemGroupClick(cItem As PieGroup)
Public Event MenuItemClick(intMenuItemIndex As Integer, stgMenuItemCaption As String)
Public Event GroupMenuItemClick(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

Private Sub HandleSegments()
    
    Dim sngAngle As Single
    Dim intCount As Integer
    Dim dblPercentage As Double
    Dim dblSegmentTotal As Double
    Dim dblPercentageTotal As Double
    Dim dblPercentageRemainder As Double
    Dim oSAttr As PieSegmentAttributes
    
    On Error GoTo errHandle
    
    'define segments' attributes
    dblSegmentTotal = 100
    dblPercentageTotal = 0
    dblPercentageRemainder = 0
    Set cItemsAttributes = Nothing
    Set cItemsAttributes = New Collection
    With cItems
        For intCount = 1 To .Count
            'total segment percentage is decreased only if we are after the first segment
            If (intCount > 1) Then
                oSAttr.AngleFrom = cItemsAttributes(intCount - 1).AngleTo
                dblSegmentTotal = dblSegmentTotal - cItemsAttributes(intCount - 1).Percentage
            Else
                oSAttr.AngleFrom = 0
            End If
            'calculate percentage/angle and add to the proper collection
            If intCount = .Count Then
                'last item's percentage corresponds to the remainder (100-assigned)
                dblPercentage = 100 - dblPercentageTotal
            Else
                'item by item, add the previous remainder value
                '(difference between double value and rounded value)
                dblPercentage = ((.Item(intCount).Value / dblPieTotal) * 100) + dblPercentageRemainder
                If (dblPercentage - Round(dblPercentage, 2)) > 0 Then
                    'the remainder is saved only in case the value was not rounded by excess
                    dblPercentageRemainder = dblPercentage - Round(dblPercentage, 2)
                Else
                    dblPercentageRemainder = 0
                End If
                'increment total percentage
                dblPercentageTotal = dblPercentageTotal + dblPercentage
            End If
            sngAngle = 360 * dblPercentage / 100
            oSAttr.AngleTo = oSAttr.AngleFrom + sngAngle
            oSAttr.Percentage = Round(dblPercentage, 2)
            cItemsAttributes.Add oSAttr
        Next intCount
    End With
    Exit Sub

errHandle:
    Exit Sub
End Sub

Private Function Radians(ByVal Degrees As Single) As Double
    Radians = CDbl(Degrees) * PI / 180
End Function

Private Function ConvertCoordinates(X As Single, Y As Single) As CoordConv
    
    Dim sngY1 As Single
    Dim sngX1 As Single
    Dim sngAngle As Single
    Dim oConv As CoordConv
    
    sngX1 = X / Screen.TwipsPerPixelX
    sngY1 = Y / Screen.TwipsPerPixelY
    sngX1 = (sngPieXCenter - sngX1)     'calculate in respect to center
    sngY1 = (sngPieYCenter - sngY1)     'calculate in respect to center
    sngAngle = CSng(Atn(sngY1 / IIf(sngX1 = 0, 0.00000001, sngX1))) * 180 / PI
    'these calculations are valid in case the graduation is as follows:
    '
    '              0
    '              |
    '              |
    ' 90-----------+----------270
    '              |
    '              |
    '             180
    '
    If (sngX1 < 0) And (sngY1 >= 0) Then
        sngAngle = 270 + Abs(sngAngle)
    ElseIf (sngX1 >= 0) And (sngY1 >= 0) Then
        sngAngle = 90 - sngAngle
    ElseIf (sngX1 >= 0) And (sngY1 < 0) Then
        sngAngle = 90 + Abs(sngAngle)
    ElseIf (sngX1 < 0) And (sngY1 < 0) Then
        sngAngle = 270 - Abs(sngAngle)
    End If
        
'    'these calculations are valid in case the graduation is as follows:
'    '
'    '              90
'    '              |
'    '              |
'    ' 180----------+----------0
'    '              |
'    '              |
'    '             270
'    '
'    If (sngX1 < 0) And (sngY1 >= 0) Then
'        sngAngle = Abs(sngAngle)
'    ElseIf (sngX1 >= 0) And (sngY1 >= 0) Then
'        sngAngle = 180 - sngAngle
'    ElseIf (sngX1 >= 0) And (sngY1 < 0) Then
'        sngAngle = 180 - sngAngle
'    ElseIf (sngX1 < 0) And (sngY1 < 0) Then
'        sngAngle = 360 - sngAngle
'    End If

    With oConv
        .X = sngX1
        .Y = sngY1
        .Angle = sngAngle
        .Radius = Sqr(sngX1 * sngX1 + sngY1 * sngY1)
    End With
    
    ConvertCoordinates = oConv

End Function

Private Sub DrawSegmentText(sngAngleFrom As Single, sngAngleTo As Single, intItemIdx As Integer)
    
    On Error GoTo errHandle

    Dim lngW As Long
    Dim lngH As Long
    Dim sngX1 As Single
    Dim sngY1 As Single
    Dim lngColor As Long
    Dim stgDesc As String
    Dim sngXoff As Single
    Dim sngYoff As Single
    Dim sngAngle As Single
    Dim sngAngleRad As Single

    sngAngle = sngAngleFrom + (sngAngleTo - sngAngleFrom) / 2
    sngAngleRad = Radians(sngAngle)
    sngXoff = Sin(sngAngleRad) * sngRadius
    sngYoff = Cos(sngAngleRad) * sngRadius

    With UserControl
        lngColor = .ForeColor
        If uGroupSegment = False Then
            stgDesc = cItems(intItemIdx).Description
            .ForeColor = IIf(((intItemIdx - 1) = uSelected And uSelectable), uSelectedColor, uMarkerColor)
        Else
            stgDesc = cGroups(intItemIdx).Name
            .ForeColor = IIf(((intItemIdx - 1) = uSelected And uSelectable), uSelectedColor, uMarkerColor)
        End If
    
        sngX1 = sngPieXCenter - sngXoff
        sngY1 = sngPieYCenter - sngYoff
        '
        '              0
        '              |
        '              |
        ' 90-----------+----------270
        '              |
        '              |
        '             180
        '
        lngW = .TextWidth(stgDesc) / Screen.TwipsPerPixelX / 2
        lngH = .TextHeight(stgDesc) / Screen.TwipsPerPixelY / 2
        If sngAngle >= 0 And sngAngle < 90 Then
            sngX1 = sngX1 - lngW
            sngY1 = sngY1 - lngH
        ElseIf sngAngle >= 90 And sngAngle < 180 Then
            sngX1 = sngX1 - lngW
            sngY1 = sngY1 + lngH
        ElseIf sngAngle >= 180 And sngAngle < 270 Then
            sngX1 = sngX1 + lngW
            sngY1 = sngY1 + lngH
        Else
            sngX1 = sngX1 + lngW
            sngY1 = sngY1 - lngH
        End If
        PrintRotText .hDC, stgDesc, sngX1, sngY1, 0
        .ForeColor = lngColor
    End With
    Exit Sub
    
errHandle:
    Exit Sub
    

End Sub

Private Sub GroupSegments()
    
    'important: before grouping segments, it has to be defined
    'segments' attributes!!!

    Dim intIdx As Integer
    Dim intCount As Integer
    Dim oGroup As PieGroup
    Dim stgGroup As String
    Dim stgGroups As String
    Dim stgColor As String
    Dim stgGroupsColor As String
    Dim dblSegmentTotal As Double
    Dim oGAttr As PieGroupAttributes
    Dim dblPercentage As Double
    Dim sngAngle As Single
    Dim dblPercentageTotal As Double
    Dim dblPercentageRemainder As Double
    
    'verify how may groups there are in segments
    dblSegmentTotal = 0
    stgGroups = Empty
    stgGroupsColor = Empty
    For intCount = 1 To cItems.Count
        stgGroup = cItems(intCount).Group
        If InStr(stgGroups, stgGroup) = 0 Then
            'add group name to the list
            stgGroups = stgGroups & stgGroup & Chr$(0)
            'and group color
            stgGroupsColor = stgGroupsColor & CStr(cItems(intCount).GroupColor) & Chr$(0)
        End If
    Next
    
    'set new groups' collection
    Set cGroups = Nothing
    Set cGroups = New Collection
    intIdx = 1
    While intIdx > 0
        stgGroup = TokenByPos(stgGroups, intIdx, Chr$(0))
        If stgGroup = "" Then
            'no more items in the groups' list
            intIdx = -1
        Else
            dblSegmentTotal = 0
            stgColor = TokenByPos(stgGroupsColor, intIdx, Chr$(0))
            For intCount = 1 To cItems.Count
                If cItems(intCount).Group = stgGroup Then
                    dblSegmentTotal = dblSegmentTotal + cItems(intCount).Value
                End If
            Next
            With oGroup
                .Value = dblSegmentTotal
                .Name = stgGroup
                .Color = CLng(stgColor)
            End With
            cGroups.Add oGroup
            intIdx = intIdx + 1
        End If
    Wend
    
    'groups' attributes
    dblSegmentTotal = 100
    Set cGroupsAttributes = Nothing
    Set cGroupsAttributes = New Collection
    dblPercentageTotal = 0
    dblPercentageRemainder = 0
    With cGroups
        For intCount = 1 To .Count
            'total segment percentage is decreased only if we are after the first segment
            If intCount > 1 Then
                oGAttr.AngleFrom = cGroupsAttributes(intCount - 1).AngleTo
                dblSegmentTotal = dblSegmentTotal - cGroupsAttributes(intCount - 1).Percentage
            Else
                oGAttr.AngleFrom = 0
            End If
            'calculate percentage, basing on percentage of single segments, belonging to the group
            dblPercentage = 0
            For intIdx = 1 To cItems.Count
                If cItems(intIdx).Group = .Item(intCount).Name Then
                    dblPercentage = dblPercentage + cItemsAttributes(intIdx).Percentage
                End If
            Next
            sngAngle = 360 * dblPercentage / 100
            oGAttr.AngleTo = oGAttr.AngleFrom + sngAngle
            oGAttr.Percentage = dblPercentage
            cGroupsAttributes.Add oGAttr