form1.frm

来自「运行程序前请先把"地图"文件夹中的地图集和图层拷到mapX4.0的maps文件夹」· FRM 代码 · 共 1,083 行 · 第 1/3 页

List1.Clear
Combo1.Clear
For i = 1 To Map1.Layers.Count
    List1.AddItem Map1.Layers(i).Name
    Combo1.AddItem Map1.Layers(i).Name
    'Form2.Combo1.AddItem Map1.Layers(i).Name
Next i
End Sub

 'Dim buffer As Boolean
Private Sub area_Click()
    Map1.CurrentTool = miSelectTool
    Celiangorbuffer = 1 '触发selectionchang事件来测量面积
End Sub

Private Sub Combo1_click()
'   Dim pnt As New Point, pnts As New Points
'   Dim ftr As Feature, ftrs As Features
   Dim lyr As Layer, rvs As MapXLib.RowValues
'   Dim infostr As String
   Dim flds As MapXLib.Fields
   Dim fld As MapXLib.Field
   Dim ds As MapXLib.Dataset
  Dim i As Integer
  Dim lyrname As String
  Dim ftrs As MapXLib.Features
  i = Combo1.ListIndex
  Combo2.Clear
  Set lyr = Map1.Layers.Item(i + 1)
  Set ftrs = lyr.AllFeatures
  Set ds = Map1.Datasets.Add(miDataSetLayer, lyr) '数据绑定
  For i = 1 To ftrs.Count
      Set rvs = ds.RowValues(ftrs.Item(i)) 'ftr对象的属性数据
      lyrname = ds.Fields.Item(1).Name & ":" & rvs.Item(1).Value
      Combo2.AddItem lyrname
  Next i
End Sub

Private Sub Command1_Click() 'ok
   If List1.ListIndex = -1 Then
      MsgBox "请选择一个图层"
   Else
      If Map1.Layers.Item(List1.ListIndex + 1).Name = "buffer" Then
          Map1.Layers.Remove (List1.ListIndex + 1)
          listalllayers
          Pbuffer.Checked = False
          Celiangorbuffer = 4
      Else
         Map1.Layers.Remove (List1.ListIndex + 1)
          listalllayers
      End If
  End If
End Sub

Public Sub Command2_Click() 'ok
  Map1.CreateCustomTool infoTool, miToolTypePoint, miCrossCursor
  Map1.CurrentTool = infoTool '激活Toolused事件
End Sub

Private Sub Command5_Click()
  Form2.Show
End Sub

Private Sub end_Click()
  End
End Sub

Private Sub find_Click()
Dim ftrs As MapXLib.Features
 Dim lyr As MapXLib.Layer
 Dim FoundObj As FindFeature
 'Set Map1.Layers("排水结点").Find.RefineLayer = Map1.Layers("排水改")
Set lyr = Map1.Layers(Combo1.Text)
Set FoundObj = Map1.Layers(Combo1.Text).find.Search(List2.Text)
  'Set ftrs = lyr.Search(宿舍 = Text3.Text)
 lyr.Selection.Replace FoundObj
'Set FoundObj = Map1.Layers("宿舍").Find.Search(Text3.Text)
 'Set FoundObj = Map1.Layers("排水结点").Find.Search("02", "sc")


 'If (FoundObj.FindRC Mod 10 = 1) Then
  Map1.Zoom = 0.2
  Map1.CenterX = FoundObj.CenterX
  Map1.CenterY = FoundObj.CenterY
   'FoundObj.Style.RegionColor = RGB(255, 255, 255)
 'Else
   'MsgBox "No exact match found. " + Str$(FoundObj.FindRC)
  ' End If
End Sub

Private Sub Form_Load()
   With Map1
  .Height = 5000
  .Width = 8000
  .Left = 100
  .Top = 450
  End With
  SSTab1.Left = 8200
  SSTab1.Top = 650
  Frame2.Top = 5500
  Frame2.Left = 100
  Form1.WindowState = 2 '最大化窗体
' Map1.CreateCustomTool PolyRulerTool, miToolTypePoly, miCrossCursor
  listalllayers
End Sub

Private Sub line_Click()
   '将会激活ToolUsed事件
  Map1.CurrentTool = PolyRulerTool
  Text1.Text = ""
  PolyRulerToolBengused = True
End Sub

