frmmain.frm

GIS+VB开发. GIS+VB开发.

LayerControl
End Sub

Private Sub CmdRemove_Click()
Dim ii As Integer, TempFlag As Boolean, jj As Integer
TempFlag = False
For ii = 2 To TreeView1.Nodes.Count
  If TreeView1.Nodes.Item(ii).Selected Then TempFlag = True
Next ii
If TempFlag Then
  MyMap.Layers.Remove (TreeView1.SelectedItem.Text)
  Eagle.Layers.Remove (TreeView1.SelectedItem.Text)
  Eagle.Bounds = Eagle.Layers.Bounds
  TreeView1.Nodes.Remove (TreeView1.SelectedItem.Text)
Else
  MsgBox "请先选择个图层"
  Exit Sub
End If
End Sub

Private Sub CmdUp_Click()
Dim ii As Integer, TempFlag As Boolean, jj As Integer
TempFlag = False
For ii = 2 To TreeView1.Nodes.Count
  If TreeView1.Nodes.Item(ii).Selected Then TempFlag = True
Next ii
If TempFlag Then
  If TreeView1.SelectedItem.Index = 2 Then
    MsgBox "图层已经在最上"
    Exit Sub
  Else
    jj = TreeView1.SelectedItem.Index
    MyMap.Layers.Move jj - 1, jj - 2
    Eagle.Layers.Move jj, jj - 1
    LayerList
  End If
Else
  MsgBox "请先选择一个图层"
  Exit Sub
End If
End Sub

Private Sub Command5_Click()
Dim TempLayer As Layer, TempFeatures As New MapXLib.Features
Dim TempDataset As MapXLib.Dataset, TempFeature As MapXLib.Feature, TempField As MapXLib.Field
Dim NodX As Node, NodY As Node, NodZ As Node
If Trim(Text1.Text) = "" Then
  MsgBox "请输入关键字"
  Text1.SetFocus
  Exit Sub
End If
TreeView2.Nodes.Clear
    For Each TempLayer In MyMap.Layers
      If TempLayer.Selectable = True Then
        Set TempDataset = MyMap.DataSets.Add(miDataSetLayer, TempLayer)
        Set TempFeatures = MyMap.Layers.Item(TempLayer).Search(TempLayer.KeyField + " like ""%" + Trim(Text1.Text) + "%""")
          If TempFeatures.Count > 0 Then
            Set NodX = TreeView2.Nodes.Add(, tvwChild, TempLayer.Name, TempLayer.Name)
            NodX.EnsureVisible
              For Each TempFeature In TempFeatures
              Set NodY = TreeView2.Nodes.Add(NodX, tvwChild, TempLayer.Name + "|||" + TempFeature.FeatureKey, TempFeature.Name)
              NodY.EnsureVisible
              Next
          End If
      End If
    Next
End Sub

Private Sub Command6_Click()
Dim TempLayer As Layer, TempFeatures As New MapXLib.Features, TempPoint As New MapXLib.Point
Dim TempDataset As MapXLib.Dataset, TempFeature As MapXLib.Feature, TempField As MapXLib.Field
Dim NodX As Node, NodY As Node, NodZ As Node
Dim IntTempA As Integer, TempUnit As Integer
Dim TempMapX As Double, TempMapY As Double
IntTempA = Val(Text3.Text)
If IntTempA <= 0 Then
  MsgBox "距离范围输入有错误"
  Text3.SetFocus
  Exit Sub
End If
Select Case Combo1.Text
Case "Mile"
  TempUnit = 0
Case "KiloMeter"
  TempUnit = 1
Case "Inch"
  TempUnit = 2
Case "Foot"
  TempUnit = 3
Case "Yard"
  TempUnit = 4
Case "MilliMeter"
  TempUnit = 5
Case "CentiMeter"
  TempUnit = 6
Case "Meter"
  TempUnit = 7
Case "SurveyFoot"
  TempUnit = 8
Case "NauticalMile"
  TempUnit = 9
Case "Twip"
  TempUnit = 10
Case "Point"
  TempUnit = 11
Case "Pica"
  TempUnit = 12
Case "Degree"
  TempUnit = 13
Case "Link"
  TempUnit = 30
Case "Chain"
  TempUnit = 31
Case "Rod"
  TempUnit = 32
