frmtest.frm

来自「多种图表的绘制及其运用」· FRM 代码 · 共 682 行 · 第 1/2 页

            '-----------------------------------------------------------------------------
            'these settings are useful to see how percentage is calculated and distributed
            'onto single segments and groups
            For X = 1 To 8
                With oChartItem
                    .Value = 1
                    .ItemID = X
                    .Description = X
                    .SelectedDescription = X
                    .LegendDescription = X
                    .Color = vbYellow
                    .Group = "1st"
                    .GroupColor = vbYellow
                End With
                .AddItem oChartItem
    
                grd.AddItem X & vbTab & oChartItem.SelectedDescription & vbTab & oChartItem.Value
                grd.RowData(grd.Rows - 1) = oChartItem.GroupColor
            Next
            For X = 1 To 8
                With oChartItem
                    .Value = 1
                    .ItemID = X
                    .Description = X
                    .SelectedDescription = X
                    .LegendDescription = X
                    .Color = vbRed
                    .Group = "2nd"
                    .GroupColor = vbRed
                End With
                .AddItem oChartItem
    
                grd.AddItem X & vbTab & oChartItem.SelectedDescription & vbTab & oChartItem.Value
                grd.RowData(grd.Rows - 1) = oChartItem.GroupColor
            Next
            For X = 1 To 3
                With oChartItem
                    .Value = 1
                    .ItemID = X
                    .Description = X
                    .SelectedDescription = X
                    .LegendDescription = X
                    .Color = vbBlue
                    .Group = "3rd"
                    .GroupColor = vbBlue
                End With
                .AddItem oChartItem
    
                grd.AddItem X & vbTab & oChartItem.SelectedDescription & vbTab & oChartItem.Value
                grd.RowData(grd.Rows - 1) = oChartItem.GroupColor
            Next
            '-----------------------------------------------------------------------------
        Else
            Randomize
            For X = 1 To UBound(varMonths) + 1
                With oChartItem
                    .Value = CDbl(Rnd(UBound(varMonths) + 1) * 1000)
                    .Value = Round(.Value, 2)
                    .ItemID = X
                    .Description = varMonths(X - 1)
                    .SelectedDescription = "Month " & varMonthsExt(X - 1)
                    .LegendDescription = "Month " & varMonthsExt(X - 1)
                    If Check1(0).Value = vbUnchecked Then
                        .Group = ""
                    End If
                    If X >= 1 And X <= 3 Then
                        .Color = vbBlue
                        .Group = "1st quarter"
                        .GroupColor = vbBlue
                    ElseIf X >= 4 And X <= 6 Then
                        .Color = vbGreen
                        .Group = "2nd quarter"
                        .GroupColor = vbGreen
                    ElseIf X >= 7 And X <= 9 Then
                        .Color = vbRed
                        .Group = "3rd quarter"
                        .GroupColor = vbRed
                    Else
                        .Color = vbYellow
                        .Group = "4th quarter"
                        .GroupColor = vbYellow
                    End If
                End With
                .AddItem oChartItem
        
                grd.AddItem X & vbTab & oChartItem.SelectedDescription & vbTab & oChartItem.Value
                grd.RowData(grd.Rows - 1) = oChartItem.GroupColor
            Next X
        End If
        .DrawChart
    End With
    grd.RowSel = 0

End Sub

Private Sub RefreshData()
    
    Dim intIdx As Integer
    
    With XPie1
        Label1(0).BackColor = .BackColor
        Label1(1).BackColor = .ChartTitleColor
        Label1(2).BackColor = .ChartSubTitleColor
        Label1(3).BackColor = .pieborderColor
        Label1(9).BackColor = .LegendForeColor
        Label1(10).BackColor = .LegendbackColor
        Label1(11).BackColor = .InfoForeColor
        Label1(12).BackColor = .InfoBackColor
        Label1(15).BackColor = .SelectedColor
        Label1(16).BackColor = .MarkerColor
        Label1(17).BackColor = .InfoPieforeColor
        Label1(18).BackColor = .InfoPieBackColor
        Option1(.MenuType).Value = True
        Check1(1).Value = IIf((.PictureTile = True), vbChecked, vbUnchecked)
        Check1(0).Value = IIf((.GroupSegment = True), vbChecked, vbUnchecked)
        Check1(3).Value = IIf((.HotTRacking = True), vbChecked, vbUnchecked)
        For intIdx = 0 To cboPrtMode.ListCount - 1
            If cboPrtMode.ItemData(intIdx) = .PrinterFit Then
                cboPrtMode.ListIndex = intIdx
                Exit For
            End If
        Next
    End With
    
