mod_editoperations.bas

ArcEngine 这是基于AE组件的源代码

Attribute VB_Name = "Mod_EditOperations"

Option Explicit

Private m_pEditFeature As iFeature
Private m_pPoint As IPoint
Private m_pAnchorPoint As IPoint
Private m_pFeedback As IDisplayFeedback
Private m_bInUse As Boolean
Private m_pPointCollection As IPointCollection

' Starts an editing session on the currently selected layer
Public Sub StartEditing()
  Dim pWorkspaceEdit As IWorkspaceEdit
  Dim pFeatureLayer As IFeatureLayer
  Dim pDataset As IDataset
  
  On Error GoTo StartEditing_err
  
  ' Check edit conditions before allowing edit to start
  If m_pCurrentLayer Is Nothing Then Exit Sub
  If Not TypeOf m_pCurrentLayer Is IGeoFeatureLayer Then Exit Sub
  Set pFeatureLayer = m_pCurrentLayer
  Set pDataset = pFeatureLayer.FeatureClass
  If pDataset Is Nothing Then Exit Sub
  
  ' Start editing, making sure that undo/redo are enabled
  Set pWorkspaceEdit = pDataset.Workspace
  If Not pWorkspaceEdit.IsBeingEdited Then
    pWorkspaceEdit.StartEditing True
    pWorkspaceEdit.EnableUndoRedo
  End If
  
  Exit Sub
StartEditing_err:
  MsgBox Err.Description
End Sub

' Completes an editing session on the currently selected layer
Public Sub StopEditing()
  Dim pFeatureLayer As IFeatureLayer
  Dim pDataset As IDataset
  Dim pWorkspaceEdit As IWorkspaceEdit
  Dim pActiveView As IActiveView
  Dim bHasEdits As Boolean
  Dim bSave As Boolean
  
  On Error GoTo StopEditing_err
  
  ' Check edit conditions before allowing edit to stop
  If m_pCurrentLayer Is Nothing Then Exit Sub
  Set pFeatureLayer = m_pCurrentLayer
  If pFeatureLayer.FeatureClass Is Nothing Then Exit Sub
  Set pDataset = pFeatureLayer.FeatureClass
  If pDataset Is Nothing Then Exit Sub
   
  ' If the current document has been edited then prompt the user to save changes
  Set pWorkspaceEdit = pDataset.Workspace
  If pWorkspaceEdit.IsBeingEdited Then
    pWorkspaceEdit.HasEdits bHasEdits
    If bHasEdits = True Then
      If vbYes = MsgBox("是否保存当前编辑?", vbQuestion + vbYesNoCancel) Then
        bSave = True
      End If
    End If
    pWorkspaceEdit.StopEditing bSave
  End If
 
  m_pMap.ClearSelection
  Set pActiveView = m_pMap
  pActiveView.refresh
  
  Exit Sub
StopEditing_err:
  MsgBox Err.Description
End Sub

' Returns true if the startEdit button has been pressed
Public Function InEdit() As Boolean
  Dim pFeatureLayer As IFeatureLayer
  Dim pDataset As IDataset
  Dim pWorkspaceEdit As IWorkspaceEdit
  
  InEdit = False
  
  On Error GoTo StopEditing_err
  
  ' Check edit conditions before allowing edit to stop
  If m_pCurrentLayer Is Nothing Then Exit Function
  Set pFeatureLayer = m_pCurrentLayer
  If pFeatureLayer.FeatureClass Is Nothing Then Exit Function
  Set pDataset = pFeatureLayer.FeatureClass
  If pDataset Is Nothing Then Exit Function
  Set pWorkspaceEdit = pDataset.Workspace
  If pWorkspaceEdit.IsBeingEdited Then InEdit = True
  Exit Function
StopEditing_err:
  MsgBox Err.Description
End Function

