
'start edit session for the point shapefile before running
'only select one line
'lineshapefile has to be 1st layer in TOC
'pointshapefile has to be 2nd layer in TOC
Sub test()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pFeatureLayer As IFeatureLayer
Dim pFeatureSelection As IFeatureSelection
Dim pEnumFeature As IEnumFeature
Dim pEnumFeatureSetup As IEnumFeatureSetup
Dim pFeature_line As IFeature
Set pMxDoc = Application.Document
Set pMap = pMxDoc.FocusMap
'Line shapefile is the first in the TOC
Set pFeatureLayer = pMap.Layer(0)
Set pFeatureSelection = pFeatureLayer
Set pEnumFeature = pMap.FeatureSelection
Set pEnumFeatureSetup = pEnumFeature
pEnumFeatureSetup.AllFields = True
Set pFeature_line = pEnumFeature.Next
'************************************
'point shapefile
Dim pFLayer As IFeatureLayer
'second layer in TOC
Set pFLayer = pMap.Layer(1)
Dim pFeat As IFeature
Dim pFc As IFeatureClass
Set pFc = pFLayer.FeatureClass
Dim prow As IRow
Dim pTable As ITable
Set pTable = pFc
Dim count As Integer
Dim pCursor As ICursor
Set pCursor = pTable.Update(Nothing, False)
Dim pFeature As IFeature
Set prow = pCursor.NextRow
Dim FeatureCount As Long
FeatureCount = pFc.FeatureCount(Nothing)
Dim maxval As Long
maxval = FeatureCount
Dim azi As Double
Dim pi As Double
pi = 4 * Atn(1)
Dim ppt As IPoint
Dim ppt_new As IPoint
Dim ppt_intersect As IPoint
Dim line As IPolyline
Dim lenght As Double
Length = 1000000
Dim pProxOp As IProximityOperator
Dim pGeom As IGeometry
Dim pGeom1 As IGeometry
Dim pGeomColl As IGeometryCollection
Dim pTopoOptr As ITopologicalOperator
'loop through the point shapefile
For i = 0 To maxval  1
Set pFeat = pFc.GetFeature(i)
Set prow = pTable.GetRow(i)
'get the azimuth values from the attribute table
azi = prow.Value(pTable.FindField("azimuth"))
azi = azi * pi / 180
Set ppt = pFeat.Shape
Set ppt_new = New Point
ppt_new.x = ppt.x + (Sin(azi) * Length)
ppt_new.Y = ppt.Y + (Cos(azi) * Length)
Set line = New Polyline
line.FromPoint = ppt
line.ToPoint = ppt_new
Set pTopoOptr = line
Set pGeomColl = pTopoOptr.Intersect(pFeature_line.Shape, esriGeometry0Dimension)
'If no intersection points, write 99 in the "distance" field
If pGeomColl.GeometryCount = 0 Then
dDist = 99
Else
' first point in pgeomcoll is the closest
'Create a new point features at each intersection
Set ppt_intersect = pGeomColl.Geometry(0)
Set pGeom1 = ppt
Set pGeom = ppt_intersect
Set pProxOp = pGeom
'Find the Distance
dDist = pProxOp.ReturnDistance(pGeom1)
End If
'writes the result in the field "distance" in the point shapefile
prow.Value(pTable.FindField("distance")) = dDist
prow.Store
Set prow = pCursor.NextRow
Next i
End Sub
