frmtracksearch.frm

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

            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 GetLineX = RecX.Fields("Shape").Value
                    For lpPart = 0 To GetLineX.Parts.Count - 1
                        Set PointsX = New MapObjects2.Points
                        Set PointsX = GetLineX.Parts.Item(lpPart)
                        LineX.Parts.Add PointsX
                    Next
                End If
            End If
            frmMain.Progress_SetValue CDbl(lpointer), _
                CDbl(lstInfo.ListItems.Count)
        Next lpointer
        Set GetAllShape = LineX
    
    Case moShapeTypePolygon
        '面状图
        Dim GetPolygonX As MapObjects2.Polygon
        Dim PolygonX As New MapObjects2.Polygon
        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 GetPolygonX = RecX.Fields("Shape").Value
                    For lpPart = 0 To GetPolygonX.Parts.Count - 1
                        Set PointsX = New MapObjects2.Points
                        Set PointsX = GetPolygonX.Parts.Item(lpPart)
                        PolygonX.Parts.Add PointsX
                    Next
                End If
                
            End If
            DoEvents
            frmMain.Progress_SetValue CDbl(lpointer), _
                CDbl(lstInfo.ListItems.Count)
        Next lpointer
        Set GetAllShape = PolygonX
End Select
frmMain.Progress_Disable
Set RecX = Nothing

End Function
Private Sub PanToRecord()
'------------------------------------------------------------
'地图自动定位到选择的记录所对应的几何对象上
'------------------------------------------------------------

Dim ShapeX As Object
frmMain.SetTipText "正在定位到选择几何区域上，请稍候..."
Set ShapeX = GetAllShape
If ShapeX Is Nothing Then
    MsgBox "请先选择需要定位的数据"
    frmMain.SetTipText "完毕"
    Exit Sub
End If

ShapeX.Extent.ScaleRectangle 2
Set frmMain.Map1.Extent = ShapeX.Extent
frmMain.SetTipText "完毕"
End Sub

Private Sub HighlightRecord()
'------------------------------------------------------------
'高亮显示被选择记录所对应的几何对象
'------------------------------------------------------------
Dim ShapeX As Object
frmMain.SetTipText "正在处理高亮显示几何区域，请稍候..."
Set ShapeX = GetAllShape
If ShapeX Is Nothing Then
    MsgBox "请先选择需要定位的数据"
    frmMain.SetTipText "完毕"
    Exit Sub
End If
Call HighLightShape(Index, ShapeX)
frmMain.SetTipText "完毕"

End Sub

Public Sub HighLightShape(LayerIndex As Long, _
                        Optional ShapeX As Object = Nothing)
'----------------------------------------------------------------
'高亮显示某几何对象
'----------------------------------------------------------------

Dim LayerX As MapLayer
Dim SymbolX As New MapObjects2.Symbol
Set LayerX = frmMain.Map1.Layers(LayerIndex)
Set g_HighlightShape = ShapeX

If Not ShapeX Is Nothing Then
    '设置符号属性
    SymbolX.Color = LayerX.Symbol.Color
    SymbolX.Custom = LayerX.Symbol.Custom
    SymbolX.Font = LayerX.Symbol.Font
    SymbolX.Outline = LayerX.Symbol.Outline
    SymbolX.OutlineColor = LayerX.Symbol.OutlineColor
    SymbolX.Size = LayerX.Symbol.Size
    SymbolX.Style = LayerX.Symbol.Style
    
    Select Case LayerX.shapeType
        Case moShapeTypePolygon
            '若为多边形，则改变其填色方式以高亮显示
            SymbolX.Style = moGrayFill
            SymbolX.Color = moWhite
        Case Else
            '以黄色显示
            SymbolX.Color = moYellow
            SymbolX.Size = g_HighlightSymbol.Size + 1
    End Select
    Set g_HighlightSymbol = SymbolX
End If

frmMain.Map1.TrackingLayer.Refresh True

End Sub
Private Sub ZoomToRecord()
'------------------------------------------------------------
'地图自动缩放到选择的记录所对应的几何对象上
'------------------------------------------------------------
Dim ShapeX As Object
frmMain.SetTipText "正在定位到选择的几何区域上，请稍候..."
Set ShapeX = GetAllShape
If ShapeX Is Nothing Then
    MsgBox "请先选择需要定位的数据"
    frmMain.SetTipText "完毕"
    Exit Sub
End If
frmMain.Map1.Extent = ShapeX.Extent
frmMain.SetTipText "完毕"

End Sub
Private Sub SaveData()
'------------------------------------------------------------
'数据导出
'------------------------------------------------------------
CD.Filter = "文本文件 (*.txt)|*.txt|HTML文件(*.htm)|*.htm"
CD.ShowSave

Dim strFileName As String

strFileName = CD.FileName
If Dir(strFileName) <> "" Then
    If MsgBox("文件已经存在，是否要覆盖它？", vbQuestion + vbYesNo, "保存") = vbNo Then Exit Sub
End If

If UCase(Right(strFileName, 3)) = "TXT" Then
    Call SaveAsText(lstInfo.ListItems, strFileName)
Else
    Call SaveAsHtml(lstInfo.ListItems, strFileName)
End If

MsgBox "保存文件成功!" & vbCrLf & "文件:" & strFileName, vbInformation, "保存"
End Sub

Private Sub lstInfo_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
'Listview表头鼠标单击事件
If ColumnHeader.Key <> "SID" Then
    '记录鼠标单击的表头
    mnuSort.Caption = ColumnHeader.Key
    PopupMenu mnuSort