' Starts a new sketch or adds a point to an existing one, of a type
' determined by the current layer selected in the layers combo.
Public Sub SketchMouseDown(x As Long, y As Long)
  Dim pPoint As IPoint
  Dim pActiveView As IActiveView
  Dim pPolyFeed As INewPolygonFeedback
  Dim pLineFeed As INewLineFeedback
  Dim pFeatureLayer As IFeatureLayer
  
  On Error GoTo BeginSketch_err
  
  ' Can only sketch on GeoFeature layers
  If m_pCurrentLayer Is Nothing Then Exit Sub
  If Not TypeOf m_pCurrentLayer Is IGeoFeatureLayer Then Exit Sub

  ' Get the mouse down point in map coordinates
  Set pFeatureLayer = m_pCurrentLayer
  If pFeatureLayer.FeatureClass Is Nothing Then Exit Sub
  Set pActiveView = m_pMap
  Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
  
  ' If this is a fresh sketch then create an appropriate feedback object,
  ' otherwise extent the existing feedback
  If Not m_bInUse Then
    Select Case pFeatureLayer.FeatureClass.ShapeType
      Case esriGeometryPoint
        CreateFeature pPoint
      Case esriGeometryMultipoint
        m_bInUse = True
        Set m_pFeedback = New NewMultiPointFeedback
        Dim pMPFeed As INewMultiPointFeedback
        Set pMPFeed = m_pFeedback
        Set m_pPointCollection = New Multipoint
        pMPFeed.Start m_pPointCollection, pPoint
      Case esriGeometryPolyline
        m_bInUse = True
        Set m_pFeedback = New NewLineFeedback
        Set pLineFeed = m_pFeedback
        pLineFeed.Start pPoint
      Case esriGeometryPolygon
        m_bInUse = True
        Set m_pFeedback = New NewPolygonFeedback
        Set pPolyFeed = m_pFeedback
        pPolyFeed.Start pPoint
    End Select
    If Not m_pFeedback Is Nothing Then Set m_pFeedback.Display = pActiveView.ScreenDisplay
  Else
    If TypeOf m_pFeedback Is INewMultiPointFeedback Then
      m_pPointCollection.AddPoint pPoint
    ElseIf TypeOf m_pFeedback Is INewLineFeedback Then
      Set pLineFeed = m_pFeedback
      pLineFeed.AddPoint pPoint
    ElseIf TypeOf m_pFeedback Is INewPolygonFeedback Then
      Set pPolyFeed = m_pFeedback
      pPolyFeed.AddPoint pPoint
    End If
  End If

  Exit Sub
BeginSketch_err:
  MsgBox Err.Description
End Sub

Public Sub SketchMouseMove(ByVal x As Long, ByVal y As Long)
  If Not m_bInUse Or m_pFeedback Is Nothing Then Exit Sub
  
  ' Move the feedback envelope and store the current mouse position
  Dim pActiveView As IActiveView
  Set pActiveView = m_pMap
  m_pFeedback.MoveTo pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
  Set m_pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)

End Sub

' Use the feedback object's geometry to create a new feature
Public Sub EndSketch()
  Dim pGeom As IGeometry
  Dim pPointCollection As IPointCollection
  
  On Error GoTo EndSketch_err
  
  ' Create a new feature if possible
  If TypeOf m_pFeedback Is INewMultiPointFeedback Then
    Dim pMPFeed As INewMultiPointFeedback
    Set pMPFeed = m_pFeedback
    pMPFeed.Stop
    Set pGeom = m_pPointCollection
  ElseIf TypeOf m_pFeedback Is INewLineFeedback Then
    Dim pLineFeed As INewLineFeedback
    Set pLineFeed = m_pFeedback
    Dim pPolyline As IPolyline
    pLineFeed.AddPoint m_pPoint
    Set pPolyline = pLineFeed.Stop
    Set pPointCollection = pPolyline
    If pPointCollection.PointCount < 2 Then
      MsgBox "You must have at least two vertices in a line.", vbExclamation + vbOKOnly, "Bad Line Geometry"
    Else
      Set pGeom = pPointCollection
    End If
  ElseIf TypeOf m_pFeedback Is INewPolygonFeedback Then
    Dim pPolyFeed As INewPolygonFeedback
    Set pPolyFeed = m_pFeedback
    pPolyFeed.AddPoint m_pPoint
    Dim pPolygon As IPolygon
    Set pPolygon = pPolyFeed.Stop
    If Not pPolygon Is Nothing Then
      Set pPointCollection = pPolygon
      If pPointCollection.PointCount < 3 Then
        MsgBox "You must have at least three vertices in a polygon.", vbExclamation + vbOKOnly, "Bad Polygon Geometry"
      Else
        Set pGeom = pPointCollection
      End If
    End If
  End If

  CreateFeature pGeom
  Set m_pFeedback = Nothing
  m_bInUse = False
  
  Exit Sub
EndSketch_err:
  MsgBox Err.Description
End Sub

