Le portail francophone de la géomatique

Public Function Recherche_FLayer(Nom_Layer As String) As esricarto.IFeatureLayer

Dim i As Integer
Dim pLayer As esricarto.ILayer

Dim MonApp As esriArcMapUI.IMxApplication
Dim MonDoc As esriArcMapUI.IMxDocument
Dim MaMap As esricarto.IMap
Dim MaVueActive As esricarto.IActiveView

Set MonApp = Application
Set MonDoc = ThisDocument
Set MaVueActive = MonDoc.ActiveView
Set MaMap = MaVueActive.FocusMap

For i = 0 To MaMap.LayerCount - 1
    If TypeOf MaMap.Layer(i) Is esricarto.ICompositeLayer = True Then
        Dim MaCoucheCompose As esricarto.ICompositeLayer
        Set MaCoucheCompose = MaMap.Layer(i)
        Dim A As Integer
        For A = 0 To MaCoucheCompose.Count - 1
            If MaCoucheCompose.Layer(A).Name = Nom_Layer Then
                Set Recherche_FLayer = MaCoucheCompose.Layer(A)
                Exit For
            End If
        Next A
    Else
        Set pLayer = MaMap.Layer(i)
        If pLayer.Name = Nom_Layer Then
            Set Recherche_FLayer = pLayer
            Exit For
        End If
    End If
Next i
End Function

Private Function ISnapAgent_Snap(ByVal MaCouche As String, ByVal MonPoint As esriGeometry.IPoint, ByVal tolerance As Double) As esriGeometry.IPoint

  Dim minDist As Double
  Dim pFLayer As esricarto.IFeatureLayer
  Dim pSnapPt As esriGeometry.IPoint
  Dim pOutPoly As esriGeometry.IPolygon
  Dim pProximity As esriGeometry.IProximityOperator
  Dim pTopo As esriGeometry.ITopologicalOperator
  Dim X As Double, Y As Double

  Set pProximity = MonPoint
  minDist = 10
  Set pFLayer = ThisDocument.Recherche_FLayer(MaCouche)

  Set pTopo = MonPoint
  Set pOutPoly = pTopo.Buffer(minDist) 'Set the buffer distance to 10 map units

Dim MaRequete As esriGeoDatabase.IQueryFilter
Set MaRequete = New esriGeoDatabase.QueryFilter
MaRequete.WhereClause = ""

Dim pFilter As esriGeoDatabase.ISpatialFilter
Set pFilter = New esriGeoDatabase.SpatialFilter

With pFilter
    Set .Geometry = pOutPoly
    .GeometryField = "Shape"
    .SpatialRel = esriSpatialRelIntersects
End With

Dim pFeatureSelection As esricarto.IFeatureSelection
Set pFeatureSelection = pFLayer
pFeatureSelection.SelectFeatures pFilter, esriSelectionResultNew, True
Dim MonCurseur As esriGeoDatabase.ICursor
pFeatureSelection.SelectionSet.Search MaRequete, False, MonCurseur
Dim MaLigne As esriGeoDatabase.IRow
Set MaLigne = MonCurseur.NextRow
pFeatureSelection.Clear

Dim MaFeature As esriGeoDatabase.IFeature
Set MaFeature = MaLigne
If MaFeature Is Nothing Then
    Set ISnapAgent_Snap = MonPoint
    Exit Function
Else

    Dim MaCollection As esriGeometry.IPointCollection
    Dim MaCollection2 As esriGeometry.IPointCollection
    Set MaCollection = MaFeature.Shape
    Set MaCollection2 = New esriGeometry.Multipoint
    MaCollection2.InsertPointCollection 0, MaCollection
    Dim MonMultipoint As esriGeometry.IMultipoint
    Set MonMultipoint = MaCollection2
    Set pProximity = MonMultipoint
    Set pSnapPt = pProximity.ReturnNearestPoint(MonPoint, esriNoExtension)
    If pSnapPt Is Nothing Then
        Set ISnapAgent_Snap = MonPoint
    Else
        Dim MonTrace As esriGeometry.ILine
        Set MonTrace = New esriGeometry.Line
        MonTrace.PutCoords MonPoint, pSnapPt
        If MonTrace.Length < tolerance Then
            Set ISnapAgent_Snap = pSnapPt
        Else
            Set ISnapAgent_Snap = MonPoint
        End If
    End If
End If
End Function

    
            Dim C As esriGeometry.IPoint
            Set C = New esriGeometry.Point
            Dim D As esriGeometry.IPoint
            Set D = New esriGeometry.Point

'la il faudrait un bout de code suplémentaire pour creer tes points. Si tu trouve pas je devrais pouvoir te trouver ça
       
            Dim MaligneCD As esriGeometry.ILine
            Set MaligneCD = New esriGeometry.Line
            MaligneCD.PutCoords C, D
    
            Dim MonSegment As ISegment
            Set MonSegment = MaligneCD
    
            Dim MonSegmentCollection As esriGeometry.ISegmentCollection
            Set MonSegmentCollection = New esriGeometry.Polyline
            MonSegmentCollection.AddSegment MonSegment
    
            Dim CD As esriGeometry.IPolyline
            Set CD = MonSegmentCollection