mygis002.frm

电子地图查询系统

Dim i As Layer
Dim f As Feature
Dim parnode As Node
TreeView1.Nodes.Clear
For Each i In Map1.Layers
If i.Selection.Count > 0 Then
Set parnode = TreeView1.Nodes.Add(, , i.Name, i.Name)
parnode.Expanded = True
For Each f In i.Selection
TreeView1.Nodes.Add parnode, tvwChild, parnode.Key & f.Name, f.Name
Next
End If
Next
End Sub



Private Sub Map1_ToolUsed(ByVal ToolNum As Integer, ByVal x1 As Double, ByVal y1 As Double, ByVal X2 As Double, ByVal Y2 As Double, ByVal Distance As Double, ByVal Shift As Boolean, ByVal Ctrl As Boolean, EnableDefault As Boolean)
Select Case ToolNum
Case AREATOOLSEARCH
On Error Resume Next
Map1.MapUnit = miUnitMeter
Dim ftrs As Features
Dim Pt As New Point
Dim a As Double, i As Integer
TreeView1.Nodes.Clear
a = InputBox("请输入查询范围的半径（单位：米）", "范围查询")
If a = 0 Then Exit Sub
Pt.Set x1, y1
For i = 1 To Map1.Layers.Count
Set ftrs = Map1.Layers(i).SearchWithinDistance(Pt, a, miUnitMeter, miSearchTypePartiallyWithin)
Map1.Layers(i).Selection.Replace ftrs
Next
End Select

End Sub

Private Sub Map2_MapInitialized()
Set Map2.Bounds = Map2.Layers.Bounds
End Sub


Private Sub mbsearch_Click()
Dim lyR As Layer
Dim findobj As MapXLib.Find
Dim a As String
Dim i As Integer
Dim Fdat As FindFeature
Dim layerds As Dataset
Dim fid As MapXLib.Field
On Error Resume Next
TreeView1.Nodes.Clear
For Each lyR In Map1.Layers
Map1.DataSets.Add miDataSetLayer, lyR, lyR.Name
Next
a = InputBox("请输入模糊查询目标", "模糊查询")
For i = 1 To Map1.Layers.Count
Set findobj = Map1.Layers(i).Find
Set layerds = Map1.DataSets.Item(Map1.Layers(i).Name)
Dim X As MapXLib.Field
Set findobj.FindDataset = Formmain.Map1.DataSets(Map1.Layers(i).Name)
For Each fid In layerds.Fields
Set findobj.FindField = findobj.FindDataset.Fields(fid)
Set Fdat = findobj.Search(a)
Map1.Layers(i).Selection.Replace Fdat
Next
Next
'If Fdat = Null Then MsgBox "没有找到任何数据！", , "提示"
Formmain.Map1.DataSets.RemoveAll
End Sub

Private Sub menuexit_Click()
End
End Sub

Private Sub menulayerbz_Click()
Form3.Show
End Sub

Private Sub menulayercontrol_Click()
Map1.Layers.LayersDlg
Map1.Refresh
End Sub

Private Sub menulayeropen_Click()
Dim sfile As String
With CM1
On Error Resume Next
.DialogTitle = "加载图层"
.Filter = "MapInfo Tables (*.tab)|*.tab"
.CancelError = True
.ShowOpen
   If Err.Number = 32755 Then Exit Sub
sfile = .filename
End With
If Map1.GeoSet = "" Then
MsgBox "请先打开或加载一个地图集", , "警告"
Exit Sub
End If
On Error Resume Next
Map1.Layers.Add sfile
End Sub

Private Sub menulayeropengst_Click()
Dim sfile As String
With CM1
On Error Resume Next
.DialogTitle = "加载图层集"
.Filter = "MapX GeoSet (*.gst)|*.gst"
.CancelError = True
.ShowOpen
If Err.Number = 32755 Then Exit Sub
sfile = .filename
End With
  If sfile = Map1.GeoSet Then
  MsgBox "请务重复加载同一个地图集", , "警告"
  Exit Sub
  End If
Map1.Layers.AddGeoSetLayers sfile
End Sub

Private Sub menulayerremove_Click()
Form1.Show
End Sub

Private Sub menulayerview_Click()
Form2.Show
End Sub

Private Sub menumapclose_Click()
Map1.GeoSet = ""
TreeView1.Nodes.Clear
End Sub

