mod_editoperations.bas

AO的开发平台

            pPointColn.AddPoint pPoint, , vertexIndex
          End If
          ' Reset the index pointer to the new index
          TestGeometryHit tol, pPoint, pFeature, pHitPoint, hitDist, partIndex, vertexIndex, vertex
        End If
        Set m_pFeedback = New LineMovePointFeedback
        Set m_pFeedback.Display = pActiveView.ScreenDisplay
        Set pLineMove = m_pFeedback
        pLineMove.Start pGeom, vertexIndex, pPoint
      Else
        Exit Function
      End If
      
    Case esriGeometryPolygon
      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
          
          ' Reset the index pointer to the new index
          If vertexIndex = 0 Then
            pPointColn.AddPoint pPoint, 1
          Else
            pPointColn.AddPoint pPoint, , vertexIndex
          End If
          
          ' Reset the index pointer to the new index
          TestGeometryHit tol, pPoint, pFeature, pHitPoint, hitDist, partIndex, vertexIndex, vertex
        End If
        Set m_pFeedback = New PolygonMovePointFeedback
        Set m_pFeedback.Display = pActiveView.ScreenDisplay
        Set pPolyMove = m_pFeedback
        pPolyMove.Start pGeom, vertexIndex, pPoint
      Else
        Exit Function
      End If
      
  End Select

  EditFeature = True

  Exit Function
Edit_err:
  MsgBox Err.Description
End Function

' Moves the edit feedback object along with the mouse.
Public Sub FtrEditMouseMove(ByVal x As Long, ByVal y As Long)
  Dim pActiveView As IActiveView
  Dim pPoint As IPoint
  
  On Error GoTo FtrEditMouseMove_err
  
  If m_pFeedback Is Nothing Then Exit Sub
  
  Set pActiveView = m_pMap
  Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
  m_pFeedback.MoveTo pPoint

  Exit Sub
FtrEditMouseMove_err:
  MsgBox Err.Description
End Sub

' Uses the feedback object's geometry to reset the geometry on the feature
' being edited.
Public Sub EndFtrEdit(ByVal x As Long, ByVal y As Long)
  Dim pPointMove As IMovePointFeedback
  Dim pLineMove As ILineMovePointFeedback
  Dim pPolyMove As IPolygonMovePointFeedback
  Dim pActiveView As IActiveView
  Dim pGeometry As IGeometry
  Dim pPoint As IPoint
  
  On Error GoTo EndFtrEdit_err
  
  ' If no feedback no edit
  If m_pFeedback Is Nothing Then Exit Sub
  
  Set pActiveView = m_pMap
  Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)

  If TypeOf m_pFeedback Is IMovePointFeedback Then
    Set pPointMove = m_pFeedback
    Set pGeometry = pPointMove.Stop
    UpdateFeature m_pEditFeature, pGeometry
  ElseIf TypeOf m_pFeedback Is ILineMovePointFeedback Then
    Set pLineMove = m_pFeedback
    Set pGeometry = pLineMove.Stop
    UpdateFeature m_pEditFeature, pGeometry
  ElseIf TypeOf m_pFeedback Is IPolygonMovePointFeedback Then
    Set pPolyMove = m_pFeedback
    Set pGeometry = pPolyMove.Stop
    UpdateFeature m_pEditFeature, pGeometry
  End If

  Set m_pFeedback = Nothing
  pActiveView.refresh

  Exit Sub
EndFtrEdit_err:
  MsgBox Err.Description
End Sub

' Deletes all features selected on the current layer
Public Sub DeleteSelectedFeatures()
  Dim pFeatureCursor As IFeatureCursor
  Dim pWorkspaceEdit As IWorkspaceEdit
  Dim pFeature As iFeature
  Dim pActiveView As IActiveView
  
  On Error GoTo DeleteSelectedFeatures_err

  If m_pCurrentLayer Is Nothing Then Exit Sub
          
  ' If there are no features currently selected then nothing to do
  Set pFeatureCursor = GetSelectedFeatures
  If pFeatureCursor Is Nothing Then Exit Sub

  m_pMap.ClearSelection

  ' Loop over the selected features deleting each in turn
  Set pWorkspaceEdit = GetWorkspaceEdit
  pWorkspaceEdit.StartEditOperation
  Set pFeature = pFeatureCursor.NextFeature
  While Not pFeature Is Nothing
    pFeature.Delete
    Set pFeature = pFeatureCursor.NextFeature
  Wend
  pWorkspaceEdit.StopEditOperation
  
  Set pActiveView = m_pMap
  pActiveView.refresh
  
  Exit Sub
