frmchart.frm

地理信息系统工程案例精选程序,本书所有案例均需要单独配置

Private Sub GeneChart_Period()
'------------------------------------------------------------------
'生成时间段统计的统计图表
'------------------------------------------------------------------
Dim xField As String
Dim yField As String

Dim lpRecord As Long
Dim ListX As ListItem
Dim lngPeriodCount As Long

Dim LatestDate As Date
Dim EarliestDate As Date
Dim CurrentDate As Date

Dim strArray() As cusPeriod

'获取用户设置
With abTools.Bands("barTools")
    xField = .Tools("cmbX").CBList(.Tools("cmbX").CBListIndex)
    yField = .Tools("cmbY").CBList(.Tools("cmbY").CBListIndex)
    Chart1.ChartType = .Tools("cmbType").CBListIndex * 2 + 1
End With

With frmTrackSearch.lstInfo

    LatestDate = CDate(.ListItems(1).ListSubItems(xField).text)
    EarliestDate = LatestDate
    
    For lpRecord = 2 To .ListItems.Count
        Set ListX = .ListItems(lpRecord)
        CurrentDate = CDate(ListX.ListSubItems(xField).text)
        If CurrentDate > LatestDate Then LatestDate = CurrentDate
        If CurrentDate < EarliestDate Then EarliestDate = currentdata
    Next lpRecord
    
    CurrentDate = EarliestDate
    lngPeriodCount = 1
    Do Until CurrentDate >= LatestDate
        CurrentDate = GetAddDate(CurrentDate)
        lngPeriodCount = lngPeriodCount + 1
    Loop
    
    '初始化用以存储X轴字符串的数列
    
    ReDim strArray(lngPeriodCount)
    Dim i As Long
    Dim J As Long
    
    CurrentDate = EarliestDate
    
    For i = 0 To lngPeriodCount - 1
        strArray(i).DateBegin = CurrentDate
        CurrentDate = GetAddDate(CurrentDate)
        strArray(i).DateEnd = CurrentDate
    Next i
    
    
    Dim lFieldCount As Long
    
    Chart1.RowCount = lngPeriodCount
    Chart1.ColumnCount = 1
    
    Dim ListX_1 As ListItem
    Dim ListX_2 As ListItem
    frmChAnn.lstAnnotation.ColumnHeaders.Clear
    frmChAnn.lstAnnotation.ListItems.Clear
    
    Call frmChAnn.lstAnnotation.ColumnHeaders.Add(Width:=1)
    Set ListX_1 = frmChAnn.lstAnnotation.ListItems.Add
    Set ListX_2 = frmChAnn.lstAnnotation.ListItems.Add
    
    For lpRecord = 1 To lngPeriodCount
        
        Chart1.Row = lpRecord
        Chart1.RowLabel = CStr(lpRecord)
        frmChAnn.lstAnnotation.ColumnHeaders.Add
        ListX_1.ListSubItems.Add text:=CStr(lpRecord)
        ListX_2.ListSubItems.Add text:=CStr(strArray(lpRecord - 1).DateBegin) _
            & "至" & CStr(strArray(lpRecord - 1).DateEnd)
        Chart1.Data = 0
    
    Next lpRecord
    
    Chart1.Visible = False
    
    For lpRecord = 1 To .ListItems.Count
        Set ListX = .ListItems(lpRecord)
        For i = 1 To lngPeriodCount
            If CDate(ListX.ListSubItems(xField).text) >= strArray(i - 1 _
                ).DateBegin And CDate(ListX.ListSubItems(xField).text) _
                <= strArray(i - 1).DateEnd Then
                Chart1.Row = i
                If yField = "记录数量" Then
                    Chart1.Data = Val(Chart1.Data) + 1
                Else
                    Chart1.Data = Val(Chart1.Data) + Val( _
                        ListX.ListSubItems(yField).text)
                End If
                
                Exit For
            End If
        Next i
        DoEvents
    Next lpRecord
End With

Chart1.Visible = True
End Sub

Private Function GetRange() As Double
'获取区间
    GetRange = Val(frmChSet.txtRange.text)
End Function

Private Sub GeneChart_Range()
'------------------------------------------------------------------
'生成区间统计的统计图表
'------------------------------------------------------------------
Dim xField As String
Dim yField As String

Dim lpRecord As Long
Dim ListX As ListItem
Dim lngPeriodCount As Long

Dim MaxNumber As Double
Dim MinNumber As Double
Dim CurrentNumber As Double

Dim strArray() As cusRange

With abTools.Bands("barTools")
    xField = .Tools("cmbX").CBList(.Tools("cmbX").CBListIndex)
    yField = .Tools("cmbY").CBList(.Tools("cmbY").CBListIndex)
    Chart1.ChartType = .Tools("cmbType").CBListIndex * 2 + 1
End With