Private Sub List1_Click()  '分层显示  ok
    If Option1.Value = True Then
        If List1.Selected(List1.ListIndex) = True Then
            Map1.Layers.Item(List1.ListIndex + 1).Visible = True
        End If
    Else
       If List1.Selected(List1.ListIndex) = True Then
          Map1.Layers.Item(List1.ListIndex + 1).Visible = False
       End If
    End If
End Sub

Private Sub litter_Click()
   Form2.Show
   
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
   Text1.Text = ""
   If Map1.CurrentTool = PolyRulerTool Then
    Map1.ConvertCoord x, Y, mousedownmapx, mousedownmapy, miScreenToMap '使屏幕坐标转化为地图坐标
   End If
    Text1.Text = ""
End Sub

Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
' Dim num As Double
' If RulerToolBengused Then '当调用了RulerTool工具后
'     If Map1.CurrentTool = PolyRulerTool Then  '调用自定义的画折线工具
'        Map1.ConvertCoord x, Y, dblmapx, dblmapy, miScreenToMap '使屏幕坐标转化为地图坐标
'        Map1.MapUnit = miUnitMeter
'        num = Map1.Distance(mousedownmapx, mousedownmapy, dblmapx, dblmapy)
'        Text1.Text = Format(num, "###00.000") & "米"
'     End If
' End If
End Sub
Private Sub Map1_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 pts As New MapXLib.Points
 Dim n As Integer, i As Integer
 Dim disSum As Double
 Dim Sum As Double
 Dim X1 As Double, X2 As Double, Y1 As Double, Y2 As Double
 Set pts = Points
 disSum = 0
 If Flags = miPolyToolEnd Then
    For i = 1 To pts.Count - 1
         X1 = pts.Item(i).x
         Y1 = pts.Item(i).Y
         X2 = pts.Item(i + 1).x
         Y2 = pts.Item(i + 1).Y
         Map1.MapUnit = miUnitMeter
         Sum = Map1.Distance(X1, Y1, X2, Y2)
        disSum = Sum + disSum
     Next i
   Text1.Text = Format(disSum, "####.000") & "米"
 End If
End Sub

Private Sub Map1_SelectionChanged()
Dim ftr As Feature, ftrBuffer As Feature
Dim Mydataset As Dataset
Dim Newstyle As MapXLib.Style
Dim Newftr As MapXLib.Feature
Dim lyr As Layer, selc As Selection
Dim x As String  '定义缓冲范围值x
Dim str As String '判断是否点到对象
Dim m As Integer '图层序号
Sumarea = 0: str = ""
Select Case Celiangorbuffer   'Celiang面积 = 1
    Case 1
       For Each lyr In Map1.Layers
           For Each ftr In lyr.Selection
               Set lyr = ftr.Layer  'get layer which is related to the feature
               Set Mydataset = Map1.Datasets.Add(miDataSetLayer, lyr)
               Set rvs = Mydataset.RowValues(ftr)
               Sumarea = Sumarea + rvs.Item(3).Value
           Next
       Next
     If Sumarea = 0 Then
        Text2.Text = ""
    Else
        Text2.Text = Sumarea
    End If
    Case 2  'buffer分析 = 2 (创造一个新的图层用来分析buffer,图层在Form_load中)
        For Each lyr In Map1.Layers
           For Each ftr In lyr.Selection
           str = ftr.Name
           Next
        Next
        If str <> "" Then '有对象则缓冲，无对象就不反应
          x = InputBox$("请输入缓冲区范围（单位：米）", 输入框)
             If x <> "" Then '如果按取消按钮就不作缓冲区分析
                For Each lyr In Map1.Layers
                   For Each ftr In lyr.Selection '得到一个对象ftr
                      Set ftrfac = Map1.FeatureFactory
                      Set ftrBuffer = ftrfac.BufferFeatures(ftr, Val(x), miUnitMeter)
                        '得到一个独立的缓冲区对象ftrbuffer
                   Next
               Next
              '  x = InputBox$("请输入缓冲区范围（单位：米）", 输入框)
               Set Newftr = Newlyr.AddFeature(ftrBuffer)
                '将缓冲区对象ftrbuffer添加到新图层中,并且返回一个和 ftrbuffer等价的对象Newftr
               Set Newstyle = Newftr.Style  '将Newftr的Style属性对象付给style对象
               Newstyle.RegionColor = 0 '改变颜色
               '更新
              Map1.AutoRedraw = False '在作出更改前禁止地图重绘
              Newlyr.Editable = True
             Set Newftr.Style = Newstyle '将改变后的style重新付给Newftr对象的Style属性
             Newftr.Update True '此方法使用对 Feature 对象所作更改更新图层
             Newlyr.Refresh  '此方法将从图层刷新缓存
             Newlyr.Editable = False
             Map1.AutoRedraw = True
          End If
      End If
    End Select
