BufferSnapAgent\BufferSnap.vb
' Copyright 2012 ESRI ' ' All rights reserved under the copyright laws of the United States ' and applicable international laws, treaties, and conventions. ' ' You may freely redistribute and use this sample code, with or ' without modification, provided you include the original copyright ' notice and use restrictions. ' ' See the use restrictions. ' Imports System Imports System.Runtime.InteropServices Imports ESRI.ArcGIS.Carto Imports ESRI.ArcGIS.esriSystem Imports ESRI.ArcGIS.Geodatabase Imports ESRI.ArcGIS.Geometry Imports ESRI.ArcGIS.ADF.CATIDs Imports ESRI.ArcGIS.Controls Namespace BufferSnapVB '/ <summary> '/ Uses the Create Feature event to turn on the extension, which '/ implements a snapping agent. The Buffer Snap agent is based on a buffer '/ around the points of the first editable point feature class. '/ A buffer of 1000 map units is created if the next point feature created '/ is within the tolerance it is snapped to the buffer ring. '/ </summary> <Guid("A7BE542E-6C0D-423f-8824-FFC7B6ADF0B4"), ClassInterface(ClassInterfaceType.None), ProgId("BufferSnapVB.BufferSnap")> _ Public Class BufferSnap Implements IEngineSnapAgent Implements IEngineSnapAgentCategory Implements IPersistVariant Implements IExtension #Region "COM Registration Function(s)" <ComRegisterFunction(), ComVisible(False)> _ Public Shared Sub RegisterFunction(ByVal registerType As Type) ' Required for ArcGIS Component Category Registrar support ArcGISCategoryRegistration(registerType) End Sub <ComUnregisterFunction(), ComVisible(False)> _ Public Shared Sub UnregisterFunction(ByVal registerType As Type) ' Required for ArcGIS Component Category Registrar support ArcGISCategoryUnregistration(registerType) End Sub #Region "ArcGIS Component Category Registrar generated code" '/ <summary> '/ Required method for ArcGIS Component Category registration - '/ Do not modify the contents of this method with the code editor. '/ </summary> Private Shared Sub ArcGISCategoryRegistration(ByVal registerType As Type) Dim regKey As String = String.Format("HKEY_CLASSES_ROOT\CLSID\{{{0}}}", registerType.GUID) EngineSnapAgents.Register(regKey) End Sub '/ <summary> '/ Required method for ArcGIS Component Category unregistration - '/ Do not modify the contents of this method with the code editor. '/ </summary> Private Shared Sub ArcGISCategoryUnregistration(ByVal registerType As Type) Dim regKey As String = String.Format("HKEY_CLASSES_ROOT\CLSID\{{{0}}}", registerType.GUID) EngineSnapAgents.Unregister(regKey) End Sub #End Region #End Region 'declare and initialize class variables. Private m_featureCache As IFeatureCache Private m_featureClass As IFeatureClass Private m_editor As IEngineEditor Public Sub New() End Sub #Region "IPersist Variant Members." ''' <summary> ''' Get the ID of the object. ''' </summary> Private ReadOnly Property ID() As ESRI.ArcGIS.esriSystem.UID Implements ESRI.ArcGIS.esriSystem.IPersistVariant.ID Get Dim pID As New UID pID.Value = "BufferSnapVB.BufferSnap" Return pID End Get End Property Private Sub Load(ByVal stream As ESRI.ArcGIS.esriSystem.IVariantStream) Implements ESRI.ArcGIS.esriSystem.IPersistVariant.Load End Sub Private Sub Save(ByVal Stream As ESRI.ArcGIS.esriSystem.IVariantStream) Implements ESRI.ArcGIS.esriSystem.IPersistVariant.Save End Sub #End Region #Region "IEngineSnapAgent Implementations" Public ReadOnly Property Name() As String Implements IEngineSnapAgent.Name, IExtension.Name Get Return "Buffer Snap VB" End Get End Property Public Function Snap(ByVal geom As IGeometry, ByVal point As IPoint, ByVal tolerance As Double) As Boolean Implements IEngineSnapAgent.Snap GetFeatureClass() Dim b_setNewFeatureCache As Boolean = False If m_featureClass Is Nothing Or m_editor Is Nothing Then Return False End If If m_featureClass.ShapeType <> esriGeometryType.esriGeometryPoint Then Return False End If 'Check if a feature cache has been created. If Not b_setNewFeatureCache Then m_featureCache = New FeatureCache() b_setNewFeatureCache = True End If 'Fill the New Cache with the geometries. 'It is up to the developer to choose an appropriate value 'given the map units and the scale at which editing will be undertaken. FillCache(m_featureClass, point, 10000) Dim proximityOp As IProximityOperator = DirectCast(point, IProximityOperator) Dim minDist As Double = tolerance Dim cachePt As IPoint = New PointClass() Dim snapPt As IPoint = New PointClass() Dim outPoly As IPolygon = New PolygonClass() Dim topoOp As ITopologicalOperator Dim feature As IFeature Dim Index As Integer = 0 Dim Count As Integer For Count = 0 To m_featureCache.Count - 1 Step Count + 1 feature = m_featureCache.Feature(Count) cachePt = feature.Shape topoOp = cachePt 'Set the buffer distance to an appropriate value 'given the map units and data being edited outPoly = topoOp.Buffer(1000) Dim Dist As Double = proximityOp.ReturnDistance(outPoly) If Dist < minDist Then Index = Count minDist = Dist End If Next 'Make sure minDist is within the search tolerance. If minDist >= tolerance Then Return False End If 'Retrieve the feature and its part again. feature = m_featureCache.Feature(Index) cachePt = feature.Shape topoOp = cachePt 'Set the buffer distance to an appropriate value 'given the map units and data being edited outPoly = topoOp.Buffer(1000) proximityOp = outPoly snapPt = proximityOp.ReturnNearestPoint(point, esriSegmentExtension.esriNoExtension) 'Since point was passed in ByValue, we have to modify its values instead. 'of giving it a new address. point.PutCoords(snapPt.X, snapPt.Y) Return True End Function Private Sub FillCache(ByVal FClass As IFeatureClass, ByVal pPoint As IPoint, ByVal Distance As Double) m_featureCache.Initialize(pPoint, Distance) m_featureCache.AddFeatures(FClass) End Sub #End Region #Region "IEngineSnapAgentCategory Implementation" Public ReadOnly Property Category() As String Implements IEngineSnapAgentCategory.Category Get Return "Buffer Snap Category VB" End Get End Property #End Region Private Sub GetFeatureClass() Dim map As IMap = m_editor.Map Dim snapLayers As IEngineEditLayers = m_editor Dim featLayer As IFeatureLayer = snapLayers.TargetLayer 'Search the editable layers and set the snap feature class to the point layer. Dim CountLayers As Integer For CountLayers = 0 To map.LayerCount - 1 Step CountLayers + 1 If featLayer Is Nothing Then Return End If If featLayer.FeatureClass.ShapeType <> esriGeometryType.esriGeometryPoint Then Return Else m_featureClass = featLayer.FeatureClass End If Next End Sub #Region "IExtension Members" Public Sub Shutdown() Implements IExtension.Shutdown m_editor = Nothing End Sub Public Sub Startup(ByRef initializationData As Object) Implements IExtension.Startup If initializationData IsNot Nothing AndAlso TypeOf initializationData Is IEngineEditor Then m_editor = DirectCast(initializationData, IEngineEditor) End If End Sub #End Region End Class End Namespace