clschartwizard.cls

一个用于交警的系统

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsChartWizard"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'创建数据源
Public Function CreateDataSource(ByVal lstDataSource As Control, ByVal txtChartTitle As Control, ByVal txtX As Control, ByVal txtLeftY As Control, ByVal txtRightY As Control, ByVal XData As Collection, ByVal LeftYData1 As Collection, Optional LeftYData2 As Collection, Optional LeftYData3 As Collection, Optional LeftYData4 As Collection, Optional RightYData As Collection) As Boolean
    On Error GoTo ErrMsg
    Dim colHeader As ColumnHeader
    Dim itemX As ListItem
    Dim i As Integer
    Dim j As Integer
    Dim colCount As Integer
    
    CreateDataSource = False
    lstDataSource.ListItems.Clear
    If XData.Count > 0 Then
        colCount = colCount + 1
        txtX = XData.Item(1)
    End If
    If LeftYData1.Count > 0 Then
        colCount = colCount + 1
        txtLeftY = txtLeftY & LeftYData1.Item(1)
    End If
    If LeftYData2.Count > 0 Then
        colCount = colCount + 1
        txtLeftY = txtLeftY & LeftYData2.Item(1)
    End If
    If LeftYData3.Count > 0 Then
        colCount = colCount + 1
        txtLeftY = txtLeftY & LeftYData3.Item(1)
    End If
    If LeftYData4.Count > 0 Then
        colCount = colCount + 1
        txtLeftY = txtLeftY & LeftYData4.Item(1)
    End If
    If RightYData.Count > 0 Then
        colCount = colCount + 1
        txtRightY = RightYData.Item(1)
    End If
    
    If XData.Count = 0 Then
        Screen.MousePointer = 0
        MsgBox "当前用户得出的结果数据中,不包含制作图表 X 轴的数据信息,图表制作不能继续.", vbExclamation + vbOKOnly, "系统信息"
        Exit Function
    Else
        i = colCount
        If lstDataSource.ColumnHeaders.Count < i Then
            For j = 1 To i
                Set colHeader = lstDataSource.ColumnHeaders.Add(, , "Col_" & j)
            Next j
        End If
        '在lstataSource中写人数据
        For j = 1 To XData.Count
            Set itemX = lstDataSource.ListItems.Add(, , XData.Item(j))
            If LeftYData1.Count > 0 Then
                itemX.SubItems(1) = LeftYData1.Item(j)
            End If
            If LeftYData2.Count > 0 Then
                itemX.SubItems(2) = LeftYData2.Item(j)
            End If
            If LeftYData3.Count > 0 Then
                itemX.SubItems(3) = LeftYData3.Item(j)
            End If
            If LeftYData4.Count > 0 Then
                itemX.SubItems(4) = LeftYData3.Item(j)
            End If
            If RightYData.Count > 0 Then
                itemX.SubItems(colCount - 1) = RightYData.Item(j)
            End If
        Next j
    End If
    If lstDataSource.ListItems.Count > 0 Then
        txtChartTitle = "各" & txtX & txtLeftY & txtRightY & "的统计结果"
        CreateDataSource = True
    End If
    Exit Function
    
ErrMsg:
    CreateDataSource = False
    Screen.MousePointer = 0
    MsgBox "错误描述: " & Err.Description & vbCrLf & _
           "错误源: " & Err.Source, vbExclamation + vbOKOnly, "系统信息"
End Function
'图表坐标选择
Private Function ChrCol(ByVal DSColsCount As Integer) As String
    ChrCol = ""
    Select Case DSColsCount
    Case 1
        ChrCol = "B"
    Case 2
        ChrCol = "C"
    Case 3
        ChrCol = "D"
    Case 4
        ChrCol = "E"
    Case 5
        ChrCol = "F"
    Case 6
        ChrCol = "G"
    End Select