End Select
TreeView2.Nodes.Clear
'MyMap.ConvertCoord MyMap.CenterX, MyMap.CenterY, TempMapX, TempMapY, miScreenToMap
TempPoint.Set MyMap.CenterX, MyMap.CenterY
    For Each TempLayer In MyMap.Layers
      If TempLayer.Selectable = True Then
        Set TempDataset = MyMap.DataSets.Add(miDataSetLayer, TempLayer)
        Set TempFeatures = TempLayer.SearchWithinDistance(TempPoint, IntTempA, TempUnit, Combo2.ListIndex)
          If TempFeatures.Count > 0 Then
            Set NodX = TreeView2.Nodes.Add(, tvwChild, TempLayer.Name, TempLayer.Name)
            NodX.EnsureVisible
              For Each TempFeature In TempFeatures
              Set NodY = TreeView2.Nodes.Add(NodX, tvwChild, TempLayer.Name + "|||" + TempFeature.FeatureKey, TempFeature.Name)
              NodY.EnsureVisible
              Next
          End If
      End If
    Next
End Sub

Private Sub fileclosemenu_Click()
On Error Resume Next
MyMap.Layers.RemoveAll
Eagle.Layers.RemoveAll
MyMap.GeoSet = ""
Eagle.GeoSet = ""
Set m_Fea = Nothing
Set m_TempLayer = Nothing
MyMap.GeoSet = ""
MyMap.Title.Visible = False
Eagle.GeoSet = ""
Eagle.Title.Visible = False
MyFileName = ""
MyFilePath = ""
MyMap.Title = "未命名"
FrmMain.Caption = "电子地图查询系统----" + MyMap.Title
Set m_TempLayer = Eagle.Layers.CreateLayer("T_tempLayer") '给eagle增加临时图层
filesavemenu.Enabled = False
filesaveasmenu.Enabled = False
Toolbar1.Buttons(2).Enabled = False
TreeView2.Nodes.Clear
Unload FrmSearchAdv
Unload FrmInfo
SSTab1.Tab = 0
SSTab2.Tab = 0
SSTab1.Enabled = False
TreeView1.Nodes.Clear
End Sub

Private Sub fileendmenu_Click()
End
End Sub

Private Sub fileopenmenu_Click()
Dim filepath As String
Dim filename As String
On Error Resume Next
CommonDialog1.DialogTitle = "电子地图查询系统----打开地图集"
CommonDialog1.DefaultExt = "gst"
CommonDialog1.Filter = "MapX GeoSet(*.gst)|*.gst"
CommonDialog1.CancelError = True
CommonDialog1.ShowOpen
If Err.Number = 32755 Then
  Exit Sub
Else
  MyFileName = CommonDialog1.FileTitle
  MyFilePath = Left(CommonDialog1.filename, Len(CommonDialog1.filename) - Len(MyFileName) - 1)
  Call LoadGST
  FrmMain.Caption = "电子地图查询系统----" + MyMap.Title
  filesavemenu.Enabled = True
  filesaveasmenu.Enabled = True
  Toolbar1.Buttons(2).Enabled = True
  SSTab1.Enabled = True
End If
End Sub


Private Sub fileoutmenu_Click()
FrmOutPut.Show 1, FrmMain
End Sub

Private Sub fileprintmenu_Click()
FrmPrint.Show 1, FrmMain
End Sub

Private Sub filesaveasmenu_Click()
On Error Resume Next
CommonDialog1.DialogTitle = "电子地图查询系统----另存地图集"
CommonDialog1.DefaultExt = "gst"
CommonDialog1.Filter = "MapX GeoSet (*.gst)|*.gst"
CommonDialog1.CancelError = True
CommonDialog1.Flags = &H2
CommonDialog1.Action = 2
If Err.Number = 32755 Then Exit Sub
MyFileName = CommonDialog1.FileTitle
MyFilePath = Left(CommonDialog1.filename, Len(CommonDialog1.filename) - Len(MyFileName) - 1)
If Right(MyFileName, 4) <> ".gst" Then MyFileName = MyFileName + ".gst"
MyMap.SaveMapAsGeoset MyMap.Title, MyFilePath + "\" + MyFileName
End Sub

Private Sub filesavemenu_Click()
If MyMap.GeoSet <> "" And MyFileName <> "" And MyFilePath <> "" Then
MyMap.SaveMapAsGeoset MyMap.Title, MyFilePath + "\" + MyFileName
MyMap.Refresh
Else
filesaveasmenu_Click
End If
End Sub