Private Sub menumapopen_Click()
  Dim filepath As String
    Dim filename As String
    On Error Resume Next
    CM1.DialogTitle = "打开文件"
    CM1.DefaultExt = "gst"
    CM1.Filter = "MapX GeoSet(*.gst)|*.gst"
    CM1.CancelError = True
    CM1.Action = 1
  If Err.Number = 32755 Then Exit Sub
  If CM1.filename = Map1.GeoSet Then
  MsgBox "请务重复打开同一个地图", , "警告"
  Exit Sub
  End If
Map1.GeoSet = CM1.filename
End Sub

Private Sub menumapsave_Click()
    If Map1.GeoSet = "" Then
    MsgBox "当前没有地图，无需保存", , "警告"
    Exit Sub
    End If
    Dim filepath As String
    Dim filename As String
    On Error Resume Next
    CM1.DialogTitle = "保存地图集"
    CM1.DefaultExt = "gst"
    CM1.Filter = "MapX GeoSet (*.gst)|*.gst"
    CM1.CancelError = True
    filename = CM1.FileTitle
    filepath = CM1.filename
    filename = Left(filename, InStr(filename, ".") - 1)
    Map1.SaveMapAsGeoset filename, filepath
End Sub

Private Sub menuselectnotall_Click()
    Dim lyrs As MapXLib.Layer
    For Each lyrs In Formmain.Map1.Layers
         lyrs.Selection.ClearSelection
    Next
    Set lyrs = Nothing
End Sub

Private Sub menuviewalllayer_Click()
Map1.Bounds = Map1.Layers.Bounds
End Sub

Private Sub menutoolarrow_Click()
Map1.CurrentTool = miArrowTool
End Sub

Private Sub menutoolpan_Click()
Map1.CurrentTool = miPanTool
End Sub

Private Sub menutoolzoomin_Click()
Map1.CurrentTool = miZoomInTool
End Sub

Private Sub menutoolzoomout_Click()
Map1.CurrentTool = miZoomOutTool
End Sub


Private Sub movelayers_Click()
Form4.Show
End Sub

Private Sub othersave_Click()

    If Map1.GeoSet = "" Then
    MsgBox "当前没有地图，无需保存", , "警告"
    Exit Sub
    End If
     Dim filepath As String
    Dim filename As String
    On Error Resume Next
    CM1.DialogTitle = "保存地图集"
    CM1.DefaultExt = "gst"
    CM1.Filter = "MapX GeoSet (*.gst)|*.gst"
    CM1.CancelError = True
    CM1.Flags = &H2
    CM1.Action = 2
   If Err.Number = 32755 Then Exit Sub
    filename = CM1.FileTitle
    filepath = CM1.filename
    filename = Left(filename, InStr(filename, ".") - 1)
    Map1.SaveMapAsGeoset filename, filepath
End Sub


Private Sub outmapbmp_Click()
    If Map1.GeoSet = "" Then
    MsgBox "当前没有地图，无法输出地图", , "警告"
    Exit Sub
    End If
    Dim filepath As String
    On Error Resume Next
    CM1.DialogTitle = "输出BMP地图"
    CM1.DefaultExt = "bmp"
    CM1.Filter = "BMP格式(*.bmp)|*.bmp"
    CM1.CancelError = True
    CM1.Flags = &H2
    CM1.Action = 2
   If Err.Number = 32755 Then Exit Sub
    filepath = CM1.filename
    Map1.ExportMap filepath, miFormatBMP
End Sub

Private Sub outmapgif_Click()
    If Map1.GeoSet = "" Then
    MsgBox "当前没有地图，无法输出地图", , "警告"
    Exit Sub
    End If
    Dim filepath As String
    On Error Resume Next
    CM1.DialogTitle = "输出GIF地图"
    CM1.DefaultExt = "gif"
    CM1.Filter = "GIF格式(*.gif)|*.gif"
    CM1.CancelError = True
    CM1.Flags = &H2
    CM1.Action = 2
   If Err.Number = 32755 Then Exit Sub
    filepath = CM1.filename
    Map1.ExportMap filepath, miFormatGIF
End Sub

Private Sub outmapjpg_Click()
    If Map1.GeoSet = "" Then
    MsgBox "当前没有地图，无法输出地图", , "警告"
    Exit Sub
    End If
    Dim filepath As String
    On Error Resume Next
    CM1.DialogTitle = "输出JPG地图"
    CM1.DefaultExt = "jpg"
    CM1.Filter = "JPG格式(*.jpg)|*.jpg"
    CM1.CancelError = True
    CM1.Flags = &H2
    CM1.Action = 2
   If Err.Number = 32755 Then Exit Sub
    filepath = CM1.filename
    Map1.ExportMap filepath, miFormatJPEG
