'******************************************************************** ' Procédure servant à populer les listes des layers pour le calcul ' du plus proche voisin. ' D'après : François Robitaille, note de cours GEO7631, Cours 5 et 8 '******************************************************************** Private Sub Nearest_Click() frmNearest.cboSource.Clear frmNearest.cboChainage.Clear Dim pMxDoc As IMxDocument Set pMxDoc = ThisDocument Dim pMaps As IMaps Set pMaps = pMxDoc.Maps Dim pMap As IMap Dim i As Integer For i = 0 To (pMaps.Count - 1) Set pMap = pMaps.Item(i) If pMap.LayerCount > 0 Then Dim pAllLayers As IEnumLayer Dim pLayer As ILayer Set pAllLayers = pMap.Layers pAllLayers.Reset Set pLayer = pAllLayers.Next Do Until pLayer Is Nothing frmNearest.cboSource.AddItem pLayer.Name frmNearest.cboChainage.AddItem pLayer.Name Set pLayer = pAllLayers.Next Loop End If Next i frmNearest.cboSource.Value = frmNearest.cboSource.List(1) ' frmNearest.cboChainage.Value = frmNearest.cboChainage.List(0) ' frmNearest.Show End Sub '*********************************************************************************************************************************************** Public Function NearestNeighbor(strSource As String, strTarget As String, intSourceIndex As Integer, intTargetIndex As Integer) As Boolean frmNearest.Hide Dim pMxDoc As IMxDocument Set pMxDoc = ThisDocument Dim pEnumLayer As IEnumLayer Set pEnumLayer = pMxDoc.FocusMap.Layers pEnumLayer.Reset Dim pLSource As ILayer Set pLSource = pEnumLayer.Next Do Until pLSource Is Nothing If pLSource.Name = strSource Then Exit Do End If Set pLSource = pEnumLayer.Next Loop pEnumLayer.Reset Dim pLChainage As ILayer Set pLChainage = pEnumLayer.Next Do Until pLChainage Is Nothing If pLChainage.Name = strTarget Then Exit Do End If Set pLChainage = pEnumLayer.Next Loop '************************************************************************* ' Add the field that will receive the offset value of the nearest neighbor '************************************************************************* Dim pFeatLayerSource As IFeatureLayer Set pFeatLayerSource = pMxDoc.FocusMap.Layer(intSourceIndex) Dim pFeatClassSource As IFeatureClass Set pFeatClassSource = pFeatLayerSource.FeatureClass ' Création de la collection de champs Dim pFields As IFields Dim pFieldsEdit As IFieldsEdit Set pFields = pFeatClassSource.Fields Set pFieldsEdit = pFields Dim pField As IField Dim pFieldEdit As IFieldEdit ' Add the field only if it don't exist If pFeatClassSource.Fields.FindField("Offset") = -1 Then Set pField = New Field Set pFieldEdit = pField With pFieldEdit .Name = "Offset" .Type = esriFieldTypeSingle End With pFeatClassSource.Addfield pField ' TEMPORAIRE : Pour validation seulement parce qu'anyway Else MsgBox "The field «Offset» already exists", vbExclamation End If '**************************************************************** ' Find the Nearest Feature ' Adapted from: ' anjal Dave, "Find Nearest feature from click location" ' http://arcscripts.esri.com/details.asp?dbid=14317 '****************************************************************************** Dim ii As Long Dim intSourceCount As Integer ii = 1 intSourceCount = pFeatClassSource.FeatureCount(Nothing) Dim pFeatLayerTarget As IFeatureLayer Set pFeatLayerTarget = pMxDoc.FocusMap.Layer(intTargetIndex) Dim pFeatClassTarget As IFeatureClass Set pFeatClassTarget = pFeatLayerTarget.FeatureClass Dim pFeatIndex As IFeatureIndex Set pFeatIndex = New FeatureIndex Set pFeatIndex.FeatureClass = pFeatClassTarget Dim pTrackCancel As ITrackCancel Set pTrackCancel = New CancelTracker Dim pEnv As IEnvelope Set pEnv = pFeatLayerTarget.AreaOfInterest pFeatIndex.Index pTrackCancel, pEnv Dim pQI As IIndexQuery2 Set pQI = pFeatIndex Dim lngFid As Long Dim dblDist As Double Dim pFeatSource As IFeature Dim pFeatTarget As IFeature Dim sglValOffset As Single sglValOffset = -99 ' for validation purpose... Dim pCurSource As IFeatureCursor Set pCurSource = pFeatClassSource.Update(Nothing, False) Set pFeatSource = pCurSource.NextFeature Dim pGeom As IPoint Set pGeom = pFeatSource.ShapeCopy frmProgression.Show Do Until pFeatSource Is Nothing pQI.NearestFeature pGeom, lngFid, dblDist Set pFeatTarget = pFeatClassTarget.GetFeature(lngFid) sglValOffset = pFeatTarget.Value(pFeatClassTarget.Fields.FindField("Offset")) ' MsgBox "Source FID = " & pFeatSource.Value(pFeatClassSource.Fields.FindField("FID")) & vbNewLine & _ ' "Target FID: " & lngFid & vbNewLine & _ ' "Distance: " & dblDist pFeatSource.Value(pFeatClassSource.Fields.FindField("Offset")) = sglValOffset pCurSource.UpdateFeature pFeatSource pFeatSource.Store Set pFeatSource = pCurSource.NextFeature Set pGeom = pFeatSource.ShapeCopy frmProgression.lblProgression.Caption = ii & "/" & intSourceCount ii = ii + 1 Loop frmProgression.Hide NearestNeighbor = True End Function