End Function
'创建默认图表
Public Function CreateDefaultChart(ByVal objExcelApplication As Object, ByVal objExcelWorkSheet As Object, ByVal DSRowsCount As Integer, ByVal DSColsCount As Integer, Optional RightYData As Collection) As Boolean
    On Error GoTo ErrMsg
    Dim DSRange As String
    
    If objExcelWorkSheet Is Nothing Then Exit Function
    CreateDefaultChart = False
    DSRange = "B4:" & ChrCol(DSColsCount) & (DSRowsCount + 3)
    
    '选定区域
    objExcelWorkSheet.Range(DSRange).Select
    '准备加载图表
    objExcelApplication.Charts.Add
    '激活图表类型
    objExcelApplication.ActiveChart.ChartType = 51
    '设置图表数据源
    objExcelApplication.ActiveChart.SetSourceData Source:=objExcelWorkSheet.Range(DSRange), PlotBy:=2
    
    '设置图表位置?
    objExcelApplication.ActiveChart.Location Where:=2, Name:="Sheet1"
    
    If RightYData.Count > 0 Then
        Dim i As Long
        
        i = objExcelApplication.ActiveChart.SeriesCollection.Count
        objExcelApplication.ActiveChart.SeriesCollection(i).Select
        objExcelApplication.ActiveChart.SeriesCollection(i).ChartType = 65
        objExcelApplication.ActiveChart.SeriesCollection(i).Select
        With objExcelApplication.Selection.Border
            .ColorIndex = 1
            .Weight = 1
            .LineStyle = -4118
        End With
        With objExcelApplication.Selection
            .MarkerBackgroundColorIndex = 27
            .MarkerForegroundColorIndex = 1
            .MarkerStyle = 2
            .Smooth = False
            .MarkerSize = 3
            .Shadow = False
        End With
        objExcelApplication.ActiveChart.SeriesCollection(i).AxisGroup = 2
    End If
    CreateDefaultChart = True
    
    Exit Function

ErrMsg:
    CreateDefaultChart = False
    Screen.MousePointer = 0
    MsgBox "错误描述: " & Err.Description & vbCrLf & _
           "错误源: " & Err.Source, vbExclamation + vbOKOnly, "系统信息"
