we.frm

该系统为空车计量系统.完成对空车的自动计量.附串口处理程序.

VERSION 5.00
Object = "{65E121D4-0C60-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCHRT20.OCX"
Begin VB.Form we 
   Caption         =   "chk"
   ClientHeight    =   5208
   ClientLeft      =   1104
   ClientTop       =   348
   ClientWidth     =   6708
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form3"
   ScaleHeight     =   5208
   ScaleWidth      =   6708
   Begin VB.CommandButton cmdClose 
      Cancel          =   -1  'True
      Caption         =   "关闭"
      Height          =   300
      Left            =   60
      TabIndex        =   1
      Top             =   3960
      Width           =   1080
   End
   Begin MSChart20Lib.MSChart chtReport 
      Height          =   3840
      Left            =   60
      OleObjectBlob   =   "we.frx":0000
      TabIndex        =   0
      Top             =   60
      Width           =   6360
   End
End
Attribute VB_Name = "we"
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 ch,pz,sj from chk} AS ChildCommand COMPUTE ChildCommand, AVG(ChildCommand.[pz]) AS [pz] BY [ch]"
Private Const CONNECT_STRING = "PROVIDER=MSDataShape;dsn=dzqch;uid=sa;pwd=;Data Provider=MSDASQL"
Private Const FIELD_X = "ch"
Private Const FIELD_Y = "pz"
Private Const FIELD_Z = ""
Private Const VBERR_INVALID_PROCEDURE_CALL = 5
Private Const MARKERS_VISIBLE = 0
Private Const BRACKET_LEFT = "["
Private Const BRACKET_RIGHT = "]"
Private Const SPACE_CHAR = " "

Private Sub cmdClose_Click()
    Unload Me
End Sub

'-------------------------------------------------------------------------
'目的:   向用户显示一条出错信息
'输入:
'   [oError]
'           包含出错信息的错误对象
'-------------------------------------------------------------------------
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
    '显示或隐藏制作者
    ShowMarkers MARKERS_VISIBLE
    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

'-------------------------------------------------------------------------
'目的:   确定一个密码是否被用过
'输入:
' [cCol]    包含使用密码的集合
' [sKey]    查询的密码
'返回:   如果此密码曾在集合中被用过，则返回 true，否则返回 false.
'-------------------------------------------------------------------------
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

'----------------------------------------------------------
'目的:   根据参数来显示或隐藏系列制作者。
'输入:
' [bShow]   若为 true, 则显示所有系列制作者。
'           否则, 所有系列制作者都被隐藏。
'----------------------------------------------------------
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

'----------------------------------------------------------
'目的:   显示在图表的 recordset 中被总结过的数据
'输入:
' [recParent]
'           一个用 Shape 命令创建的 recordset，由1~2个域 (field)
'           来分组，并总结其中的1个。
' [sFldX]
'           在 X 轴上进行分组的域名 (field name)。
' [sFldY]
'           在 Y 轴上进行总结的域名 (field name)。
' [sFldZ]
'           在 Z 轴上进行分组的域名 (field name)。如果 recordset
'           只被一个域分组，则此域名应为一个零长度字符串。
'----------------------------------------------------------
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

'-------------------------------------------------------------------------
'目的:   检查一个变量的值是否为空。如果为空，则返回 vbNullString 或 0 。
'输入:
' [vField]
'           要检查的变量。
' [bNumericRequired]
'           若为 true, 则当变量为空时返回 0。否则，返回 vbNullString。
'-------------------------------------------------------------------------
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