' Copyright 2008 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 use restrictions at <your ArcGIS install location>/developerkit/userestrictions.txt.
'
'
'Title: Jumper Extension
'Date: November 28, 2000
'Purpose: This sample code is designed to add a jumper (semi-circle) during the adding of
' line feature that crosses another line feature of the same feature class. For instance,
' if you are adding a new pipe feature and you cross over an existing pipe feature, this
' extension will automatically add a jumper.
'
' This extension is designed as an MxExtension so the state of the extension can be toggled on
' and off through the ArcMap extension dialog. This is accomplished by implementing
' IExtensionConfig in addition to IExtension.
'
' The extension is currently searching for a layer called "Pipes". Update the code and
' recompile if you want to apply this to a layer with a different name.
'
'To use:
'1.) (Optional) Change the layer to search for from "Pipes" to something else and recompile.
'2.) Register the dll in categories.exe under ESRI Mx Extensions.
'3.) Start ArcMap and add a line layer with the name "Pipes" (or whatever name you used).
'4.) Access the Extensions dialog and make sure the Jumper extension is enabled.
'5.) Start editing, and add line features into the "Pipes" layer that cross other features in that layer.
'
Option Explicit
Implements IExtension
Implements IExtensionConfig
Dim WithEvents m_Editor As Editor
Dim m_Flag As Boolean
Dim m_pLayer As IFeatureLayer
Dim m_ExtState As esriSystem.esriExtensionState
Private Property Get IExtension_Name() As String
IExtension_Name = "Jumper Addition"
End Property
Private Sub IExtension_Shutdown()
Set m_Editor = Nothing
Set m_pLayer = Nothing
m_Flag = False
End Sub
Private Sub IExtension_Startup(initializationData As Variant)
Dim pApp As IApplication, pUID As New UID
Set pApp = initializationData
pUID = "esriEditor.editor"
Set m_Editor = pApp.FindExtensionByCLSID(pUID)
m_ExtState = esriESDisabled
End Sub
Private Property Get IExtensionConfig_Description() As String
IExtensionConfig_Description = "Adds a jumper when a new line crosses another."
End Property
Private Property Get IExtensionConfig_ProductName() As String
IExtensionConfig_ProductName = "Jumper Extension"
End Property
Private Property Let IExtensionConfig_State(ByVal RHS As esriSystem.esriExtensionState)
m_ExtState = RHS
End Property
Private Property Get IExtensionConfig_State() As esriSystem.esriExtensionState
IExtensionConfig_State = m_ExtState
End Property
Private Sub m_Editor_OnCurrentLayerChanged()
On Error GoTo ErrHand:
Dim pEditor As IEditLayers, pLayer As IFeatureLayer
Set pEditor = m_Editor
If pEditor Is Nothing Then
m_Flag = False
Exit Sub
End If
If pEditor.CurrentLayer Is Nothing Then
m_Flag = False
Exit Sub
End If
Set pLayer = pEditor.CurrentLayer
If pLayer Is Nothing Then
m_Flag = False
Exit Sub
End If
If UCase(pLayer.Name) = "PIPES" And m_ExtState = esriESEnabled Then '<---- CHANGE THIS TO YOUR LAYER OF CHOICE
m_Flag = True
Set m_pLayer = pLayer
Else
m_Flag = False
End If
Set pEditor = Nothing
Set pLayer = Nothing
Exit Sub
ErrHand:
MsgBox "OnCurrentLayerChanged - " & Err.Description
Exit Sub
End Sub
Private Sub m_Editor_OnSketchModified()
On Error GoTo ErrHand:
If Not m_Flag Then Exit Sub
Dim pSketch As IEditSketch, pCount As Long, pPolyline As IPointCollection
If m_Editor Is Nothing Then Exit Sub
Set pSketch = m_Editor
If pSketch.Geometry Is Nothing Then Exit Sub
Set pPolyline = pSketch.Geometry
If pPolyline.PointCount < 2 Then Exit Sub
Dim pLine As IPointCollection, pFeatCursor As IFeatureCursor, pFilter As ISpatialFilter
Dim pFeat As IFeature
Set pLine = New esriGeometry.Polyline
pLine.AddPoint pPolyline.Point(pPolyline.PointCount - 2)
pLine.AddPoint pPolyline.Point(pPolyline.PointCount - 1)
Set pFilter = New SpatialFilter
Set pFilter.Geometry = pLine
pFilter.SpatialRel = esriSpatialRelCrosses
Set pFeatCursor = m_pLayer.Search(pFilter, False)
Set pFeat = pFeatCursor.NextFeature
If pFeat Is Nothing Then Exit Sub
Dim pTopo As ITopologicalOperator, pCol As IPointCollection, pIntPt As IPoint, pTopo2 As ITopologicalOperator
Dim pPLine As IPolyline, pOutPt As IPoint, pLineCurve As ICurve, dTotDist As Double
Dim dDist As Double, dDist2 As Double, bSide As Boolean
Set pTopo = pFeat.Shape
Set pIntPt = New esriGeometry.Point
Set pTopo2 = pLine
pTopo2.Simplify
pTopo.Simplify
Set pCol = pTopo.Intersect(pLine, esriGeometry0Dimension)
Set pIntPt = pCol.Point(0)
pCount = pPolyline.PointCount - 1
'Find distance along the curve
Set pOutPt = New esriGeometry.Point
Set pPLine = pLine
pPLine.QueryPointAndDistance esriNoExtension, pIntPt, False, pOutPt, dDist, dDist2, bSide
Set pLineCurve = pPLine
dTotDist = dDist + 7#
'Exit if there isn't room for the curve
If dDist < 7# Or pLineCurve.Length < dTotDist Then Exit Sub
'Make the start point
Dim pEndPt As IPoint, pSegColl As ISegmentCollection
Dim pCurve As IConstructCircularArc, pCurveSeg As ISegment
Dim pProx As IProximityOperator, dblPntDist As Double
Set pOutPt = New esriGeometry.Point
pPLine.QueryPoint esriNoExtension, dDist - 7#, False, pOutPt
'Reset the last point to the beginning of the curve
Set pEndPt = pPolyline.Point(pPolyline.PointCount - 1)
pPolyline.RemovePoints pPolyline.PointCount - 1, 1
pPolyline.AddPoint pOutPt
'Create the curve segment and add it to the polyline
Set pCurve = New CircularArc
Set pProx = pIntPt
dblPntDist = pProx.ReturnDistance(pOutPt)
pCurve.ConstructChordDistance pIntPt, pOutPt, True, (2 * dblPntDist)
Set pCurveSeg = pCurve
Set pSegColl = pPolyline
pSegColl.AddSegment pCurveSeg
pPolyline.AddPoint pEndPt
pSketch.RefreshSketch
Exit Sub
ErrHand:
MsgBox Err.Description
Exit Sub
End Sub