End Sub

Private Sub Check1_Click(Index As Integer)

'    Dim lngRow As Long
'    Dim lngCol As Long
'
'    If Index = 0 Then
'        With XPie1
'            .GroupSegment = IIf(Check1(0).Value = vbChecked, True, False)
'            .SelectedColumn = -1
'        End With
'        For lngRow = grd.FixedRows To grd.Rows - 1
'            grd.Row = lngRow
'            For lngCol = grd.FixedCols To grd.Cols - 1
'                grd.Col = lngCol
'                grd.CellBackColor = vbWhite
'            Next
'        Next
'    End If

End Sub

Private Sub Command1_Click()

    With XPie1
        .AutoRedraw = False
        .BackColor = Label1(0).BackColor
        .ChartTitleColor = Label1(1).BackColor
        .ChartSubTitleColor = Label1(2).BackColor
        .pieborderColor = Label1(3).BackColor
        .LegendForeColor = Label1(9).BackColor
        .LegendbackColor = Label1(10).BackColor
        .InfoForeColor = Label1(11).BackColor
        .InfoBackColor = Label1(12).BackColor
        .SelectedColor = Label1(15).BackColor
        .MarkerColor = Label1(16).BackColor
        .InfoPieforeColor = Label1(17).BackColor
        .InfoPieBackColor = Label1(18).BackColor
        If Option1(0).Value = True Then
            .MenuType = xcPopUpMenu
        Else
            .MenuType = xcButtonMenu
        End If
        .PictureTile = IIf((Check1(1).Value = vbChecked), True, False)
        
        PrepareData (1)
        If Check1(2).Value = vbUnchecked Then
            Set .Picture = Nothing
        Else
            Set .Picture = LoadPicture(App.Path & "\STONEHNG.JPG")
        End If
        .GroupSegment = IIf(Check1(0).Value = vbUnchecked, False, True)
        .HotTRacking = IIf(Check1(3).Value = vbUnchecked, False, True)
        .PrinterFit = cboPrtMode.ItemData(cboPrtMode.ListIndex)
        .SelectedColumn = -1
        .AutoRedraw = True
    End With
    RefreshData

End Sub

Private Sub Command2_Click()
    
    With XPie1
        .AutoRedraw = False
        .BackColor = Label1(0).BackColor
        .ChartTitleColor = Label1(1).BackColor
        .ChartSubTitleColor = Label1(2).BackColor
        .pieborderColor = Label1(3).BackColor
        .LegendForeColor = Label1(9).BackColor
        .LegendbackColor = Label1(10).BackColor
        .InfoForeColor = Label1(11).BackColor
        .InfoBackColor = Label1(12).BackColor
        .SelectedColor = Label1(15).BackColor
        .MarkerColor = Label1(16).BackColor
        .InfoPieforeColor = Label1(17).BackColor
        .InfoPieBackColor = Label1(18).BackColor
        If Option1(0).Value = True Then
            .MenuType = xcPopUpMenu
        Else
            .MenuType = xcButtonMenu
        End If
        .PictureTile = IIf((Check1(1).Value = vbChecked), True, False)
        
        PrepareData (0)
        If Check1(2).Value = vbUnchecked Then
            Set .Picture = Nothing
        Else
            Set .Picture = LoadPicture(App.Path & "\STONEHNG.JPG")
        End If
        .GroupSegment = IIf(Check1(0).Value = vbUnchecked, False, True)
        .HotTRacking = IIf(Check1(3).Value = vbUnchecked, False, True)
        .PrinterFit = cboPrtMode.ItemData(cboPrtMode.ListIndex)
        .SelectedColumn = -1
        .AutoRedraw = True
    End With
    RefreshData