End If

End Sub

Private Sub mnuAsc_Click()
    '升序排列数据
    SortList True
End Sub

Private Sub mnuDes_Click()
    '降序排列数据
    SortList False
End Sub
Private Sub SortList(bOrder As Boolean)
'------------------------------------------------------------
'根据字段类型对其确定不同的排序规则，并对其排序
'------------------------------------------------------------

If lstInfo.ListItems.Count <= 0 Then Exit Sub
modListItemSort.sOrder = bOrder
lstInfo.SortKey = lstInfo.ColumnHeaders(mnuSort.Caption).Index - 1
modListItemSort.lSubItem = lstInfo.SortKey

Select Case GetFieldType(mnuSort.Caption)
   
    Case 0
           '字符串排序
            lstInfo.SortOrder = Abs(sOrder)
            lstInfo.Sorted = True
    Case 1
           '日期排序
            lstInfo.Sorted = False
            SendMessageLong lstInfo.hwnd, _
                            LVM_SORTITEMS, _
                            lstInfo.hwnd, _
                            AddressOf CompareDates
    Case 2
           '数值排序
            lstInfo.Sorted = False
            SendMessageLong lstInfo.hwnd, _
                            LVM_SORTITEMS, _
                            lstInfo.hwnd, _
                            AddressOf CompareValues
End Select
End Sub

Public Function GetFieldType(FieldName As String) As Long
'------------------------------------------------------------
'获取某字段的数据类型
'------------------------------------------------------------

Dim ListX As ListItem
Set ListX = lstFieldAttr.ListItems(FieldName)
Dim lType As Long
lType = CLng(ListX.ListSubItems("Type").text)

If lType = moLong Or lType = moDouble Then
    GetFieldType = 2
ElseIf lType = moDate Then
    GetFieldType = 1
Else
    GetFieldType = 0
End If

End Function

Public Sub SaveAsText(lstInfo As ListItems, strFileName As String)
'------------------------------------------------------------
'数据导出为文本文件
'------------------------------------------------------------

Dim lpRecord
Dim ListX As ListItem
Dim lpSubItem As Long
Dim PrintLine As String
If lstInfo.Count <= 0 Then Exit Sub

Open strFileName For Output As #1

For lpSubItem = 1 To lstInfo.Item(1).ListSubItems.Count
    If lpSubItem <> 1 Then PrintLine = PrintLine & " , "
    PrintLine = PrintLine & lstInfo.Item(1).ListSubItems(lpSubItem).Key
Next lpSubItem
Print #1, PrintLine
  
For lpRecord = 1 To lstInfo.Count
    Set ListX = lstInfo.Item(lpRecord)
    PrintLine = ""
    For lpSubItem = 1 To ListX.ListSubItems.Count
        If lpSubItem <> 1 Then PrintLine = PrintLine & " , "
        PrintLine = PrintLine & ListX.ListSubItems(lpSubItem).text
    Next lpSubItem
    DoEvents
    Print #1, PrintLine
Next lpRecord

Close #1

End Sub

Public Sub SaveAsHtml(lstInfo As ListItems, strFileName As String)
'------------------------------------------------------------
'数据导出为HTML文件
'------------------------------------------------------------

If lstInfo.Count <= 0 Then Exit Sub

Dim i As Long, J As Long, K As Long, oldFont As New StdFont
Dim lWidth As Long

Open strFileName For Output As #1

Print #1, "<HTML>"
Print #1, "<HEAD>"
Print #1, "<meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312"">"
Print #1, "<meta http-equiv=""Content-Language"" content="; zh - cn; "" > ""
Print #1, "<meta name=""GENERATOR"" content = "" RiceSoft ProMap 2002# "" > "
Print #1, "<TITLE>报表</TITLE>"
Print #1, "<STYLE>"
Print #1, "<!--"
Print #1, "BODY,td {"
Print #1, "font-family:""宋体,Arial Black"";"
Print #1, "font-size:9pt;"
Print #1, "line-height:16px;"
Print #1, "}"
Print #1, "-->"
Print #1, "</STYLE>"
Print #1, "</Head>"
Print #1, "<Body>"

Print #1, "<Table border="" 1"">"

If lstInfo.Count > 1 Then
    lWidth = 100 / lstInfo.Count - 1
Else
    lWidth = 100 / lstInfo.Count
End If

If lWidth < 10 Then
    lWidth = 10
End If

lWidth = 1000

'表头
Print #1, "<TR>"
For J = 1 To lstInfo.Item(1).ListSubItems.Count
    Print #1, "<td width=""" & Str(lWidth) & """ bgcolor = ""#B1CACF"" > "
    Print #1, lstInfo.Item(1).ListSubItems(J).Key
    Print #1, "</td>"
Next J
Print #1, "</TR>"
'数据
For i = 1 To lstInfo.Count
    If i Mod 2 = 1 Then
        Print #1, "<TR bgcolor = ""#EFEFEF"">"
    Else
        Print #1, "<TR bgcolor = ""#FFFFFF"">"
    End If
    For J = 1 To lstInfo.Item(i).ListSubItems.Count
        Print #1, "<td width=""" & Str(lWidth) & """> "
        Print #1, lstInfo.Item(i).ListSubItems(J).text
        Print #1, "</td>"
    Next J
    Print #1, "</TR>"
Next i
    
Print #1, "</Table>"
Print #1, "</Body>"
Print #1, "</HTML>"
Close #1
End Sub