SW Gas: Create perpendicular bisectors

Although as it turns out this code is no longer really needed, I wrote some VBA code to create perpendicular from points to lines (e.g. from disconnected service point to secondary OH).  As shown in the image, this works in edit mode on a selected set of points (first layer in the TOC).  The second layer is the line layer. Click the button and "Bob's your uncle".  You can modify the VBA code (below) to increase or decrease the search distance as required.  Note that it finds the NEAREST line to the selected point, but if outside the search tolerance, than no perpendicular is created.  Make sure to save your edits after editing.  If you undo, all the edits for that one click of the button are undone.

Click to enlarge

Here's the code which you can paste into the VBA editor.  You might want to add a button to the ArcMap UI as shown in the image. 

Option Explicit

Private Sub CreateBisectors()

'PURPOSE - Constructs perpindicular bisectors from the selected point

'in layer #1 to the nearest line in layer #2 within xx feet. Note that

'you must save your edits after using this tool.

'ASSUMPTIONS - must be editing to use the layer.

'This code assumes that the point layer is the first layer in the TOC

'and that the line layer (the layer that we will be adding to) is the

'the second layer

Dim SEARCHDISTANCE As Double, SUBTYPECODE As Long

SEARCHDISTANCE = 10

SUBTYPECODE = 1

On Error GoTo eh

Dim startedOperation As Boolean

Dim ed As IEditor

Set ed = Application.FindExtensionByName("ESRI OBJECT EDITOR")

ed.StartOperation

startedOperation = True

Dim sf As ISpatialFilter

Set sf = New SpatialFilter

sf.GeometryField = "SHAPE"

sf.SpatialRel = esriSpatialRelIntersects

Dim mxdoc As IMxDocument

Set mxdoc = ThisDocument

Dim pntLayer As IFeatureLayer, linLayer As IFeatureLayer

Set pntLayer = mxdoc.FocusMap.Layer(0)

Set linLayer = mxdoc.FocusMap.Layer(1)

Dim linFC As IFeatureClass

Set linFC = linLayer.FeatureClass

Dim feSel As IFeatureSelection

Set feSel = pntLayer

Dim pntCur As IFeatureCursor

feSel.SelectionSet.Search Nothing, False, pntCur

Dim pntFE As IFeature

Set pntFE = pntCur.NextFeature

Do While Not pntFE Is Nothing

  Dim selPoint As IPoint

  Set selPoint = pntFE.ShapeCopy

  Dim topOp As ITopologicalOperator

  Set topOp = selPoint

  Dim buf As IGeometry

  Set buf = topOp.Buffer(SEARCHDISTANCE)

  Set sf.Geometry = buf

  Dim linCur As IFeatureCursor

  Set linCur = linLayer.Search(sf, False)

  Dim linFe As IFeature

  Set linFe = linCur.NextFeature

  Dim nearestSoFar As Double

  nearestSoFar = SEARCHDISTANCE

  Dim nearestLineFe As IFeature

  Set nearestLineFe = Nothing

  Do While Not linFe Is Nothing

    Dim proxOp As IProximityOperator

    Set proxOp = linFe.ShapeCopy

    Dim retDist As Double

    retDist = proxOp.ReturnDistance(selPoint)

    If (retDist < nearestSoFar) Then

      Set nearestLineFe = linFe

      nearestSoFar = retDist

    End If

    Set linFe = linCur.NextFeature

  Loop

  If Not nearestLineFe Is Nothing Then

    Dim c3 As ICurve3

    Set c3 = nearestLineFe.ShapeCopy

    Dim outPoint As IPoint, dac As Double, dfc As Double, brs As Boolean

    Set outPoint = New Point

    c3.QueryPointAndDistance esriNoExtension, selPoint, False, outPoint, dac, dfc, brs

    If Not outPoint Is Nothing Then

        Dim newFe As IFeature

        Set newFe = linFC.CreateFeature

        Dim pl As ISegmentCollection

        Set pl = New Polyline

        Dim ln As ILine

        Set ln = New Line

        ln.FromPoint = outPoint

        ln.ToPoint = selPoint

        pl.AddSegment ln

        Set newFe.Shape = pl

        newFe.Value(newFe.Fields.FindField("SUBTYPECD")) = SUBTYPECODE

        newFe.Store

    End If

  End If

  Set pntFE = pntCur.NextFeature

Loop

ed.StopOperation "Create perpindicular bisectors"

startedOperation = False

mxdoc.ActiveView.Refresh

Exit Sub

eh:

MsgBox "An error occured. Please stop editing, and do NOT save edits."

If startedOperation = True Then

    ed.StopOperation "An error occured. Please do not save edits"

End If

End Sub

Private Sub UIButtonControl1_Click()

CreateBisectors

End Sub