Le portail francophone de la géomatique

Sub recherchedoublons(LayerName As String)

     '***Description : Permet de définir les doublons existants et de les sélectionner
    BasculerEnModeDonnées
    ActiverBlocDonnées "CARTE00"
    
    Dim msg As String
    msg = "Liste des OID" & vbNewLine
    Dim nb As Long
    nb = 0
    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
    Dim pFLayer As IFeatureLayer
    Dim pMap As IMap
    Set pMap = pMxDoc.FocusMap
    Dim pLayers As IEnumLayer
    Set pLayers = pMap.Layers
    Dim pLayer As ILayer
    Set pLayer = pLayers.Next
    
    Dim Trouvé As Boolean
    Trouvé = False
    
    Do Until pLayer Is Nothing
        If TypeOf pLayer Is IFeatureLayer Then
            Set pFLayer = pLayer
            If pLayer.Name = LayerName Then
                Trouvé = True
                Exit Do
            End If
        End If
        Set pLayer = pLayers.Next
    Loop
    
    
    If Not Trouvé Then
        MsgBox "Couche non trouvé dans le document!", vbInformation
        Exit Sub
    End If
    
    'calcul du nombre d'entités dans la table sélectionnée
    Dim pFC1 As IFeatureClass
    Set pFC1 = pFLayer.FeatureClass
    Dim nbEntite As Integer
    nbEntite = pFC1.FeatureCount(Nothing)

    'Crée un espace de travail temporaire nécessaire à la sélection
    Dim pScratchWorkspace As IWorkspace
    Dim pScratchWorkspaceFactory As IScratchWorkspaceFactory
    Set pScratchWorkspaceFactory = New ScratchWorkspaceFactory
    Set pScratchWorkspace = pScratchWorkspaceFactory.DefaultScratchWorkspace
    
    'On sélectionne toutes les entités.
    Dim pSelSet As ISelectionSet
    Set pSelSet = pFLayer.FeatureClass.Select(Nothing, esriSelectionTypeIDSet, _
    esriSelectionOptionNormal, pScratchWorkspace)
    
    Dim pFCurs1 As IFeatureCursor
    Dim pFCurs2 As IFeatureCursor
    
    pSelSet.Search Nothing, False, pFCurs1
    
    Dim pF1 As IFeature
    Dim pF2 As IFeature
    
    Set pF1 = pFCurs1.NextFeature
    
    Dim pSFilter As ISpatialFilter 'Cette ligne et les 2 suivantes sont à écrire avant Do Until pF is Nothing
    Set pSFilter = New SpatialFilter
    pSFilter.SpatialRel = esriSpatialRelIntersects
    Dim pRelOp As IRelationalOperator 'Avant Do Until pF is Nothing
    
    frmDoublons.Hide
    
    BPinit nbEntite
    PROGRESSION.Caption = "Analyse de la table"
    Dim I As Integer
    
    Do Until pF1 Is Nothing

        I = I + 1
        If I Mod 50 = 0 Then
            BPshow 50
        End If
        
        pSelSet.RemoveList 1, pF1.OID 'Pour ne plus tester l'entité pF, on la retire depSelSet
        Set pSFilter.Geometry = pF1.Shape
        pSelSet.Search pSFilter, False, pFCurs2
        Set pF2 = pFCurs2.NextFeature
        
        Set pRelOp = pF1.Shape
        Do Until pF2 Is Nothing
            If pRelOp.Equals(pF2.Shape) Then
                pSelSet.RemoveList 1, pF2.OID 'Pour ne plus tester l'entité pF2, on la retire de pSelSet
                'Sélection de pF2, ajout de pF2 à la liste des doublons et incrémentation du compteur des doublons.
                'traitement
                nb = nb + 1
                pMap.SelectFeature pFLayer, pF2
                msg = msg & pF2.Value(pF1.Fields.FindField("OBJECTID")) & vbNewLine
                '-------------'
            End If
            Set pF2 = pFCurs2.NextFeature
        Loop
        Set pF1 = pFCurs1.NextFeature
    Loop
    
    PROGRESSION.Hide
    pMxDoc.ActiveView.Refresh
    
    'pas de doublons
    If nb = 0 Then
        MsgBox "La table ne contient pas de doublons.", , "Résultats : "
    Else
        MsgBox msg, , "Résultats : " & nb & " doublons"
    End If
    
End Sub