frmtracksearch.frm

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

VERSION 5.00
Object = "{4932CEF1-2CAA-11D2-A165-0060081C43D9}#2.0#0"; "Actbar2.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmTrackSearch 
   Caption         =   "搜索结果"
   ClientHeight    =   5430
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8295
   Icon            =   "frmTrackSearch.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   5430
   ScaleWidth      =   8295
   StartUpPosition =   1  '所有者中心
   Begin MSComDlg.CommonDialog CD 
      Left            =   1320
      Top             =   3720
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSComctlLib.ListView lstFieldAttr 
      Height          =   1815
      Left            =   0
      TabIndex        =   3
      Top             =   5520
      Visible         =   0   'False
      Width           =   8295
      _ExtentX        =   14631
      _ExtentY        =   3201
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin ActiveBar2LibraryCtl.ActiveBar2 abTool 
      Align           =   1  'Align Top
      Height          =   495
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   8295
      _LayoutVersion  =   1
      _ExtentX        =   14631
      _ExtentY        =   873
      _DataPath       =   ""
      Bands           =   "frmTrackSearch.frx":08A6
      Begin VB.Label Label1 
         Caption         =   "Label1"
         Height          =   15
         Left            =   0
         TabIndex        =   2
         Top             =   480
         Width           =   735
      End
   End
   Begin MSComctlLib.ListView lstInfo 
      Height          =   4935
      Left            =   0
      TabIndex        =   0
      Top             =   480
      Width           =   8295
      _ExtentX        =   14631
      _ExtentY        =   8705
      View            =   3
      LabelEdit       =   1
      MultiSelect     =   -1  'True
      LabelWrap       =   0   'False
      HideSelection   =   0   'False
      FullRowSelect   =   -1  'True
      GridLines       =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin VB.Menu mnuSort 
      Caption         =   ""
      Visible         =   0   'False
      Begin VB.Menu mnuAsc 
         Caption         =   "按此列内容升序排列"
      End
      Begin VB.Menu mnuDes 
         Caption         =   "按此列内容降序排列"
      End
   End
End
Attribute VB_Name = "frmTrackSearch"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'------------------------------------------------------------------------------
'2002-11-11修改为无模式窗体,加入fieldattr表存储RecQuery基本信息
'2002-10-27
'2002-10-12修改界面,准备增加zoom,pan,statistic,save,计算功能.
'------------------------------------------------------------------------------
Dim Index As Long

Private Sub refreshFieldAttr()
'------------------------------------------------------
'根据QueryRec内容刷新lstFieldAttr,存储查询结果基本信息
'------------------------------------------------------
Dim lpField As Long
Dim ListX As ListItem
Dim FieldX As MapObjects2.Field
lstFieldAttr.ListItems.Clear

Dim strField As String
RecQuery.MoveFirst
If RecQuery.EOF Then Exit Sub

For lpField = 1 To frmSQLSearch.lstField.ListItems.Count
    Set FieldX = RecQuery.Fields(frmSQLSearch.lstField.ListItems(lpField).text)
    Set ListX = lstFieldAttr.ListItems.Add(Key:=FieldX.Name)
    ListX.ListSubItems.Add Key:="Type", text:=CStr(FieldX.Type)
    DoEvents
Next lpField

End Sub

Private Sub refreshData()
'------------------------------------------------------
'根据QueryRec内容刷新lstInfo
'------------------------------------------------------

lstInfo.ListItems.Clear
lstInfo.ColumnHeaders.Clear

If RecQuery Is Nothing Then Exit Sub

Dim lpointer As Long

Dim ListFieldX As ListItem
lstInfo.ColumnHeaders.Add text:="序号", Key:="ID", Width:=1
'添加表头
For lpointer = 1 To frmSQLSearch.lstField.ListItems.Count
    Set ListFieldX = frmSQLSearch.lstField.ListItems(lpointer)
    If ListFieldX.Checked Then
        lstInfo.ColumnHeaders.Add text:=ListFieldX.text, _
            Key:=ListFieldX.text, Width:=lstInfo.Width / 6
    End If
Next

Dim ListX As ListItem
RecQuery.MoveFirst
Dim RecCount As Long
Dim lpRec As Long
RecCount = RecQuery.CalculateStatistics("SID").Count
lpRec = 0
frmMain.Progress_Enable

'向ListView中添加数据
Do Until RecQuery.EOF
    
    Set ListX = lstInfo.ListItems.Add( _
        text:=RecQuery.Fields("SID").ValueAsString)
    For lpointer = 1 To frmSQLSearch.lstField.ListItems.Count
        Set ListFieldX = frmSQLSearch.lstField.ListItems(lpointer)
        If ListFieldX.Checked Then
            ListX.ListSubItems.Add text:=RecQuery.Fields( _
                ListFieldX.text).ValueAsString, Key:=ListFieldX.text
        End If
    Next
    RecQuery.MoveNext
    Call frmMain.Progress_SetValue(CDbl(lpRec), CDbl(RecCount))
    lpRec = lpRec + 1
    
    
    DoEvents
    
    If lpRec = Search_MaxResult Then
        If MsgBox("记录数量已经超过" & CStr(Search_MaxResult) & _
            "条,是否全部显示?", vbQuestion + vbOKCancel, _
            "信息") = vbCancel Then
            Exit Do
        End If
    End If
    
