frmchart.frm

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

VERSION 5.00
Object = "{4932CEF1-2CAA-11D2-A165-0060081C43D9}#2.0#0"; "Actbar2.OCX"
Object = "{65E121D4-0C60-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCHRT20.OCX"
Begin VB.Form frmChart 
   Caption         =   "统计图表"
   ClientHeight    =   7290
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   10155
   Icon            =   "frmChart.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   7290
   ScaleWidth      =   10155
   StartUpPosition =   1  '所有者中心
   Begin ActiveBar2LibraryCtl.ActiveBar2 abTools 
      Align           =   1  'Align Top
      Height          =   495
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   10155
      _LayoutVersion  =   1
      _ExtentX        =   17912
      _ExtentY        =   873
      _DataPath       =   ""
      Bands           =   "frmChart.frx":08A6
   End
   Begin MSChart20Lib.MSChart Chart1 
      Height          =   6720
      Left            =   120
      OleObjectBlob   =   "frmChart.frx":1C02
      TabIndex        =   0
      Top             =   495
      Width           =   9975
   End
End
Attribute VB_Name = "frmChart"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Type cusRange
    NumberBegin As Double
    NumberEnd As Double
End Type
Private Type cusPeriod
    DateBegin As Date
    DateEnd As Date
End Type

Private Sub abTools_TextChange(ByVal Tool As ActiveBar2LibraryCtl.Tool)
'------------------------------------------------------------------
'工具栏文字改变
'------------------------------------------------------------------
If Tool.Name = "cmbX" Then
    With abTools.Bands("barTools").Tools("cmbX")
    Select Case frmTrackSearch.GetFieldType(.CBList(.CBListIndex))
        Case 2
            '数值类型字段
            'Double or Long
            frmChSet.OptMethod(2).Value = True
            frmChSet.OptMethod(0).Enabled = False
            frmChSet.OptMethod(1).Enabled = False
            frmChSet.txtDay.Enabled = False
            frmChSet.txtMonth.Enabled = False
            frmChSet.OptMethod(2).Enabled = True
            frmChSet.txtRange.Enabled = True
        Case 1
            '日期类型字段
            'Date
            frmChSet.OptMethod(1).Value = True
            frmChSet.OptMethod(0).Enabled = True
            frmChSet.OptMethod(1).Enabled = True
            frmChSet.txtDay.Enabled = True
            frmChSet.txtMonth.Enabled = True
            frmChSet.OptMethod(2).Enabled = False
            frmChSet.txtRange.Enabled = False
        
        Case 0
            '字符串类型字段
            'String
            frmChSet.OptMethod(0).Value = True
            frmChSet.OptMethod(0).Enabled = True
            frmChSet.OptMethod(1).Enabled = False
            frmChSet.txtDay.Enabled = False
            frmChSet.txtMonth.Enabled = False
            frmChSet.OptMethod(2).Enabled = False
            frmChSet.txtRange.Enabled = False
        
    End Select
    End With
End If

End Sub

Private Sub abTools_ToolClick(ByVal Tool As ActiveBar2LibraryCtl.Tool)
'------------------------------------------------------------------
'工具栏按钮单击事件
'------------------------------------------------------------------
Select Case Tool.Name
    Case "cmdExit"
        '退出
        Unload Me
    Case "cmdGenerate"
        '生成统计图表
        Call GenerateChart
    Case "cmdSetup"
        '设置
        frmChSet.Show vbModal
End Select

End Sub

Private Sub Chart1_DblClick()
    '显示标注窗口
    frmChAnn.Show
End Sub

Private Sub Form_Resize()
'控件大小随着窗口大小变动
If frmChart.WindowState <> 1 Then
    Chart1.Height = frmChart.ScaleHeight - abTools.Height - 100
    Chart1.Width = frmChart.ScaleWidth - 250
End If

End Sub

Public Sub InitForm()
'------------------------------------------------------------------
'窗体初始化代码
'------------------------------------------------------------------
Dim lpField As Long

