editlayer.cls

自己编写的基于VB+MO的图形元素编辑代码

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 newPoly As New MapObjects2.Polygon
Dim m_map As MapObjects2.map
Dim m_poly As MapObjects2.Polygon
Dim m_line As MapObjects2.line
Dim m_selPoly As Boolean
Dim m_selLine As Boolean
Dim m_selVertex As Integer
Dim pts As New MapObjects2.points
Dim ppts As MapObjects2.points
Dim m_iLyr As Integer

' polygon array
'Dim m_lines() As MapObjects2.Line
'Dim m_selLine As Integer
' selection
'Dim m_grid As SnappingGrid

Sub Initialize(map As MapObjects2.map, poly As MapObjects2.Polygon, index As Integer) ', grid As SnappingGrid)
  
  Set m_map = map
  m_iLyr = index
  Set m_poly = poly
'  Set pts = m_poly.Parts(0)
  m_selPoly = True
'  Set m_grid = grid
End Sub

''*****************
Sub InitializeLine(map As MapObjects2.map, line As MapObjects2.line, index As Integer)   ''初始化线
    Set m_map = map
    m_iLyr = index
    Set m_line = line
    m_selLine = True
End Sub


Private Sub Class_Initialize()
   PolyColor = moCyan
  
   m_selVertext = -1
  
  ' ReDim m_lines(0)
  ' m_selLine = -1
End Sub
'删除所选择的点或多边形
Sub DeleteSelection()
   
  ' delete the selected vertex, if any
  '如果点被选中则删除点
  If m_selVertex >= 0 Then
'    Set pts = m_poly.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
  
  '如果没有点被选中，则删除所选择的多边形
  ' delete selected polygon
  If m_selPoly = True Then
   Dim ans
   ans = MsgBox("确认删除该图图元吗？", vbYesNo + vbExclamation, "删除提示")
   If ans = 6 Then
     Set m_poly = Nothing
     m_selPoly = False
   Else
    Exit Sub
   End If
    Refresh
  End If
End Sub

'给多边形及极点赋颜色
Sub Draw()
 
    If m_selPoly = True Then
        Dim sym As New MapObjects2.Symbol
        Dim p As New MapObjects2.Point
        sym.Color = moYellow
        sym.Style = moGrayFill
        m_map.DrawShape m_poly, sym
        
        sym.SymbolType = moPointSymbol
        sym.Size = 5
        sym.Color = moBlue
        
        For Each p In pts
            m_map.DrawShape p, sym
        Next p
        
        sym.Color = moRed
        If m_selVertex >= 0 Then m_map.DrawShape pts(m_selVertex), sym
     
     End If
 End Sub

Sub Refresh()
  m_map.TrackingLayer.Refresh True
End Sub
'选择顶点
Function SelectVertex(pt As MapObjects2.Point) As Boolean
  Dim v As New MapObjects2.Point
  Dim tol As Double
  tol = m_map.ToMapDistance(60) '设置捕获距离
  
  If m_map.Layers(m_iLyr).shapeType = moShapeTypePolygon Or moShapeTypeRectangle Then
    If m_selPoly = True Then
        m_selVertex = -1
        For Each ppts In m_poly.Parts
            For Each v In ppts
                m_selVertex = m_selVertex + 1
                If v.DistanceTo(pt) < tol Then
                    Refresh
                    SelectVertex = True
                    Set pts = ppts
                    Exit Function
                End If
            Next v
        Next ppts
    End If
  ElseIf m_map.Layers(m_iLyr).shapeType = moShapeTypeLine Then
    If m_selLine = True Then
        m_selVertex = -1
        For Each ppts In m_line.Parts
            For Each v In ppts
                m_selVertex = m_selVertex + 1
                If v.DistanceTo(pt) < tol Then
                    Refresh
                    SelectVertex = True
                    Set pts = ppts
                    Exit Function
                End If
            Next v
        Next ppts
    End If
  End If
  
  SelectVertex = False
End Function

Sub SplitPolygon(pt As MapObjects2.Point)
  Dim tol As Double
  If m_selPoly = False Then Exit Sub
  tol = m_map.ToMapDistance(60)
  pts.Add pts(0)
  For i = 1 To pts.Count - 1
    dist = pt.DistanceToSegment(pts(i - 1), pts(i))
    If dist <= tol Then
      pts.Insert i, pt  ' insert the point
      m_selVertex = i   ' select the vertex
      Set newPoly = m_poly
      frmmain.mnuFile_Save.Enabled = True
      frmmain.Toolbar1.Buttons("save").Enabled = True
      Refresh
      Exit Sub
    End If
  Next i
End Sub

Sub MoveVertex(pt As MapObjects2.Point)
  ' moves the selected vertex
    If m_map.Layers(m_iLyr).shapeType = moShapeTypePolygon Or moShapeTypeRectangle Then
        If m_selPoly = True And m_selVertex >= 0 Then
            pts.Set m_selVertex, pt
            Set newPoly = m_poly
            Refresh
        End If
    ElseIf m_map.Layers(m_iLyr).shapeType = moShapeTypeLine Then
        If m_selLine = True And m_selVertex >= 0 Then
            pts.Set m_selVertex, pt
            Refresh
        End If
    End If
End Sub

Function VertexHandle(i As Integer) As MapObjects2.Rectangle
  Dim pt As MapObjects2.Point
  Dim pts1 As MapObjects2.points
  If m_selVertex = -1 Then Exit Function
'  MsgBox m_poly.Parts.Count
  Set pts1 = m_poly.Parts(i)
  Set pt = pts1.Item(m_selVertex)
'  Set pt = m_poly.Parts(i).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