Loop

abTool.Bands("bStandard").Tools("lblNumber").Caption = _
    "共" & CLng(lstInfo.ListItems.Count) & "条记录"
frmMain.Progress_Disable
End Sub
Private Sub abTool_ToolClick(ByVal Tool As _
    ActiveBar2LibraryCtl.Tool)
'---------------------------------------------------------------
'工具栏按钮单击事件
'---------------------------------------------------------------
Select Case Tool.Name
    
    Case "Filter"
        frmSQLSearch.Show
    Case "Statistic"
        '统计
        frmStatistic.Show
    Case "Highlight"
        '高亮显示所选记录
        Call HighlightRecord
    Case "Pan"
        '平移到所选记录
        Call PanToRecord
    Case "Zoom"
        '放大到所选记录
        Call ZoomToRecord
    Case "Save"
        '数据导出
        Call SaveData
    Case "Chart"
        '统计图表
        frmChart.InitForm
        frmChart.Show
    Case "Print"
        '打印数据
        frmPreview.PrintContent
        frmPreview.Show vbModal
    Case "Exit"
        '退出
        Unload Me
End Select

End Sub
Public Sub InitForm(lIndex As Long)
'-----------------------------------------------------
'窗口初始化
'-----------------------------------------------------
    Index = lIndex
    
    frmMain.SetTipText "正在刷新查询结果,请稍后..."
    frmMain.MousePointer = 11
    Screen.MousePointer = 11
    Call refreshFieldAttr
    Call refreshData
    If Trim(CustomLayers(lIndex).MultiRelate.Database) = "" Then
        abTool.Bands("bStandard").Tools("MultiRelation").Enabled = False
    Else
        abTool.Bands("bStandard").Tools("MultiRelation").Enabled = True
    End If
    If Trim(CustomLayers(Index).PictureField) = "" Then
        abTool.Bands("bStandard").Tools("Picture").Enabled = False
    Else
        Dim lpField As Long
        For lpField = 1 To lstInfo.ColumnHeaders.Count
            If lstInfo.ColumnHeaders(lpField).Key = _
                CustomLayers(Index).PictureField Then Exit For
        Next lpField
        
        If lpField > lstInfo.ColumnHeaders.Count Then
            abTool.Bands("bStandard").Tools("Picture").Enabled = False
        Else
            abTool.Bands("bStandard").Tools("Picture").Enabled = True
        End If
    End If
    Screen.MousePointer = 0
    frmMain.MousePointer = 0
    frmMain.SetTipText "完毕"
End Sub

Private Sub Form_Resize()
'-----------------------------------------------------
'窗体改变尺寸,同时控件也改变尺寸
'-----------------------------------------------------
If frmTrackSearch.WindowState <> 1 Then
    lstInfo.Width = frmTrackSearch.ScaleWidth
    lstInfo.Height = frmTrackSearch.ScaleHeight - abTool.Height
End If

End Sub

Private Sub Form_Unload(Cancel As Integer)
    '取消高亮显示
    Call HighLightShape(Index, Nothing)
End Sub

Private Sub lstInfo_Click()
'-----------------------------------------------------
'列表中记录被单击
'-----------------------------------------------------
Dim RecX As MapObjects2.Recordset
If Not lstInfo.SelectedItem Is Nothing Then
    '查询记录并闪烁
    Set RecX = frmMain.Map1.Layers(Index).SearchExpression("SID=" & Trim(lstInfo.SelectedItem.text) & "")
    RecX.MoveFirst
    If Not RecX.EOF Then
        '闪烁记录一次
        frmMain.Map1.FlashShape RecX.Fields("Shape").Value, 1
    End If
    Set RecX = Nothing
End If

End Sub
Private Function GetAllShape() As Object
'-----------------------------------------------------
'将所有选中的记录的图形合并起来
'-----------------------------------------------------
If lstInfo.SelectedItem Is Nothing Then
    Set GetAllShape = Nothing
    Exit Function
End If

Dim lpointer As Long
Dim lpPart As Long
Dim PointsX As New MapObjects2.Points
Dim RecX As MapObjects2.Recordset
frmMain.Progress_Enable
'根据图层类型不同而分别处理
Select Case frmMain.Map1.Layers(Index).shapeType
    
    Case moShapeTypePoint
        '点状图层
        Dim PointX As New MapObjects2.POINT
        
        For lpointer = 1 To lstInfo.ListItems.Count
            If lstInfo.ListItems(lpointer).Selected Then
                Set RecX = frmMain.Map1.Layers(Index).SearchExpression( _
                    "SID=" & Trim(lstInfo.ListItems(lpointer).text) & "")
                RecX.MoveFirst
                If Not RecX.EOF Then
                    Set PointX = RecX.Fields("Shape").Value
                    PointsX.Add PointX
                End If
                
            End If
            frmMain.Progress_SetValue CDbl(lpointer), _
                CDbl(lstInfo.ListItems.Count)
        Next lpointer
        Set GetAllShape = PointsX
    
    Case moShapeTypeLine
        '线状图
        Dim GetLineX As MapObjects2.Line
        Dim LineX As New MapObjects2.Line
        For lpointer = 1 To lstInfo.ListItems.Count