End Sub

Private Sub outmaptif_Click()
    If Map1.GeoSet = "" Then
    MsgBox "当前没有地图，无法输出地图", , "警告"
    Exit Sub
    End If
    Dim filepath As String
    On Error Resume Next
    CM1.DialogTitle = "输出TIF地图"
    CM1.DefaultExt = "tif"
    CM1.Filter = "TIF格式(*.tif)|*.tif"
    CM1.CancelError = True
    CM1.Flags = &H2
    CM1.Action = 2
   If Err.Number = 32755 Then Exit Sub
    filepath = CM1.filename
    Map1.ExportMap filepath, miFormatTIF
End Sub

Private Sub regiongg_Click()
Set teststyle = Map1.DefaultStyle
teststyle.PickRegion
Set Map1.DefaultStyle = teststyle
End Sub


Private Sub symbolgg_Click()
Set teststyle = Map1.DefaultStyle
teststyle.PickSymbol
Set Map1.DefaultStyle = teststyle
End Sub

Private Sub textgg_Click()
Set teststyle = Map1.DefaultStyle
teststyle.PickText
Set Map1.DefaultStyle = teststyle
End Sub

Private Sub Toolbar2_ButtonClick(ByVal Button As MSComctlLib.Button)
On Error Resume Next
Select Case Button.Key
Case "toolbarsave"
menumapsave_Click
Case "toolbaropen"
menumapopen_Click
Case "searchpoin"
dwsearchpoint_Click
Case "toolbarprint"
Map1.CurrentTool = miArrowTool
Case "zoomin"
Map1.CurrentTool = miZoomInTool
Case "zoomout"
Map1.CurrentTool = miZoomOutTool
Case "pan"
Map1.CurrentTool = miPanTool
Case "alllayers"
Map1.Bounds = Map1.Layers.Bounds
Case "notallselect"
menuselectnotall_Click
Case "controllayers"
menulayercontrol_Click
Case "searchdistan"
Map1.CurrentTool = 1
Case "aboutme"
frmAbout.Show
End Select
End Sub


Private Sub Map1_MapViewChanged()
Dim tempFea As MapXLib.Feature
Dim tempPnts As MapXLib.Points
Dim tempStyle As MapXLib.Style
Map2.GeoSet = Map1.GeoSet
Map1.Title.Visible = False
Map2.Title.Visible = False
If Map1.GeoSet = "" Then
menutool.Enabled = False
menulayer.Enabled = False
menusearch.Enabled = False
Else
menutool.Enabled = True
menulayer.Enabled = True
menusearch.Enabled = True
End If
Set m_TempLayer = Map2.Layers.CreateLayer("T_tempLayer") '给Map2增加临时图层
If m_TempLayer.AllFeatures.Count = 0 Then
'设置矩形边框样式
Set tempStyle = New MapXLib.Style
tempStyle.RegionPattern = miPatternNoFill
tempStyle.RegionBorderColor = 255
tempStyle.RegionBorderWidth = 2
'在临时图层添加大小为Map1的边界的Rectangle对象
Set tempFea = Map2.FeatureFactory.CreateRegion(Map1.Bounds, tempStyle)
Set m_Fea = m_TempLayer.AddFeature(tempFea)
Set tempStyle = Nothing
Else '根据Map1的视野变化改变矩形边框的大小和位置
With m_Fea.Parts.Item(1)
.RemoveAll
.AddXY Map1.Bounds.XMin, Map1.Bounds.YMin
.AddXY Map1.Bounds.XMax, Map1.Bounds.YMin
.AddXY Map1.Bounds.XMax, Map1.Bounds.YMax
.AddXY Map1.Bounds.XMin, Map1.Bounds.YMax
End With
m_Fea.Update
End If
End Sub

'下面代码和"API方式实现"的一样
Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim MapX As Double
Dim MapY As Double
bDown = True
Map2.ConvertCoord X, Y, MapX, MapY, miScreenToMap
Map1.CenterX = MapX
Map1.CenterY = MapY

End Sub

Private Sub Map2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim MapX As Double
Dim MapY As Double
If bDown Then
Map2.ConvertCoord X, Y, MapX, MapY, miScreenToMap
Map1.CenterX = MapX
Map1.CenterY = MapY
End If
End Sub

Private Sub Map2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
bDown = False
End Sub