VERSION 5.00
Object = "{65E121D4-0C60-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCHRT20.OCX"
Begin VB.Form frmClass 
   Caption         =   "Class"
   ClientHeight    =   3390
   ClientLeft      =   1110
   ClientTop       =   345
   ClientWidth     =   5415
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form2"
   ScaleHeight     =   3390
   ScaleWidth      =   5415
   Begin VB.CommandButton cmdClose 
      Cancel          =   -1  'True
      Caption         =   "关闭"
      Height          =   300
      Left            =   0
      TabIndex        =   1
      Top             =   3060
      Width           =   1080
   End
   Begin MSChart20Lib.MSChart chtReport 
      Height          =   2820
      Left            =   60
      OleObjectBlob   =   "sy11-17.frx":0000
      TabIndex        =   0
      Top             =   60
      Width           =   5280
   End
End
Attribute VB_Name = "frmClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Const MARGIN_SIZE = 60 'In Twips
Private Const SHAPE_COMMAND = "SHAPE {select 课程名,成绩,学号,学期 from Class} AS ChildCommand COMPUTE ChildCommand, AVG(ChildCommand.[成绩]) AS [成绩] BY [课程名]"
Private Const CONNECT_STRING = "PROVIDER=MSDataShape;Data Source=Mydb.mdb;Data Provider=Microsoft.Jet.OLEDB.3.51"
Private Const FIELD_X = "课程名"
Private Const FIELD_Y = "成绩"
Private Const FIELD_Z = ""
Private Const VBERR_INVALID_PROCEDURE_CALL = 5
Private Const BRACKET_LEFT = "["
Private Const BRACKET_RIGHT = "]"
Private Const SPACE_CHAR = " "

Private Sub cmdClose_Click()
    Unload Me
End Sub

Private Sub DisplayError(oError As ErrObject)
    MsgBox oError.Description, vbExclamation, App.Title
End Sub

Private Sub Form_Load()
    Dim conShape As ADODB.Connection
    Dim recShape As ADODB.Recordset
    On Error GoTo Form_Load_Error
    '创建并打开到 Data Shape provider 的连接
    Set conShape = New ADODB.Connection
    conShape.Open CONNECT_STRING
    '创建并打开一个 recordset
    Set recShape = New ADODB.Recordset
    recShape.Open SHAPE_COMMAND, conShape
    '用 recordset 中的数据来填充图表
    ShowRecordsInChart recShape, FIELD_X, FIELD_Y, FIELD_Z
    Exit Sub
Form_Load_Error:
    DisplayError Err
    Exit Sub
End Sub

Private Sub Form_Resize()
    Dim sngButtonTop As Single
    Dim sngScaleWidth As Single
    Dim sngScaleHeight As Single
    On Error GoTo Form_Resize_Error
    With Me
        sngScaleWidth = .ScaleWidth
        sngScaleHeight = .ScaleHeight
        '移动“关闭”按钮到右下角
        With .cmdClose
            sngButtonTop = sngScaleHeight - (.Height + MARGIN_SIZE)
            .Move sngScaleWidth - (.Width + MARGIN_SIZE), sngButtonTop
        End With
        .chtReport.Move MARGIN_SIZE, _
                        MARGIN_SIZE, _
                        sngScaleWidth - (2 * MARGIN_SIZE), _
                        sngButtonTop - (2 * MARGIN_SIZE)
    End With
    Exit Sub
Form_Resize_Error:
    '如果用户使窗体过小，以至于出现负值高度或宽度，则会出错。
    Resume Next
End Sub

Private Function IsKeyInCollection(cCol As Collection, sKey As String) As Boolean
    Dim v As Variant
    On Error Resume Next
    v = cCol.Item(sKey)
    '检查错误5是很重要的，超过检查其它错误。因为即使密码是有效的，仍有可能出错。
    '如果密码已存在，但它是同一个对象的元素相关的，则会出错。因为“Set”并不把
    '它设为 'v'。
    IsKeyInCollection = (Err.Number <> VBERR_INVALID_PROCEDURE_CALL)
    Err.Clear