DeleteSelectedFeatures_err:
  MsgBox Err.Description
End Sub

Public Sub UndoEdit()
  Dim pFeatureLayer As IFeatureLayer
  Dim pWorkspaceEdit As IWorkspaceEdit
  Dim pDataset As IDataset
  Dim pActiveView As IActiveView
  Dim bHasUndos As Boolean
  
  On Error GoTo UndoEdit_err
  
  ' Check that editing is possible
  If m_pCurrentLayer Is Nothing Then Exit Sub
  Set pFeatureLayer = m_pCurrentLayer
  Set pDataset = pFeatureLayer.FeatureClass
  If pDataset Is Nothing Then Exit Sub

  ' If edits have taken place then roll-back the last one
  Set pWorkspaceEdit = pDataset.Workspace
  pWorkspaceEdit.HasUndos bHasUndos
  If bHasUndos Then
     pWorkspaceEdit.UndoEditOperation
  End If
  Set pActiveView = m_pMap
  pActiveView.refresh
  frmMDIMap.MapControl.refresh esriViewGeography
  Exit Sub
UndoEdit_err:
  MsgBox Err.Description
End Sub
Public Sub RedoEdit()
  Dim pFeatureLayer As IFeatureLayer
  Dim pWorkspaceEdit As IWorkspaceEdit
  Dim pDataset As IDataset
  Dim pActiveView As IActiveView
  Dim bHasRedos As Boolean
  
  On Error GoTo UndoEdit_err
  ' Check that editing is possible
  If m_pCurrentLayer Is Nothing Then Exit Sub
  Set pFeatureLayer = m_pCurrentLayer
  Set pDataset = pFeatureLayer.FeatureClass
  If pDataset Is Nothing Then Exit Sub

  ' If edits have taken place then roll-back the last one
  Set pWorkspaceEdit = pDataset.Workspace
  pWorkspaceEdit.HasRedos bHasRedos
  If bHasRedos Then pWorkspaceEdit.RedoEditOperation
  Set pActiveView = m_pMap
  pActiveView.refresh
  Exit Sub
UndoEdit_err:
  MsgBox Err.Description
End Sub

Private Sub CreateFeature(pGeom As IGeometry)
  Dim pWorkspaceEdit As IWorkspaceEdit
  Dim pFeatureLayer As IFeatureLayer
  Dim pFeatureClass As IFeatureClass
  Dim pFeature As iFeature
  
  On Error GoTo CreateFeature_err
  
  If pGeom Is Nothing Then Exit Sub
  If m_pCurrentLayer Is Nothing Then Exit Sub
  
  ' Create the feature
  Set pWorkspaceEdit = GetWorkspaceEdit
  Set pFeatureLayer = m_pCurrentLayer
  Set pFeatureClass = pFeatureLayer.FeatureClass
  pWorkspaceEdit.StartEditOperation
  Set pFeature = pFeatureClass.CreateFeature
  Set pFeature.Shape = pGeom
  pFeature.Store
  pWorkspaceEdit.StopEditOperation
  
  ' Select the feature that's been created
  m_pMap.SelectFeature m_pCurrentLayer, pFeature

  ' Refresh the relevant area of the active view
  Dim pActiveView As IActiveView
  Set pActiveView = m_pMap
  If pGeom.GeometryType = esriGeometryPoint Then
    Dim length As Double
    length = ConvertPixelsToMapUnits(m_pMap, 30)
    Dim pTopo As ITopologicalOperator
    Set pTopo = pGeom
    Dim pBuffer As IGeometry
    Set pBuffer = pTopo.Buffer(length)
    pActiveView.PartialRefresh esriDPGeography Or esriDPSelection, m_pCurrentLayer, pBuffer.Envelope
  Else
    pActiveView.PartialRefresh esriDPGeography Or esriDPSelection, m_pCurrentLayer, pGeom.Envelope
  End If
  
  Exit Sub
CreateFeature_err:
  MsgBox Err.Description
End Sub