End Sub


Private Sub Label1_Click(Index As Integer)
    
    dlgColor.Color = Label1(Index).BackColor
    dlgColor.ShowColor
    If dlgColor.Color <> Label1(Index).BackColor Then
        Label1(Index).BackColor = dlgColor.Color
    End If

End Sub

Private Sub XPie1_GroupMenuItemClick(intMenuItemIndex As Integer, stgMenuItemCaption As String)

    MsgBox "You clicked in the group explosion form the item #" & intMenuItemIndex & ":" & stgMenuItemCaption, _
            vbOKOnly, "GroupMenuItem"

End Sub

Private Sub XPie1_ItemClick(cItem As ActivePie.PieSegment)
        
    Dim lngRow As Long
    Dim lngCol As Long
    
    For lngRow = grd.FixedRows To grd.Rows - 1
        grd.Row = lngRow
        For lngCol = grd.FixedCols To grd.Cols - 1
            grd.Col = lngCol
            If lngRow = cItem.ItemID Then
                grd.CellBackColor = &H8000000D
                grd.CellForeColor = vbWhite
            Else
                grd.CellBackColor = vbWhite
                grd.CellForeColor = vbBlack
            End If
        Next
    Next
    
End Sub

Private Sub Form_Load()
    
    PrepareData (0)
        
    With cboPrtMode
        .Clear
        .AddItem "Stretched":      .ItemData(.NewIndex) = PrinterFitConstants.prtFitStretched
        .AddItem "Centered":       .ItemData(.NewIndex) = PrinterFitConstants.prtFitCentered
        .AddItem "TopLeft":        .ItemData(.NewIndex) = PrinterFitConstants.prtFitTopLeft
        .AddItem "TopRight":       .ItemData(.NewIndex) = PrinterFitConstants.prtFitTopRight
        .AddItem "BottomLeft":     .ItemData(.NewIndex) = PrinterFitConstants.prtFitBottomLeft
        .AddItem "BottomRight":    .ItemData(.NewIndex) = PrinterFitConstants.prtFitBottomRight
    End With
    
    With grd
        .FixedRows = 1
        .TextMatrix(0, 0) = "Item"
        .TextMatrix(0, 1) = "Description"
        .TextMatrix(0, 2) = "Value"
        .ColWidth(0) = 800
        .ColWidth(1) = 3500
        .ColWidth(2) = 1000
    End With

    RefreshData
    
End Sub

Private Sub Form_Resize()
'    grd.Width = Me.ScaleWidth
'    XPie1.Width = Me.ScaleWidth

'    grd.ColWidth(0) = 960
'    grd.ColWidth(1) = Me.ScaleWidth - 960 - 2025
'    grd.ColWidth(2) = 2025
End Sub

Private Sub grd_Click()
    DoEvents
End Sub



Private Sub XPie1_ItemGroupClick(cItem As ActivePie.PieGroup)
    
    Dim lngRow As Long
    Dim lngCol As Long
    
    For lngRow = grd.FixedRows To grd.Rows - 1
        grd.Row = lngRow
        For lngCol = grd.FixedCols To grd.Cols - 1
            grd.Col = lngCol
            If grd.RowData(lngRow) = cItem.Color Then
                grd.CellBackColor = &H8000000D
                grd.CellForeColor = vbWhite
            Else
                grd.CellBackColor = vbWhite
                grd.CellForeColor = vbBlack
            End If
        Next
    Next

End Sub

Private Sub XPie1_MenuItemClick(intMenuItemIndex As Integer, stgMenuItemCaption As String)
    
    MsgBox "You clicked the custom menu item #" & intMenuItemIndex & ":" & stgMenuItemCaption, _
            vbOKOnly, "CustomMenuItem"

    If intMenuItemIndex = 2 Then
        XPie1.PrintLegend
    End If

End Sub