With frmTrackSearch.lstInfo

    MinNumber = Val(.ListItems(1).ListSubItems(xField).text)
    MaxNumber = MinNumber
    
    For lpRecord = 2 To .ListItems.Count
        Set ListX = .ListItems(lpRecord)
        CurrentNumber = Val(ListX.ListSubItems(xField).text)
        If CurrentNumber > MaxNumber Then MaxNumber = CurrentNumber
        If CurrentNumber < MinNumber Then MinNumber = CurrentNumber
    Next lpRecord
    
    If (MaxNumber - MinNumber) Mod GetRange = 0 Then
        lngPeriodCount = Fix((MaxNumber - MinNumber) / GetRange)
    Else
        lngPeriodCount = Fix((MaxNumber - MinNumber) / GetRange) + 1
    End If
    If lngPeriodCount = 0 Then lngPeriodCount = 1
    
    '初始化用以存储Y轴字符串的数组
    ReDim strArray(lngPeriodCount)
    Dim i As Long
    Dim J As Long
    
    CurrentNumber = MinNumber
    
    For i = 0 To lngPeriodCount - 1
        strArray(i).NumberBegin = CurrentNumber
        CurrentNumber = CurrentNumber + GetRange
        strArray(i).NumberEnd = CurrentNumber
    Next i
    
    Dim lFieldCount As Long
    
    Chart1.RowCount = lngPeriodCount
    Chart1.ColumnCount = 1
    
    Dim ListX_1 As ListItem
    Dim ListX_2 As ListItem
    frmChAnn.lstAnnotation.ColumnHeaders.Clear
    frmChAnn.lstAnnotation.ListItems.Clear
    
    Call frmChAnn.lstAnnotation.ColumnHeaders.Add(Width:=1)
    Set ListX_1 = frmChAnn.lstAnnotation.ListItems.Add
    Set ListX_2 = frmChAnn.lstAnnotation.ListItems.Add
    
    
    For lpRecord = 1 To lngPeriodCount
        
        Chart1.Row = lpRecord
        Chart1.RowLabel = CStr(lpRecord)
        
        frmChAnn.lstAnnotation.ColumnHeaders.Add
        ListX_1.ListSubItems.Add text:=CStr(lpRecord)
        ListX_2.ListSubItems.Add text:=CStr(strArray(lpRecord - 1).NumberBegin _
            ) & "-" & CStr(strArray(lpRecord - 1).NumberEnd)
        
        Chart1.Data = 0
    
    Next lpRecord
    
    Chart1.Visible = False
    
    For lpRecord = 1 To .ListItems.Count
        
        Set ListX = .ListItems(lpRecord)
        
        For i = 1 To lngPeriodCount
            
            If Val(ListX.ListSubItems(xField).text) >= strArray(i - 1 _
                ).NumberBegin And Val(ListX.ListSubItems(xField).text) _
                <= strArray(i - 1).NumberEnd Then
                Chart1.Row = i
                If yField = "记录数量" Then
                    Chart1.Data = Val(Chart1.Data) + 1
                Else
                    Chart1.Data = Val(Chart1.Data) + Val( _
                        ListX.ListSubItems(yField).text)
                End If
                
                Exit For
            End If
        Next i
        DoEvents
    Next lpRecord
End With

Chart1.Visible = True
End Sub

Private Sub GenerateChart()
'选择不同统计方式
If frmChSet.OptMethod(0).Value Then
    Call GeneChart_Point
ElseIf frmChSet.OptMethod(1).Value Then
    Call GeneChart_Period
Else
    Call GeneChart_Range
End If

End Sub

Private Function bCompare(ByVal strA As String, ByVal strB As String) As Boolean
'------------------------------------------------------------------
'比较strA和strB的大小
'------------------------------------------------------------------

If Len(strA) <> 3 Then
    bCompare = (strA > strB)
    Exit Function
End If

If Mid(strA, 1, 2) <> "星期" Then
    bCompare = (strA > strB)
    Exit Function
End If

strA = Replace(strA, "星期一", "1")
strA = Replace(strA, "星期二", "2")
strA = Replace(strA, "星期三", "3")
strA = Replace(strA, "星期四", "4")
strA = Replace(strA, "星期五", "5")
strA = Replace(strA, "星期六", "6")
strA = Replace(strA, "星期日", "7")

strB = Replace(strB, "星期一", "1")
strB = Replace(strB, "星期二", "2")
strB = Replace(strB, "星期三", "3")
strB = Replace(strB, "星期四", "4")
strB = Replace(strB, "星期五", "5")
strB = Replace(strB, "星期六", "6")
strB = Replace(strB, "星期日", "7")
bCompare = (Val(strA) > Val(strB))

End Function

Private Function bIsNumberic(strFieldName As String) As Boolean
'获取字段是否为数值型
If frmTrackSearch.GetFieldType(strFieldName) = 2 Then
    bIsNumberic = True
Else
    bIsNumberic = False
End If

End Function