UpdateByTopology
clsUpdateFeatures.cls
' Copyright 1995-2004 ESRI
' All rights reserved under the copyright laws of the United States.
' You may freely redistribute and use this sample code, with or without modification.
' Disclaimer: THE SAMPLE CODE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED
' WARRANTIES, INCLUDING THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
' FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ESRI OR
' CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
' OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
' SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
' INTERRUPTION) SUSTAINED BY YOU OR A THIRD PARTY, HOWEVER CAUSED AND ON ANY
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ARISING IN ANY
' WAY OUT OF THE USE OF THIS SAMPLE CODE, EVEN IF ADVISED OF THE POSSIBILITY OF
' SUCH DAMAGE.
' For additional information contact: Environmental Systems Research Institute, Inc.
' Attn: Contracts Dept.
' 380 New York Street
' Redlands, California, U.S.A. 92373
' Email: contracts@esri.com
Option Explicit
Option Base 0
Implements ICommand
Private m_pEditor As esriEditor.IEditor
Private m_pMXApp As esriArcMapUI.IMxApplication
Private m_pApp As IApplication
Private m_pTopoExt As esriEditorExt.ITopologyExtension
Private m_pSurveyExt As esriSystem.IExtension
Private m_TopoFunctions As TopologyFunctions
Private m_AvailableMethod As enumTransformationMethod
Private m_bExit As Boolean
Private m_pTransF As esriGeometry.IAffineTransformation2D3
Private m_pTopoG As esriGeoDatabase.ITopologyGraph
Private m_pTopoSpatRef As esriGeometry.ISpatialReference
Private WithEvents m_pUpdateFrm As Form
Private WithEvents m_OK As CommandButton
Private WithEvents m_Cancel As CommandButton
Private Sub Class_Initialize()
Set m_pUpdateFrm = frmUpdateMethod
Set m_OK = frmUpdateMethod.cmdOK
Set m_Cancel = frmUpdateMethod.cmdCancel
Set m_TopoFunctions = New TopologyFunctions
End Sub
Private Property Get ICommand_Bitmap() As esriSystem.OLE_HANDLE
End Property
Private Property Get ICommand_Caption() As String
ICommand_Caption = "Update Features in Topology..."
End Property
Private Property Get ICommand_Category() As String
ICommand_Category = "Developer Samples Survey Analyst"
End Property
Private Property Get ICommand_Checked() As Boolean
ICommand_Checked = False
End Property
Private Property Get ICommand_Enabled() As Boolean
Dim pTopo As esriGeoDatabase.ITopology, pMapTopol As esriEditorExt.IMapTopology, pTopoG As esriGeoDatabase.ITopologyGraph
ICommand_Enabled = False
If m_pTopoExt Is Nothing Then Exit Property
If m_pSurveyExt Is Nothing Then Exit Property
If TypeOf m_pTopoExt.CurrentTopology Is esriEditorExt.IMapTopology Then
Set pMapTopol = m_pTopoExt.MapTopology
Set pTopoG = pMapTopol.Cache
Else
Set pTopo = m_pTopoExt.CurrentTopology
Set pTopoG = pTopo.Cache
End If
'Check for a topology graph
If pTopoG Is Nothing Then Exit Property
'Check for an feature selection
If m_pEditor.SelectionCount > 0 Then _
ICommand_Enabled = m_pEditor.EditState = esriStateEditing
End Property
Private Property Get ICommand_HelpContextID() As Long
End Property
Private Property Get ICommand_HelpFile() As String
End Property
Private Property Get ICommand_Message() As String
ICommand_Message = "Update selected features in a topology based on survey points"
End Property
Private Property Get ICommand_Name() As String
ICommand_Name = "Update Features in Topology"
End Property
Private Sub ICommand_OnClick()
Dim pMXDoc As esriArcMapUI.IMxDocument, iErr As Integer
Dim pSDS As esriSurveyExt.ISurveyDataset, pSAFunc As New SurveyAnalystFunctions
Dim pEnumTopoEdg As esriGeoDatabase.IEnumTopologyEdge, pInvalArea As esriGeoDatabase.IInvalidArea, pSnapPoints As esriGeometry.IMultipoint
Dim pLinkCache As esriSurveyExt.IFeatureSurveyLinkCache, pSegColl As esriGeometry.ISegmentCollection
Dim pInvalid As esriGeometry.IEnvelope, dFromErr As Double, dToError As Double
Dim pMapLU As esriGeometry.ILinearUnit, sUnit As String, pEdProps As esriEditor.IEditProperties
If m_pEditor.SelectionCount = 0 Then
MsgBox "You need to select features."
Exit Sub
End If
On Error GoTo handler
Set m_pTopoG = m_TopoFunctions.GetTopologyGraph(m_pTopoExt)
Set m_pTopoSpatRef = m_TopoFunctions.GetTopologySpatRef(m_pTopoExt)
m_TopoFunctions.BuildTopologyForFeatureSelection m_pEditor.EditSelection, m_pTopoG, False
Set pMXDoc = m_pApp.Document
Set pSDS = pSAFunc.GetSurveyDatasetFromMapLayers(pMXDoc.FocusMap.Layers)
If pSDS Is Nothing Then
MsgBox "Add a survey layer to the map."
Exit Sub
End If
Set pEnumTopoEdg = m_TopoFunctions.SelectTopoEdgesFromFeatures(m_pEditor.EditSelection, m_pTopoExt, m_pTopoG)
Set pInvalArea = New InvalidArea
Set pInvalArea.Display = m_pEditor.Display
pInvalArea.Add m_pEditor.EditSelection
Set pLinkCache = pSDS
Set pSnapPoints = pSAFunc.GetSnappedVertices(m_pEditor.EditSelection, pLinkCache, m_pEditor.Map.SpatialReference, m_pTopoSpatRef)
Set pSegColl = _
m_TopoFunctions.GetLinkInfoBySelectedTopoElements(m_pTopoG, pLinkCache)
If pSegColl.SegmentCount > 2 Then
m_AvailableMethod = Affine
Else
m_AvailableMethod = Helmert
m_pUpdateFrm.chkRMS.Value = 0
End If
Set pEdProps = m_pEditor
iErr = 99
With m_pUpdateFrm
.Show vbModal
If Not m_bExit Then
m_pEditor.StartOperation
m_TopoFunctions.Update m_pEditor.EditSelection, (.chkSnapVertices.Value = 1), (.chkTransform.Value = 1), _
pSegColl, m_pTopoExt, m_pEditor.Map.SpatialReference, m_pTopoSpatRef, _
.cboTransformationMethod.ItemData(.cboTransformationMethod.ListIndex), _
pSnapPoints, pEdProps.StretchGeometry
m_pTopoG.Post pInvalid
pInvalArea.Add pInvalid
m_pEditor.StopOperation "Update Selected Features In the Current Topology"
End If
End With
m_pTopoG.SetEmpty
pInvalArea.Invalidate m_pEditor.Display.ActiveCache
pMXDoc.ActiveView.PartialRefresh esriViewGeography, Nothing, pMXDoc.ActiveView.Extent
If m_pUpdateFrm.chkRMS.Value = 1 And m_pUpdateFrm.chkTransform.Value = 1 Then
'If Not m_pTransF Is Nothing Then
' m_pTransF.GetRMSError dFromErr, dToError
If TypeOf m_pTopoSpatRef Is IProjectedCoordinateSystem2 Then
Dim pPCS As IProjectedCoordinateSystem2: Set pPCS = m_pTopoSpatRef
sUnit = " " & LCase(pPCS.CoordinateUnit.Name) & "s"
Else
sUnit = " degrees"
End If
MsgBox Format(CStr(m_TopoFunctions.RootMeanSquareError), "0.00000") & sUnit, vbInformation, _
"Root Mean Square (RMS) Error"
'End If
End If
Unload m_pUpdateFrm
Exit Sub
handler:
MsgBox Err.Description & " " & iErr
End Sub
Private Sub ICommand_OnCreate(ByVal hook As Object)
Set m_pMXApp = hook
Set m_pApp = m_pMXApp
Set m_pEditor = m_pApp.FindExtensionByName("esri object editor")
Set m_pTopoExt = m_pApp.FindExtensionByName("esri topology extension")
Set m_pSurveyExt = m_pApp.FindExtensionByName("SurveyAnalyst_ArcMapExtension")
End Sub
Private Property Get ICommand_Tooltip() As String
ICommand_Tooltip = "Update Selected Features to Survey Point Locations"
End Property
Public Sub Setup(Method As enumTransformationMethod)
m_pUpdateFrm.chkRMS.Enabled = False
m_pUpdateFrm.cboTransformationMethod.Clear
m_pUpdateFrm.cboTransformationMethod.AddItem "Helmert Transformation", 0
m_pUpdateFrm.cboTransformationMethod.ItemData(0) = 0
Select Case Method
Case 0
Case 1
m_pUpdateFrm.cboTransformationMethod.AddItem "Affine Transformation", 1
m_pUpdateFrm.cboTransformationMethod.ItemData(1) = 1
End Select
m_pUpdateFrm.cboTransformationMethod.ListIndex = 0
End Sub
Private Sub m_Cancel_Click()
m_bExit = True
Unload m_pUpdateFrm
End Sub
Private Sub m_OK_Click()
m_pUpdateFrm.Hide
m_bExit = False
End Sub
Private Sub m_pUpdateFrm_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
Case 13
m_pUpdateFrm.Hide
m_bExit = False
Case 27
m_bExit = True
Unload m_pUpdateFrm
End Select
End Sub
Private Sub m_pUpdateFrm_Load()
Setup m_AvailableMethod
End Sub
Private Sub m_pUpdateFrm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Select Case UnloadMode
Case 0, 1
m_bExit = True
End Select
End Sub