Do While Not pFeature Is Nothing
Dim pEndPt As IPoint
Dim pLine As IPolyline
pLine = pFeature.Shape
pEndPt = pLine.ToPoint
Dim pProxOpLine As IProximityOperator
Dim pFromPt As New Point
Dim pQueryFilter As IQueryFilter
pQueryFilter = New QueryFilter
‘pQFilt.WhereClause =
pQueryFilter.WhereClause = cboRefID.Text & ” = ‘” & pFeature.Value(pFeature.Fields.FindField(cboRefField.Text)) & “‘”
‘ MsgBox(pQueryFilter.WhereClause)
Dim kFeatureLayer As IFeatureLayer
kFeatureLayer = pMxDoc2.FocusMap.Layer(GetLayerIndex(.cboRefLayer.Text))
Dim kFeatureClass As IFeatureClass = kFeatureLayer.FeatureClass
Dim kFeatureCursor As IFeatureCursor = kFeatureClass.Search(pQueryFilter, False)
If kFeatureClass.FeatureCount(pQueryFilter) > 0 Then
Dim kFeature As IFeature = kFeatureCursor.NextFeature
If Not kFeature Is Nothing Then
pProxOpLine = kFeature.Shape
pProxOpLine.QueryNearestPoint(pEndPt, esriSegmentExtension.esriNoExtension, pFromPt)
‘Dim pPolyline As New Polyline
‘ pPolyline.AddPoint(pFromPt)
Dim pPointsF As IPointCollection = pLine
Dim zAware As IZAware = CType(pFromPt, IZAware)
zAware.ZAware = True
pFromPt.Z = pEndPt.Z
pPointsF.AddPoint(pFromPt)
Dim Dist As Double = txtDist.Text
If Not Dist = 0 Then
Dim x As Double
Dim y As Double
If pEndPt.X = pFromPt.X Then
x = pFromPt.X
If pFromPt.Y > pEndPt.Y Then
y = pFromPt.Y + Dist
Else
y = pFromPt.Y – Dist
End If
Else
Dim m As Double
m = (pEndPt.Y – pFromPt.Y) / (pEndPt.X – pFromPt.X)
x = Math.Sqrt(Dist * Dist / (1 + m * m))
If pFromPt.X < pEndPt.X Then
x = pFromPt.X – x
Else
x = pFromPt.X + x
End If
y = m * (x – pFromPt.X) + pFromPt.Y
End If
Dim PtAdd As New Point
PtAdd.X = x
PtAdd.Y = y
Dim zAware2 As IZAware = CType(PtAdd, IZAware)
zAware2.ZAware = True
PtAdd.Z = pEndPt.Z
pPointsF.AddPoint(PtAdd)
End If
pFeature.Shape = pLine
pFeature.Store()
'If Not pFromPt Is Nothing Then
' pProxOpLine.AddPoint(pFromPt)
' End If
'pPolyline.AddPoint(pFromPt)
' pPolyline.AddPoint(pEndPt)
End If
End If
pFeature = pFeatureCursor.NextFeature
Loop
rikstechblog 