Private Sub helpaboutmenu_Click()
FrmAbout.Show 1, FrmMain
End Sub

Private Sub helphelpmenu_Click()
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(App.Path + "\Help.chm") Then
  ShellExecute hwnd, "Open", "Help.chm", 0, App.Path, 1
Else
MsgBox "没有找到帮助文件"
End If
End Sub

Private Sub helpquestionmenu_Click()
If IsConnected = False Then
  MsgBox "你没有连接网络。"
  Exit Sub
Else
ShellExecute hwnd, "Open", "Http://MapSearch.99model.com", 0, 0, 0
End If
End Sub

Private Sub helpregmenu_Click()
FrmReg.Show 1, FrmMain
End Sub

'根据mymap的Bounds在eagle上绘制矩形
Private Sub mymap_MapViewChanged()
On Error Resume Next
Dim TempFea As MapXLib.Feature
Dim tempPnts As MapXLib.Points
Dim tempStyle As MapXLib.Style
If m_TempLayer.AllFeatures.Count = 0 Then
'设置矩形边框样式
Set tempStyle = New MapXLib.Style
tempStyle.RegionPattern = miPatternNoFill
tempStyle.RegionBorderColor = 255
tempStyle.RegionBorderWidth = 2
'在临时图层添加大小为mymap的边界的Rectangle对象
Set TempFea = Eagle.FeatureFactory.CreateRegion(MyMap.Bounds, tempStyle)
Set m_Fea = m_TempLayer.AddFeature(TempFea)
Set tempStyle = Nothing
Else '根据mymap的视野变化改变矩形边框的大小和位置
With m_Fea.Parts.Item(1)
.RemoveAll
.AddXY MyMap.Bounds.XMin, MyMap.Bounds.YMin
.AddXY MyMap.Bounds.XMax, MyMap.Bounds.YMin
.AddXY MyMap.Bounds.XMax, MyMap.Bounds.YMax
.AddXY MyMap.Bounds.XMin, MyMap.Bounds.YMax
End With
m_Fea.Update
End If
End Sub

Private Sub eagle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim MapX As Double
Dim MapY As Double
bDown = True
Eagle.ConvertCoord X, Y, MapX, MapY, miScreenToMap
MyMap.CenterX = MapX
MyMap.CenterY = MapY
End Sub

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

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


Private Sub filedefaultmenu_Click()
If Not LoadDefault Then
MsgBox "缺省地图不存在"
filedefaultmenu.Enabled = False
End If
filesavemenu.Enabled = True
filesaveasmenu.Enabled = True
Toolbar1.Buttons(2).Enabled = True
SSTab1.Enabled = True
End Sub

Private Sub Form_Load()
FrmMain.Show
If RegFlag Then
Else
  Dim MyMsg
  MyMsg = MsgBox("软件未注册，是否现在注册？", vbYesNo)
  If MyMsg = 6 Then FrmReg.Show 1, FrmMain
End If
MyMap.CreateCustomTool 201, miToolTypePoly, 2
MyMap.CreateCustomTool 202, miToolTypePolygon, 2
MyMap.CreateCustomTool 203, miToolTypePoint, 28
If Not LoadDefault Then Call fileclosemenu_Click
End Sub

Private Sub Form_Resize()
'窗体大小不能小于640*480像素
If FrmMain.WindowState = 1 Then Exit Sub
If FrmMain.Height < 7200 Then FrmMain.Height = 7200
If FrmMain.Width < 9600 Then FrmMain.Width = 9600
'窗体大小改变时，MAP控件和TAB控件也应做相应改变以适应窗体大小
SSTab1.Height = FrmMain.Height - 1500
Picture1.Height = FrmMain.Height - 1500
Picture1.Width = FrmMain.Width - 3030
TreeView1.Height = SSTab1.Height - 3330
Eagle.Top = SSTab1.Height - 2700
TreeView2.Height = SSTab1.Height - 1130
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set m_Fea = Nothing
Set m_TempLayer = Nothing
End
End Sub


Private Sub MyMap_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim TempMapX As Double, TempMapY As Double
MyMap.ConvertCoord X, Y, TempMapX, TempMapY, miScreenToMap
StatusBar1.Panels.Item(1).Text = Format(TempMapX, "#.0000") & "，" & Format(TempMapY, "#.0000")
End Sub