End Function
'格式化图表
Public Function FormatChart(ByVal objExcelApplication As Object, ByVal objExcelWorkSheet As Object, ByVal vbOption As String, Optional vbValue As String) As Boolean
    On Error Resume Next
    Dim i As Integer
    Dim j As Integer
    FormatChart = False
    
    If objExcelWorkSheet Is Nothing Then Exit Function
    
    objExcelWorkSheet.ChartObjects(1).Activate
    objExcelApplication.ActiveChart.ChartArea.Select
    
    Select Case LCase(Trim(vbOption))
    Case "charttitle"
        '写标题
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.HasTitle = False
        Else
            With objExcelApplication.ActiveChart
                .HasTitle = True
                .ChartTitle.Characters.Text = vbValue
            End With
            objExcelApplication.ActiveChart.ChartTitle.Select
            objExcelApplication.Selection.AutoScaleFont = True
            With objExcelApplication.Selection.Font
                .Name = "宋体"
                .Size = 9
            End With
        End If
    Case "xtitle"
        '写X轴标题
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.Axes(1).HasTitle = False
        Else
            With objExcelApplication.ActiveChart
                .Axes(1).HasTitle = True
                .Axes(1).AxisTitle.Characters.Text = vbValue
            End With
            objExcelApplication.ActiveChart.Axes(1).AxisTitle.Select
            objExcelApplication.Selection.AutoScaleFont = True
            With objExcelApplication.Selection.Font
                .Name = "宋体"
                .Size = 9
            End With
        End If
    Case "leftytitle"
        '写左Y轴标题
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.Axes(2, 1).HasTitle = False
        Else
            With objExcelApplication.ActiveChart
                .Axes(2, 1).HasTitle = True
                .Axes(2, 1).AxisTitle.Characters.Text = vbValue
            End With
            objExcelApplication.ActiveChart.Axes(2).AxisTitle.Select
            objExcelApplication.Selection.AutoScaleFont = True
            With objExcelApplication.Selection.Font
                .Name = "宋体"
                .Size = 9
            End With
        End If
    Case "rightytitle"
        '写右Y轴标题
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.Axes(2, 2).HasTitle = False
        Else
            With objExcelApplication.ActiveChart
                .Axes(2, 2).HasTitle = True
                .Axes(2, 2).AxisTitle.Characters.Text = vbValue
            End With
            objExcelApplication.ActiveChart.Axes(2, 2).AxisTitle.Select
            objExcelApplication.Selection.AutoScaleFont = True
            With objExcelApplication.Selection.Font
                .Name = "宋体"
                .Size = 9
            End With
        End If
    Case "x"
        '创建X轴
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.HasAxis(1, 1) = False
        Else
            With objExcelApplication.ActiveChart
                .HasAxis(1, 1) = True
                .Axes(1, 1).CategoryType = -4105
            End With
            objExcelApplication.ActiveChart.Axes(1).Select
            objExcelApplication.Selection.TickLabels.AutoScaleFont = True
            With objExcelApplication.Selection.TickLabels.Font
                .Name = "宋体"
                .Size = 9
            End With
        End If
    Case "lefty"
        '创建左Y轴
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.HasAxis(2, 1) = False
        Else
            objExcelApplication.ActiveChart.HasAxis(2, 1) = True
            objExcelApplication.ActiveChart.Axes(2).Select
            objExcelApplication.Selection.TickLabels.AutoScaleFont = True
            With objExcelApplication.Selection.TickLabels.Font
                .Name = "宋体"
                .Size = 9
            End With
        End If
    Case "righty"
        '创建右Y轴
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.HasAxis(2, 2) = False
        Else
            objExcelApplication.ActiveChart.ChartArea.Select
            objExcelApplication.ActiveChart.HasAxis(2, 2) = True
            objExcelApplication.ActiveChart.Axes(2, 2).Select
            objExcelApplication.Selection.TickLabels.AutoScaleFont = True
            With objExcelApplication.Selection.TickLabels.Font
                .Name = "宋体"
                .Size = 9
            End With
        End If
    Case "xmaingridline"
        '创建X轴主要网格线
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.Axes(1).HasMajorGridlines = False
        Else
            objExcelApplication.ActiveChart.Axes(1).HasMajorGridlines = True
            objExcelApplication.ActiveChart.Axes(1).MajorGridlines.Select
            With objExcelApplication.Selection.Border
                .ColorIndex = 57
                .Weight = 1
                .LineStyle = -4118
            End With
        End If
    Case "xsecondgridline"
        '创建X轴次要网格线
        If Trim(vbValue) = vbNullString Then
            ActiveChart.Axes(1).HasMinorGridlines = False
        Else
            ActiveChart.Axes(1).HasMinorGridlines = True
            ActiveChart.Axes(1).MinorGridlines.Select
            With Selection.Border
                .ColorIndex = 57
                .Weight = 1
                .LineStyle = -4118
            End With
        End If
    Case "ymaingridline"
        '创建Y轴主要网格线
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.Axes(2).HasMajorGridlines = False
        Else
            objExcelApplication.ActiveChart.Axes(2).HasMajorGridlines = True
            objExcelApplication.ActiveChart.Axes(2).MajorGridlines.Select
            With objExcelApplication.Selection.Border
                .ColorIndex = 1
                .Weight = 1
                .LineStyle = -4118
            End With
        End If
    Case "ysecondgridline"
        '创建X轴次要网格线
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.Axes(2).HasMinorGridlines = False
        Else
            objExcelApplication.ActiveChart.Axes(2).HasMinorGridlines = True
            objExcelApplication.ActiveChart.Axes(2).MinorGridlines.Select
            With objExcelApplication.Selection.Border
                .ColorIndex = 1
                .Weight = 1
                .LineStyle = -4118
            End With
        End If
     Case "showlegend"
        '显示图例
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.HasLegend = False
        Else
            objExcelApplication.ActiveChart.HasLegend = True
            objExcelApplication.ActiveChart.Legend.Select
            objExcelApplication.Selection.AutoScaleFont = True
            With objExcelApplication.Selection.Font
                .Name = "宋体"
                .Size = 9
            End With
        End If
    Case "legendposition"
        '图例位置
        objExcelApplication.ActiveChart.HasLegend = True
        objExcelApplication.ActiveChart.Legend.Select
        Select Case LCase(Trim(vbValue))
        Case "bottom"
            objExcelApplication.Selection.Position = -4107
        Case "corner"
            objExcelApplication.Selection.Position = 2
        Case "top"
            objExcelApplication.Selection.Position = -4160
        Case "right"
            objExcelApplication.Selection.Position = -4152
        Case "left"
            objExcelApplication.Selection.Position = -4131
        End Select
    Case "showvalue"
        '显示值
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.ApplyDataLabels Type:=-4142, LegendKey:=False
        Else
            objExcelApplication.ActiveChart.ChartArea.Select
            objExcelApplication.ActiveChart.ApplyDataLabels Type:=2, LegendKey:=False
            i = objExcelApplication.ActiveChart.SeriesCollection.Count
            For j = 1 To i
                objExcelApplication.ActiveChart.SeriesCollection(j).DataLabels.Select
                objExcelApplication.Selection.AutoScaleFont = True
                With objExcelApplication.Selection.Font
                    .Name = "宋体"
                    .Size = 9
                End With
            Next j
        End If
    Case "showpercent"
        '显示百分比
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.ApplyDataLabels Type:=-4142, LegendKey:=False, HasLeaderLines:=True
        Else
            objExcelApplication.ActiveChart.ChartArea.Select
            objExcelApplication.ActiveChart.ApplyDataLabels Type:=3, LegendKey:=False, HasLeaderLines:=True
            i = objExcelApplication.ActiveChart.SeriesCollection.Count
            For j = 1 To i
                objExcelApplication.ActiveChart.SeriesCollection(j).DataLabels.Select
                objExcelApplication.Selection.AutoScaleFont = True
                With objExcelApplication.Selection.Font
                    .Name = "宋体"
                    .Size = 9
                End With
            Next j
        End If
    Case "showdatasheet"
        '显示数据表
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.HasDataTable = False
        Else
            objExcelApplication.ActiveChart.HasDataTable = True
            objExcelApplication.ActiveChart.DataTable.ShowLegendKey = False
            objExcelApplication.Selection.AutoScaleFont = True
            With objExcelApplication.Selection.Font
                .Name = "宋体"
                .Size = 9
            End With
        End If
    Case "backcolor"
        '显示背景色
        If Trim(vbValue) = vbNullString Then
            objExcelApplication.ActiveChart.PlotArea.Select
            With objExcelApplication.Selection.Interior
                .ColorIndex = 15
                .PatternColorIndex = 1
                .Pattern = 1
            End With
        Else
            objExcelApplication.ActiveChart.PlotArea.Select
            With objExcelApplication.Selection.Interior
                .ColorIndex = 2
                .PatternColorIndex = 1
                .Pattern = 1
            End With
        End If
    End Select
    FormatChart = True
    
End Function
'显示图表类型
Public Function ShowSubChartType(ByVal objExcelApplication As Object, ByVal objExcelWorkSheet As Object, ByVal cboSerial As Object, ByVal Index As Long, Optional RightYData As Collection) As Boolean
    On Error GoTo ErrMsg
    Dim i As Long
    Dim j As Long
    
    ShowSubChartType = False
    If objExcelWorkSheet Is Nothing Then Exit Function
    objExcelWorkSheet.ChartObjects(1).Activate
    i = objExcelApplication.ActiveChart.SeriesCollection.Count
    j = cboSerial.ListIndex + 1
    If j > i Then j = i
    On Error GoTo SerialError
    objExcelApplication.ActiveChart.SeriesCollection(j).Select
    With objExcelApplication.ActiveChart.SeriesCollection(j)
    'ChartType类型定义