End Function

Private Sub ShowMarkers(bShow As Boolean)
    Dim i As Long
    On Error GoTo ShowMarkers_Click_Error
    With chtReport.Plot
        For i = 1 To .SeriesCollection.Count
            .SeriesCollection(i).SeriesMarker.Show = bShow
        Next
    End With
    Exit Sub
ShowMarkers_Click_Error:
    DisplayError Err
    Exit Sub
End Sub
Private Sub ShowRecordsInChart(recParent As Recordset, _
                               sFldX As String, _
                               sFldY As String, _
                               sFldZ As String)
                                   
    Dim bUseZ As Boolean
    Dim cRows As Collection
    Dim cCols As Collection
    Dim lCol As Long
    Dim lRow As Long
    Dim lMaxCol As Long
    Dim lMaxRow As Long
    Dim sValue As String
    
    On Error GoTo ShowRecordsInChart_Error
    If Len(sFldZ) = 0 Then bUseZ = False Else bUseZ = True
    
    Set cRows = New Collection
    Set cCols = New Collection
    
    With Me.chtReport
        '关闭图表绘制
        .Repaint = False
        With .DataGrid
            '清除图表
            .DeleteRows 1, .RowCount
            .DeleteColumns 1, .ColumnCount
            .DeleteColumnLabels 1, .ColumnLabelCount
            .DeleteRowLabels 1, .RowLabelCount
            '确认存在一级标记 (label)
            .InsertColumnLabels 1, 1
            .InsertRowLabels 1, 1
            '如果 Z 轴未被使用，应确认存在一个列(column)
            If Not bUseZ Then .InsertColumns 1, 1
            recParent.MoveFirst
            Do Until recParent.EOF
                '确认有一个行(row)为此 X 域添加进来
                sValue = FixNull(recParent.Fields(sFldX).Value, False)
                If Not IsKeyInCollection(cRows, sValue) Then
                    lMaxRow = lMaxRow + 1
                    lRow = lMaxRow
                    '存储同行名相关的行索引
                    cRows.Add lRow, sValue
                    .InsertRows lRow, 1
                    .RowLabel(lRow, 1) = sValue
                Else
                    lRow = cRows.Item(sValue)
                End If
                
                '确认有一个列(column)为此 Z 域添加进来
                If bUseZ Then
                    sValue = FixNull(recParent.Fields(sFldZ).Value, False)
                    If Not IsKeyInCollection(cCols, sValue) Then
                        lMaxCol = lMaxCol + 1
                        lCol = lMaxCol
                        '存储同列名相关的列索引
                        cCols.Add lCol, sValue
                        .InsertColumns lCol, 1
                        .ColumnLabel(lCol, 1) = sValue
                    Else
                        lCol = cCols.Item(sValue)
                    End If
                    '为此记录的行列设置 datapoint 值
                    .SetData lRow, lCol, FixNull(recParent.Fields.Item(sFldY).Value, True), 0
                Else
                    '为此记录的行设置 datapoint 值，此种情况只有一列
                    .SetData lRow, 1, FixNull(recParent.Fields.Item(sFldY).Value, True), 0
                End If
                '移动 recordset 到下一个记录
                recParent.MoveNext
            Loop
        End With
        '重新打开图表绘制
        .Repaint = True
    End With
    Exit Sub
ShowRecordsInChart_Error:
    '确认图表绘制已被打开
    Me.chtReport.Repaint = True
    DisplayError Err
    Exit Sub
End Sub
Private Function FixNull(vField As Variant, _
                        bNumericRequired As Boolean) As Variant
    If IsNull(vField) Then
        If bNumericRequired Then
            FixNull = 0
        Else
            FixNull = vbNullString
        End If
    Else
        FixNull = vField
    End If
End Function

 

