Private Sub RunCompareTool(ByVal basefeaturelayer As IFeatureLayer, ByVal testfeaturelayer As IFeatureLayer) ' This sub checks that each feature in the test layer exists within ' the the base layer. Try 'First Test that the geometry type is the same If Not basefeaturelayer.FeatureClass.ShapeType = testfeaturelayer.FeatureClass.ShapeType Then MsgBox("Geometry types do not match and therefore cannot be compared." & vbNewLine & "Aborting...", MsgBoxStyle.Critical, "Geometry mismatch") Exit Sub End If 'Next test that features exist in both layers If basefeaturelayer.FeatureClass.FeatureCount(Nothing) = 0 Then MsgBox(basefeaturelayer.Name & " contains no features." & vbNewLine & "Aborting...", MsgBoxStyle.Critical, "Empty layer") Exit Sub End If If testfeaturelayer.FeatureClass.FeatureCount(Nothing) = 0 Then MsgBox(testfeaturelayer.Name & " contains no features." & vbNewLine & "Aborting...", MsgBoxStyle.Critical, "Empty layer") Exit Sub End If ' Get sub selection from base layer based on test layer extent and add to featurecursor g_pMap.ClearSelection() Dim psf As ISpatialFilter = New SpatialFilter With psf .Geometry = testfeaturelayer.AreaOfInterest .SpatialRel = esriSpatialRelEnum.esriSpatialRelIntersects End With Dim basesel As IFeatureSelection = basefeaturelayer basesel.SelectFeatures(psf, esriSelectionResultEnum.esriSelectionResultNew, False) Dim basecursor As IFeatureCursor basesel.SelectionSet.Search(Nothing, True, basecursor) ' Get feature cursor on all features in test layer Dim testcursor As IFeatureCursor = testfeaturelayer.Search(Nothing, True) ' Use iteration through the tow featurecursors to compare all features within the ' test layer with the baselayer and use the results to flick a boolean switch if a ' match is found. Dim pRelOp As IRelationalOperator Dim basefeat As IFeature = basecursor.NextFeature Dim testfeat As IFeature = testcursor.NextFeature Dim layermatch As Boolean = True Dim geommatch, attributematch As String Dim workspacetype As Integer = GetWorkspaceType(testfeaturelayer) Dim errorbag As IGeometryCollection = New GeometryBag Dim errorset As ISet = New [Set] Do While Not testfeat Is Nothing geommatch = "Failed" attributematch = "Not Tested" pRelOp = testfeat.Shape 'Set IRelationalOperator to test geometry 'Reset base layer cursor basesel.SelectionSet.Search(Nothing, True, basecursor) basefeat = basecursor.NextFeature Do While Not basefeat Is Nothing ' Use IRelationalOperator to test the shape of the test feature for a match in ' the selected base layer If pRelOp.Equals(basefeat.Shape) Then geommatch = "Passed" 'If selected then check this features attributes If cbbTestType.SelectedIndex = 1 Then If CompareFieldData(basefeat, testfeat, workspacetype) Then attributematch = "Passed" Exit Do Else attributematch = "Failed" End If End If Exit Do End If basefeat = basecursor.NextFeature Loop If geommatch = "Failed" Or attributematch = "Failed" Then layermatch = False If chbProduceErrorLayer.Checked Then MsgBox(testfeat.Value(3) & vbNewLine & testfeat.OID) '+++ Confirm that the features are the ones that failed the test. errorset.Add(testfeat) '+++ These features in my test space (TestFeatureLayer) are OID 11 and 58. errorbag.AddGeometry(testfeat.ShapeCopy) Else 'If no feature error record is being kept then exit loop and report layer match as false Exit Do End If End If testfeat = testcursor.NextFeature Loop If Not errorbag.GeometryCount = 0 Then InsertFeatures(errorbag) '++++ This returns only the last feature from TestFeatureLayer, OID 153 errorset.Reset() Dim test As IFeature = errorset.Next Do While Not test Is Nothing MsgBox(test.Value(3) & vbNewLine & test.OID) test = errorset.Next Loop If layermatch = False Then MsgBox("TEST FAILED: Not all of the test layer features and/or attributes were" & vbNewLine & "found within the base layer :-(", MsgBoxStyle.Information, "Results") Else MsgBox("TEST SUCEEDED: All of the test layer features and/or attributes were" & vbNewLine & "found within the base layer :-)", MsgBoxStyle.Information, "Results") End If Catch ex As Exception MsgBox("RunCompareTool - " & ex.Message & vbNewLine & ex.StackTrace) Finally g_pMap.ClearSelection() g_pMxDoc.UpdateContents() g_pMxDoc.ActiveView.Refresh() End Try End Sub
Solved! Go to Solution.