' Searches the map for features at the given point in the current layer
' and selects them
Public Sub SelectMouseDown(x As Long, y As Long)
  Dim pFeatureLayer As IFeatureLayer
  Dim pFeatureClass As IFeatureClass
  Dim pSpatialFilter As ISpatialFilter
  Dim pFilter As IQueryFilter
  Dim pActiveView As IActiveView
  Dim pGeometry As IGeometry
  Dim pPoint As IPoint
  
  On Error GoTo SelectMouseDown_err
  
  If m_pCurrentLayer Is Nothing Then Exit Sub
  If Not TypeOf m_pCurrentLayer Is IGeoFeatureLayer Then Exit Sub
  
  ' Get the feature layer and class of the current layer
  Set pFeatureLayer = m_pCurrentLayer
  Set pFeatureClass = pFeatureLayer.FeatureClass
  If pFeatureClass Is Nothing Then Exit Sub
  
  ' Get the mouse down position in map coordinates
  Set pActiveView = m_pMap
  Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
  Set pGeometry = pPoint
  
  ' Use a four pixel buffer around the cursor for feature search
  Dim length As Double
  length = ConvertPixelsToMapUnits(m_pMap, 4)
  Dim pTopo As ITopologicalOperator
  Set pTopo = pGeometry
  Dim pBuffer As IGeometry
  Set pBuffer = pTopo.Buffer(length)
  Set pGeometry = pBuffer.Envelope
  
  ' Set up a Filter specific to this layer
  Set pSpatialFilter = New SpatialFilter
  Set pSpatialFilter.Geometry = pGeometry
  Select Case pFeatureClass.ShapeType
    Case esriGeometryPoint
      pSpatialFilter.SpatialRel = esriSpatialRelContains
    Case esriGeometryPolyline
      pSpatialFilter.SpatialRel = esriSpatialRelCrosses
    Case esriGeometryPolygon
      pSpatialFilter.SpatialRel = esriSpatialRelIntersects
  End Select
  pSpatialFilter.GeometryField = pFeatureClass.ShapeFieldName
  Set pFilter = pSpatialFilter
 
  ' Do the search
  Dim pCursor As IFeatureCursor
  Set pCursor = pFeatureLayer.Search(pFilter, False)

  ' and select the features on the map
  Dim pFeature As iFeature
  Set pFeature = pCursor.NextFeature
  While Not pFeature Is Nothing
    m_pMap.SelectFeature m_pCurrentLayer, pFeature
    Set pFeature = pCursor.NextFeature
  Wend
  pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
  
  Exit Sub
SelectMouseDown_err:
  MsgBox Err.Description
End Sub

' Searches for features under the coordinate provided and starts an edit
' operation on the first one found.
Public Function EditFeature(x As Long, y As Long) As Boolean
  Dim pPointMove As IMovePointFeedback
  Dim pLineMove As ILineMovePointFeedback
  Dim pPolyMove As IPolygonMovePointFeedback
  Dim pGeomColn As IGeometryCollection
  Dim pPointColn As IPointCollection
  Dim pObjectClass As IObjectClass
  Dim pActiveView As IActiveView
  Dim pFeature As iFeature
  Dim pGeom As IGeometry
  Dim pPath As IPath
  Dim pHitPoint As IPoint
  Dim pPoint As IPoint
  Dim hitDist As Double
  Dim tol As Double
  Dim vertexIndex As Long
  Dim numVertices As Long
  Dim partIndex As Long
  Dim vertex As Boolean
 
  On Error GoTo Edit_err
 
  ' Use the first feature in the selection
  SelectMouseDown x, y
  Dim pSelected As IEnumFeature
  Set pSelected = m_pMap.FeatureSelection
  Set pFeature = pSelected.Next
  If (pFeature Is Nothing) Then Exit Function
  
  Set pActiveView = m_pMap
  Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
  
  ' Tolerance in pixels for line hits
  tol = ConvertPixelsToMapUnits(m_pMap, 4)
  
  ' The feedback action / edit action depends on the geometry type
  ' and the location of point within the geometry
  Set pGeom = pFeature.Shape
  Set pObjectClass = pFeature.Class
  Set m_pEditFeature = pFeature
  
  Select Case pGeom.GeometryType
  
    Case esriGeometryPoint
      Set m_pFeedback = New MovePointFeedback
      Set m_pFeedback.Display = pActiveView.ScreenDisplay
      Set pPointMove = m_pFeedback
      pPointMove.Start pGeom, pPoint
      
    Case esriGeometryPolyline
      If TestGeometryHit(tol, pPoint, pFeature, pHitPoint, hitDist, partIndex, vertexIndex, vertex) Then
        If Not vertex Then
          ' Get the path, add a point to it and vertex edit that newly added point
          Set pGeomColn = pGeom
          Set pPath = pGeomColn.Geometry(partIndex)
          Set pPointColn = pPath
          numVertices = pPointColn.PointCount
          
          If vertexIndex = 0 Then
            pPointColn.AddPoint pPoint, 1
          Else