' Uses the ratio of the size of the map in pixels to map units to do the conversion
Private Function ConvertPixelsToMapUnits(pActiveView As IActiveView, pixelUnits As Double) As Double
  Dim realWorldDisplayExtent As Double
  Dim pixelExtent As Integer
  Dim sizeOfOnePixel As Double

  pixelExtent = pActiveView.ScreenDisplay.DisplayTransformation.DeviceFrame.Right - pActiveView.ScreenDisplay.DisplayTransformation.DeviceFrame.Left
  realWorldDisplayExtent = pActiveView.ScreenDisplay.DisplayTransformation.VisibleBounds.Width
  sizeOfOnePixel = realWorldDisplayExtent / pixelExtent
  ConvertPixelsToMapUnits = pixelUnits * sizeOfOnePixel
End Function

' Gets the Workspace edit object from the current layer, if possible
Private Function GetWorkspaceEdit() As IWorkspaceEdit
  Dim pFeatureLayer As IFeatureLayer
  Dim pFeatureClass As IFeatureClass
  Dim pDataset As IDataset
  
  If m_pCurrentLayer Is Nothing Then Exit Function
  
  Set pFeatureLayer = m_pCurrentLayer
  Set pFeatureClass = pFeatureLayer.FeatureClass
  Set pDataset = pFeatureClass
  If pDataset Is Nothing Then Exit Function
  Set GetWorkspaceEdit = pDataset.Workspace
End Function

' Returns a cursor to the features selected on the current layer
Private Function GetSelectedFeatures() As IFeatureCursor
  Dim pFeatSel As IFeatureSelection
  Dim pSelectionSet As ISelectionSet
  Dim pCursor As ICursor
  
  If m_pCurrentLayer Is Nothing Then Exit Function
  
  ' If there are no features selected let the user know
  Set pFeatSel = m_pCurrentLayer
  Set pSelectionSet = pFeatSel.SelectionSet
  If pSelectionSet.count = 0 Then
    MsgBox "No features are selected in the '" & m_pCurrentLayer.name & "' layer", vbOKOnly
    Exit Function
  End If
  
  ' Otherwise get all of the features back from the selection
  pSelectionSet.Search Nothing, False, pCursor
  Set GetSelectedFeatures = pCursor
  
End Function

' Function returns true if a feature's shape is hit and further defines
' if a vertex lies within the tolorance
Private Function TestGeometryHit(tolerance As Double, pPoint As IPoint, _
                                 ByVal pFeature As iFeature, pHitPoint As IPoint, _
                                 hitDist As Double, partIndex As Long, _
                                 vertexIndex As Long, vertexHit As Boolean) As Boolean
  Dim pGeom As IGeometry
  Dim pHitTest As IHitTest
  
  On Error GoTo TestGeometryHit_err
  
  Set pGeom = pFeature.Shape
    
  Set pHitTest = pGeom
  Set pHitPoint = New Point
  ' First check if a vertex was hit
  If pHitTest.HitTest(pPoint, tolerance, esriGeometryPartVertex, pHitPoint, _
                      hitDist, partIndex, vertexIndex, True) Then
    TestGeometryHit = True
    vertexHit = True
  Else
    ' Secondly check if a boundary was hit
    If pHitTest.HitTest(pPoint, tolerance, esriGeometryPartBoundary, pHitPoint, _
                        hitDist, partIndex, vertexIndex, True) Then
      TestGeometryHit = True
      vertexHit = False
    End If
  End If

  Exit Function
TestGeometryHit_err:
  MsgBox Err.Description
End Function

Private Sub UpdateFeature(pFeature As iFeature, pGeometry As IGeometry)
  On Error GoTo UpdateFeature_err

  Dim pDataset As IDataset
  Dim pWorkspaceEdit As IWorkspaceEdit
  
  ' Make sure we are actually editing this layer. If not give a warning.
  Set pDataset = pFeature.Class
  Set pWorkspaceEdit = pDataset.Workspace
  If Not pWorkspaceEdit.IsBeingEdited Then
    Beep
    MsgBox "This feature is in a layer not in edit mode." & vbCrLf & "Edit cannot be made.   Start edit and try again.", vbExclamation + vbOKOnly, "Warning"
    Exit Sub
  End If
  
  ' If all tests succeed allow feature edits to be saved
  pWorkspaceEdit.StartEditOperation
  Set pFeature.Shape = pGeometry
  pFeature.Store
  pWorkspaceEdit.StopEditOperation

  Exit Sub
UpdateFeature_err:
  MsgBox Err.Description
End Sub