Le portail francophone de la géomatique

Option Explicit
Sub Test()
  Dim pMxDoc As IMxDocument
  Set pMxDoc = ThisDocument

  Dim pFlayer As IFeatureLayer
  Set pFlayer = pMxDoc.FocusMap.Layer(0)
  NearestNeighbor pFlayer.FeatureClass, pMxDoc.FocusMap.SpatialReference, NearestOID , NearestDis
End Sub

Sub NearestNeighbor(pFC As IFeatureClass, pSR As ISpatialReference, sNearOIDFld As String, sDistFld As String)
  Dim lOIDFld As Long
  lOIDFld = pFC.FindField(sNearOIDFld)
  If lOIDFld = -1 Then
    MsgBox field not found:  & sNearOIDFld
    Exit Sub
  End If

  Dim lDistFld As Long
  lDistFld = pFC.FindField(sDistFld)
  If lDistFld = -1 Then
    MsgBox field not found:  & sDistFld
    Exit Sub
  End If

  Dim pPoints() As IPoint, lOIDs() As Long
  ReDim pPoints(pFC.FeatureCount(Nothing) - 1)
  ReDim lOIDs(UBound(pPoints))

  Dim pFcur As IFeatureCursor
  Set pFcur = pFC.Search(Nothing, True)

  Debug.Print loading arrays
  Dim l As Long, pFeat As IFeature
  For l = 0 To UBound(pPoints)
    Set pFeat = pFcur.NextFeature
    Set pPoints(l) = pFeat.ShapeCopy
    pPoints(l).Project pSR
    lOIDs(l) = pFeat.OID
  Next l

  Debug.Print finding nearest neighbors
  For l = 0 To UBound(pPoints)
    Dim k As Long, dNearestDist As Double, lNearestOID As Long
    Dim dDist As Double, pProxOp As IProximityOperator
    lNearestOID = -1
    Set pProxOp = pPoints(l)
    For k = 0 To UBound(pPoints)
       If k l Then
         dDist = pProxOp.ReturnDistance(pPoints(k))
         If lNearestOID = -1 Or dDist < dNearestDist Then
            lNearestOID = lOIDs(k)
            dNearestDist = dDist
         End If
       End If
    Next k
    Set pFeat = pFC.GetFeature(lOIDs(l))
    pFeat.Value(lOIDFld) = lNearestOID
    pFeat.Value(lDistFld) = dNearestDist
    pFeat.Store
    Debug.Print l
   Next l
End Sub