Fehlermeldung: Non-Simple-Geometrie

Hallo Semy?,

funzt bei mir ohne Probleme, auch bei Intesection zweier Multiparts. Wie übergibst Du denn die Parameter?

Viele Grüße
Jörg Ostendorp

Hallo JÖrg,

So sieht der gesamte Code aus.

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

Dim pFLayer As IFeatureLayer
Set pFLayer = pMxDoc.FocusMap.Layer(1)

Dim lField As Long
lField = pFLayer.FeatureClass.FindField("State_Name")
WriteOverlaps pFLayer.FeatureClass
pMxDoc.ActiveView.Refresh
End Sub

Sub WriteOverlaps(pFC As IFeatureClass)
Dim pEditor As IEditor
Set pEditor = Application.FindExtensionByName("ESRI Object Editor")
If pEditor.EditState <> esriStateEditing Then
MsgBox "start editing first"
Exit Sub
End If
Dim pEL As IEditLayers
Set pEL = pEditor
If pEL.CurrentLayer.FeatureClass.ShapeType <> esriGeometryPolygon Then
MsgBox "target layer must be a polygon layer"
Exit Sub
End If
If pEL.CurrentLayer.FeatureClass Is pFC Then
MsgBox "target layer cannot be " & pFC.AliasName
Exit Sub
End If
pEditor.StartOperation

Dim pFI2 As IFeatureIndex2
Set pFI2 = New FeatureIndex

Set pFI2.FeatureClass = pFC
Dim pGDS As IGeoDataset
Set pGDS = pFC
pFI2.Index Nothing, pGDS.Extent
Debug.Print "index built"
Dim pIQ2 As IIndexQuery2
Set pIQ2 = pFI2

Dim pFCur As IFeatureCursor
Set pFCur = pFC.Search(Nothing, False)

Dim pFeat As IFeature
Set pFeat = pFCur.NextFeature
Dim vIntersects As Variant
Do Until pFeat Is Nothing
pIQ2.IntersectedFeatures pFeat.Shape, vIntersects
If UBound(vIntersects) > 0 Then
WriteIntersects vIntersects, pFeat,
pEL.CurrentLayer.FeatureClass
Else
Debug.Print pFeat.OID & " touches no other features"
End If
Set pFeat = pFCur.NextFeature
Loop
pEditor.StopOperation "write overlaps"

End Sub

Sub WriteIntersects(vIntersects As Variant, _
pFeat As IFeature, pOutFC As IFeatureClass)

' write all the other features in pFeat's featureclass
' that overlap with pFeat
Dim pFC As IFeatureClass
Set pFC = pFeat.Class


Dim pIntFCur As IFeatureCursor
Set pIntFCur = pFC.GetFeatures(vIntersects, False)

Dim pIntFeat As IFeature
Set pIntFeat = pIntFCur.NextFeature
Do Until pIntFeat Is Nothing
If pIntFeat.OID <> pFeat.OID Then
Dim pTopoOp2 As ITopologicalOperator2
Set pTopoOp2 = pFeat.Shape
pTopoOp2.IsKnownSimple = False
pTopoOp2.Simplify

' just because they intersect doesn't mean they
' overlap ... so test that here
Dim pIntGeom As IGeometry
Set pIntGeom = pTopoOp2.Intersect(pIntFeat.Shape,
esriGeometry2Dimension)
If Not pIntGeom.IsEmpty Then
If pFeat.OID < pIntFeat.OID Then
Dim pTopoOp As ITopologicalOperator
Set pTopoOp = pFeat.ShapeCopy
pTopoOp2.IsKnownSimple = False
pTopoOp2.Simplify
Dim pNewFeat As IFeature
Set pNewFeat = pOutFC.CreateFeature
Set pNewFeat.Shape = _
pTopoOp.Intersect(pIntFeat.Shape,
esriGeometry2Dimension)
pNewFeat.Store
End If
End If
Else
' of course a feature intersects itself
End If
Set pIntFeat = pIntFCur.NextFeature
Loop
End Sub

Gruß
Semy.