End Sub

Public 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)
   Picture1.Cls
   Select Case ToolNum  '不同的工具都会调用此事件,用ToolNum来区分
          Case infoTool
              pnt.Set X1, Y1   '得到坐标为x1,y1的以点对象
              For Each lyr In Map1.Layers
                  Set ftrs = lyr.SearchAtPoint(pnt)
                  If ftrs.Count > 0 Then
                    Set ds = Map1.Datasets.Add(miDataSetLayer, lyr) '数据绑定
                    fieldstr = ds.Fields.Item(1).Name
                    Set rvs = ds.RowValues(ftrs.Item(1)) 'ftr对象的属性数据
                    valuestr = rvs.Item(1).Value
                    Set ftr1 = ftrs.Item(1)  '保存对象,便于后面修改属性数据
                     For i = 1 To ds.Fields.Count
                       infostr = ds.Fields.Item(i).Name & ":" & rvs.Item(i).Value
                       Picture1.Print infostr
'                       a(i) = ds.Fields.Item(i).Name
'                       ': b(i) = rvs.Item(i).Value
                      Next i
                   End If
               Next
   End Select
End Sub

Private Sub more_Click()
   Form2.Show
   Form2.Combo2.Enabled = False
End Sub

Private Sub modify_Click()
  Form2.Show
End Sub

Private Sub New_Click()  'ok
   Dim newlayername As String
   newlayername = InputBox("请输入新层名(buffer出外)！", "newlayer")
   If newlayername <> "" Then
      Set newlayer = Map1.Layers.CreateLayer(newlayername) '已经添加到map1中了
      listalllayers
   End If
End Sub

Private Sub Open_Click()  'ok
  With CmD1
        .FileName = "*.gst"
        .DialogTitle = "打开文件"
        .Filter = "MapX GeoSet(*.gst)|*.gst"
        .CancelError = True
  End With
  CmD1.ShowOpen
  Map1.Geoset = CmD1.FileName
  listalllayers
End Sub

Private Sub Option1_Click() '分层显示  ok
   If List1.ListIndex = -1 Then
      MsgBox "请选择一个图层"
   Else
      If List1.Selected(List1.ListIndex) = True Then
            Map1.Layers.Item(List1.ListIndex + 1).Visible = True
       End If
   End If
End Sub

Private Sub Option2_Click()  '分层显示  ok
  If List1.ListIndex = -1 Then
     Option1.SetFocus
  Else
    If List1.Selected(List1.ListIndex) = True Then
            Map1.Layers.Item(List1.ListIndex + 1).Visible = False
    End If
  End If
End Sub

Private Sub pan_Click()
 Map1.CurrentTool = miPanTool

End Sub

Private Sub Pbuffer_Click()  'ok
 Dim ftrs As MapXLib.Features
 Map1.CurrentTool = miSelectTool
 Pbuffer.Checked = Not Pbuffer.Checked
  If Pbuffer.Checked Then
     Celiangorbuffer = 2  '通过调用selectionchange事件得到一个对象
     Set Newlyr = Map1.Layers.CreateLayer("buffer") '创造一个新的图层，名为buffer
     listalllayers
  Else
    Set ftrs = Newlyr.AllFeatures
    For i = 1 To ftrs.Count
      Newlyr.DeleteFeature (i)
    Next i
     Celiangorbuffer = 0
     Map1.Layers.Remove ("buffer")
  End If
End Sub

Private Sub polyline_Click()
  '将会激活PolyToolUsed事件
  Map1.CurrentTool = PolyRulerTool
 RulerToolBengused = True 'RulerTool工具屏蔽
End Sub




Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
   Select Case Button.Index
          Case 1
              pan_Click
          Case 3
               'Map1.CurrentTool = miSelectTool
               'Celiangorbuffer = 4 '不调用selectionchang事件
          Case 4
               zoomin_Click
          Case 5
               zoomout_Click
          Case 2
   End Select
End Sub

Private Sub zoomin_Click()
  Map1.CurrentTool = miZoomInTool

End Sub

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