editlayer.cls

用vc+mapx制作的地理信息系统软件

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "EditLayer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Public PolyColor As Long
Dim m_grid As SnappingGrid
Dim m_map As MapObjects2.Map

'多边形序列
Dim m_polys() As MapObjects2.Polygon

'选择的多边形或顶点
Dim m_selPoly As Integer
Dim m_selVertex As Integer

'删除选定的多变形或顶点
Sub DeleteSelection()
  '若存在,则删除被选中的顶点
  If m_selVertex >= 0 Then
    Set pts = m_polys(m_selPoly).Parts(0)
    If pts.Count > 4 Then
      pts.Remove m_selVertex
      m_selVertex = m_selVertex - 1
    Else
      m_selVertex = -1
    End If
    
    Refresh
    Exit Sub
  End If
  
  '若存在,则删除被选中的多边形
  If m_selPoly >= 0 Then
    Set m_polys(m_selPoly) = Nothing
    numPolys = UBound(m_polys) - 1
    Set Last = m_polys(numPolys)
    ReDim Preserve m_polys(numPolys)
    If Not Last Is Nothing Then
      Set m_polys(m_selPoly) = Last
    End If
    
    If m_selPoly >= numPolys Then
      '选择下一个多边形
      m_selPoly = m_selPoly - 1
    End If
    
    Refresh
  End If
End Sub

Sub Draw()
  '此方法需置于AfterTrackingLayerDraw事件处理代码中
  Dim sym As New MapObjects2.Symbol
  sym.Color = PolyColor
  sym.Style = moGrayFill
  For i = 0 To UBound(m_polys) - 1
    m_map.DrawShape m_polys(i), sym
  Next i
  
  '绘制选择的多边形或顶点
  sym.SymbolType = moPointSymbol
  sym.Size = 7
  sym.Color = m_grid.Color
  
  If m_selPoly >= 0 Then
    Set pts = m_polys(m_selPoly).Parts(0)
    For Each p In pts
      m_map.DrawShape p, sym
    Next p
    sym.Color = moYellow
    If m_selVertex >= 0 Then m_map.DrawShape pts(m_selVertex), sym
  End If
End Sub

'将编辑图层中的图形存储在Shape文件中
Sub ExportToShapefile(pathName As String)
  Dim fileName As String, dirName As String
  SplitPath pathName, dirName, fileName
  Dim dc As New MapObjects2.DataConnection
  dc.Database = dirName
  '检测是否连接成功
  If Not dc.Connect Then Exit Sub
  
  Dim tDesc As New MapObjects2.TableDesc
  Dim gs As GeoDataset
  Set gs = dc.AddGeoDataset(fileName, moPolygon, tDesc)
  '错误的文件名
  If gs Is Nothing Then Exit Sub
   
  Dim layer As New MapObjects2.MapLayer
  Set layer.GeoDataset = gs
  Set recs = layer.Records
  Set shpFld = recs.Fields("Shape")
  
  '向文件中写入编辑图层中的多边形
  For i = 0 To UBound(m_polys) - 1
    recs.AddNew
    shpFld.Value = m_polys(i)
    recs.Update
  Next i
End Sub

'类初始化代码
Sub Initialize(Map As MapObjects2.Map, grid As SnappingGrid)
  Set m_map = Map
  Set m_grid = grid
End Sub

'刷新TrackingLayer
Sub Refresh()
  m_map.TrackingLayer.Refresh True
End Sub

'选择pt附近的多边形顶点
Function SelectVertex(pt As MapObjects2.Point) As Boolean
  tol = m_map.ToMapDistance(100)
  If m_selPoly >= 0 Then
    m_selVertex = -1
    Set pts = m_polys(m_selPoly).Parts(0)
    For Each v In pts
      m_selVertex = m_selVertex + 1
      If v.DistanceTo(pt) < tol Then
        Refresh
        SelectVertex = True
        Exit Function
      End If
    Next v
  End If
  
  SelectVertex = False
End Function

'调整多边形,以适合当前网格
Sub SnapPolygons()
  For i = 0 To UBound(m_polys) - 1
    Set m_polys(i) = m_grid.SnapPolygon(m_polys(i), m_map)
  Next i
  Refresh
End Sub

'向多边形中添加顶点
Sub SplitPolygon(pt As MapObjects2.Point)
  If m_selPoly = -1 Then Exit Sub
  
  Dim pts As MapObjects2.Points
  Set pts = m_polys(m_selPoly).Parts(0)
  tol = m_map.ToMapDistance(100)
  
  pts.Add pts(0)
  For i = 1 To pts.Count - 1
    dist = pt.DistanceToSegment(pts(i - 1), pts(i))
    If dist <= tol Then
      m_grid.SnapPoint pt, m_map
      '插入顶点
      pts.Insert i, pt
      '选择这个顶点
      m_selVertex = i
      Refresh
      Exit Sub
    End If
  Next i
End Sub

'选中pt所在的多边形
Function SelectPolygon(pt As MapObjects2.Point) As Integer
  '若找到多边形,则返回1
  '判断是否有顶点被选中
  If SelectVertex(pt) Then
    SelectPolygon = 1
    Exit Function
  End If
  
  '或选中一个多边形
  m_selPoly = -1
  m_selVertex = -1
  For i = 0 To UBound(m_polys) - 1
    If m_polys(i).IsPointIn(pt) Then
      m_selPoly = i
      Exit For
    End If
  Next i

  Refresh
  SelectPolygon = 0
End Function

'移动选中的顶点到pt处
Sub MoveVertex(pt As MapObjects2.Point)
  If m_selPoly >= 0 And m_selVertex >= 0 Then
    m_grid.SnapPoint pt, m_map
    Set Poly = m_polys(m_selPoly)
    Dim pts As Points
    Set pts = Poly.Parts(0)
    pts.Set m_selVertex, pt
    
    '若选中的顶点是多边形顶点
    '则移动它的同时也要移动最后一个顶点
    '以保证多边形的闭合
    If m_selVertex = 0 Then pts.Set pts.Count - 1, pt
    '若选中的是多边形的最后一个顶点，也要同时移动第一个
    If m_selVertex = pts.Count - 1 Then pts.Set 0, pt
    Refresh
  End If
End Sub

'向编辑图层中添加一个多边形
Sub AddPolygon()
  Dim Poly As MapObjects2.Polygon
  Set Poly = m_map.TrackPolygon
  
  '跟踪输入的多边形，并加入多边形序列中
  If Not Poly Is Nothing Then
    numPolys = UBound(m_polys)
    ReDim Preserve m_polys(numPolys + 1)
    Set m_polys(numPolys) = m_grid.SnapPolygon(Poly, m_map)
    
    '选中新的多边形
    m_selPoly = numPolys
    m_selVertex = -1
    
    Refresh
  End If
End Sub

'将多边形定点显示为一个小矩形
Function VertexHandle() As MapObjects2.Rectangle
  If m_selVertex = -1 Then Exit Function
  
  Set pt = m_polys(m_selPoly).Parts(0).Item(m_selVertex)
  r = m_map.ToMapDistance(60)
  Dim rect As New MapObjects2.Rectangle
  rect.Left = pt.x - r
  rect.Right = pt.x + r
  rect.Top = pt.y + r
  rect.Bottom = pt.y - r
  
  Set VertexHandle = rect
End Function

'类初始化代码
Private Sub Class_Initialize()
  ReDim m_polys(0)
  PolyColor = moCyan
  m_selPoly = -1
  m_selVertext = -1
End Sub