Private Sub MyMap_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
PopupMenu popmenu
End If
End Sub

Private Sub MyMap_PolyToolUsed(ByVal ToolNum As Integer, ByVal Flags As Long, ByVal Points As Object, ByVal bShift As Boolean, ByVal bCtrl As Boolean, EnableDefault As Boolean)
Dim ii As Integer, X1 As Double, X2 As Double, Y1 As Double, Y2 As Double
Dim DisLine As Double, DisPoly As Double
Dim MyFtr As Feature, TempPoint As Point, TempLayer As Layer, TempFeatures As New MapXLib.Features
Dim TempDataset As MapXLib.Dataset, TempFeature As MapXLib.Feature, TempField As MapXLib.Field
Select Case ToolNum
Case 201

If Points.Count > 1 Then
Set MyFtr = MyMap.FeatureFactory.CreateLine(Points, MyMap.DefaultStyle)
  For ii = 1 To Points.Count - 1
    X1 = Points.Item(ii).X
    Y1 = Points.Item(ii).Y
    X2 = Points.Item(ii + 1).X
    Y2 = Points.Item(ii + 1).Y
    DisLine = MyMap.Distance(X1, Y1, X2, Y2)
    DisPoly = DisPoly + DisLine
    StatusBar1.Panels.Item(2).Text = "当前距离：" + Format(DisLine, "#.00") + GetMapUnit + "|总长度：" + Format(DisPoly, "#.00") + GetMapUnit
  Next
End If

Case 202

 On Error Resume Next
 Dim TempFea As New MapXLib.Feature
 Dim TempArea As Double
 If (Points.Count > 2) Then
 Set TempFea = New Feature
 Set TempFea = MyMap.FeatureFactory.CreateRegion(Points)
 TempArea = TempFea.Area
 End If
 StatusBar1.Panels.Item(2).Text = "面积：" + Format(TempArea, "#.0000") + MyMapAreaUnit
End Select
End Sub

Private Sub MyMap_SelectionChanged()
SelectList
End Sub

Private Sub MyMap_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)
Dim MyFtr As Feature, TempPoint As New MapXLib.Point, TempLayer As Layer, TempFeatures As New MapXLib.Features
Dim TempDataset As MapXLib.Dataset, TempFeature As MapXLib.Feature, TempField As MapXLib.Field
Dim TempDoubleA As Double, TempDoubleB As Double
Select Case ToolNum
Case 203
 Dim NodX As Node, NodY As Node, NodZ As Node
 On Error Resume Next
 FrmInfo.Show 0, FrmMain
 TempPoint.Set X1, Y1
 FrmInfo.TreeInfo.Nodes.Clear
    For Each TempLayer In MyMap.Layers
      If TempLayer.Selectable = True Then
        TempLayer.BeginAccess (miAccessRead)
        Set TempFeatures = MyMap.Layers.Item(TempLayer).SearchAtPoint(TempPoint, miSearchResultAll)

        If TempFeatures.Count > 0 Then
          Set NodX = FrmInfo.TreeInfo.Nodes.Add(, tvwChild, TempLayer.Name, TempLayer.Name)
          NodX.EnsureVisible
          Set TempDataset = MyMap.DataSets.Add(miDataSetLayer, TempLayer)
          For Each TempFeature In TempFeatures
            Set NodY = FrmInfo.TreeInfo.Nodes.Add(NodX, tvwChild, TempLayer.Name + "|||" + TempFeature.FeatureKey, TempFeature.Name)
            NodY.EnsureVisible
            For Each TempField In TempDataset.Fields
                Set NodZ = FrmInfo.TreeInfo.Nodes.Add(NodY, tvwChild, TempLayer.Name + "|||" + TempFeature.FeatureKey + "|||" + TempField.Name, TempField.Name + "：" + CStr(TempDataset.Value(TempFeature.FeatureKey, TempField.Name)))
                NodZ.EnsureVisible
            Next
            NodY.Expanded = False
          Next
        End If
       TempLayer.EndAccess (0)
      End If
    Next
End Select
End Sub

Private Sub Picture1_Resize()
'定义MAP控件的大小，当图片框改变时自动改变
MyMap.Left = 0
MyMap.Top = 0
MyMap.Width = Picture1.Width
MyMap.Height = Picture1.Height
End Sub

Private Function LoadDefault() As Boolean
'装载缺省地图
Dim fs
Dim stra As String, StrB As String