'初始化工具栏
With abTools.Bands("barTools")
    
    .Tools("cmbY").CBClear
    .Tools("cmbX").CBClear
    .Tools("cmbType").CBClear
    .Tools("cmbY").CBAddItem "记录数量"
     
    .Tools("cmbType").CBAddItem "1-二维条形图"
    .Tools("cmbType").CBAddItem "3-二维折线图"
    .Tools("cmbType").CBAddItem "5-二维域型图"
    .Tools("cmbType").CBAddItem "7-二维阶梯图"
    .Tools("cmbType").CBAddItem "9-二维组合图"
    .Tools("cmbType").CBListIndex = 0

End With

'初始化X轴和Y轴字段
With frmTrackSearch.lstInfo.ColumnHeaders

    For lpField = 2 To .Count
        abTools.Bands("barTools").Tools("cmbX").CBAddItem .Item(lpField).Key
        If bIsNumberic(.Item(lpField).Key) Then
            abTools.Bands("barTools").Tools("cmbY").CBAddItem .Item(lpField).Key
        End If
    Next lpField

End With

abTools.Bands("barTools").Tools("cmbX").CBListIndex = 0
abTools.Bands("barTools").Tools("cmbY").CBListIndex = 0

'清除Chart中已有数据
Chart1.ColumnCount = 1
Chart1.RowCount = 1
Chart1.Data = 1

End Sub

Private Sub GeneChart_Point()
'------------------------------------------------------------------
'生成单点统计的统计图表
'------------------------------------------------------------------
Dim stringx As New MapObjects2.Strings
Dim xField As String
Dim yField As String

Dim lpRecord As Long
Dim ListX As ListItem
Dim strTemp As String
Dim strArray() As String

'获取用户设置
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

    For lpRecord = 1 To .ListItems.Count
        Set ListX = .ListItems(lpRecord)
        stringx.Add ListX.ListSubItems(xField).text
    Next lpRecord
    
    If stringx.Count2 <= 0 Then Exit Sub
    
    '初始化用于存储x轴数据的数组
    
    ReDim strArray(stringx.Count2)
    Dim i As Long
    Dim J As Long
    
    For i = 0 To stringx.Count2 - 1
        strArray(i) = stringx(i)
    Next i
    
    '对数组排序
    
    For i = 0 To stringx.Count - 2
        For J = i + 1 To stringx.Count - 1
            
            If bCompare(strArray(i), strArray(J)) Then
                strTemp = strArray(i)
                strArray(i) = strArray(J)
                strArray(J) = strTemp
            End If
            
        Next J
    Next i
    
    Dim lFieldCount As Long
    
    Chart1.RowCount = stringx.Count2
    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 stringx.Count2
        
        Chart1.Row = lpRecord
        Chart1.RowLabel = CStr(lpRecord)
        '建立横轴标注
        frmChAnn.lstAnnotation.ColumnHeaders.Add
        ListX_1.ListSubItems.Add text:=CStr(lpRecord)
        ListX_2.ListSubItems.Add text:=strArray(lpRecord - 1)
        
        Chart1.Data = 0
    
    Next lpRecord
    
    '建立图表
    Chart1.Visible = False
    
    For lpRecord = 1 To .ListItems.Count
        Set ListX = .ListItems(lpRecord)
        For i = 1 To Chart1.RowCount
            Chart1.Row = i
            If ListX.ListSubItems(xField).text = strArray(i - 1) Then
                If yField = "记录数量" Then
                    Chart1.Data = Val(Chart1.Data) + 1
                Else
                    Chart1.Data = Val(Chart1.Data) + Val(ListX.ListSubItems(Chart1.ColumnLabel).text)
                End If
                Exit For
            End If
        Next i
        DoEvents
    Next lpRecord
End With

Chart1.Visible = True
End Sub

Private Function GetAddDate(ByVal CurrentDate As Date) As Date
'------------------------------------------------------------------
'获取指定间隔后的时间
'------------------------------------------------------------------
CurrentDate = DateAdd("m", Abs(Int(Val(frmChSet.txtMonth))), CurrentDate)
CurrentDate = DateAdd("d", Abs(Int(Val(frmChSet.txtDay))), currrentdate)
GetAddDate = CurrentDate
End Function