Die Ergebnisse des Puffers in ArcMap sind nicht korrekt wenn der Pufferabstand ein Attributwert ist

Beschreibung

Attributwerte können in dem Assistent zur Puffererzeugung in ArcMap als Pufferabstände verwendet werden. Bei der Verwendung der Option "Based on a distance from an attribute" sind die Ergebnisse manchmal nicht korrekt.

Ursache

Dies ist ein bekanntes Problem bei der Multipoint-Pufferung, wenn die Attributwerte als Pufferabstand verwendet werden. Nur einer der Punkte in der Multipoint-Gruppe wird gepuffert.

Lösung oder Problemumgehung

Um Multipoints unter Verwendung von Attributwerten zu puffern, müssen Sie zunächst einen temporären Layer erstellen, der aus Einzelpunkten gebildet wird, statt aus Multipoints. Sie können ein VBA-Makro verwenden, um die Multipoint-Features von dem Layer zu trennen, den Sie in seinen individuellen Punkt-Features puffern möchten. Das Makro erstellt einen neuen Layer – der ursprüngliche Multipoint-Layer bleibt unberührt. Sie können dann den neuen Punkt-Layer puffern.

1. Fügen Sie den folgenden VBA-Code in ArcMap ein.

Public Sub Explode() Dim pClone As IClone Dim pDataset As IDataset Dim pFeature As IFeature Dim pFeatureClass As IFeatureClass Dim pFeatureCursor As IFeatureCursor Dim pFeatureLayer As IFeatureLayer Dim pFeatureWorkspace As IFeatureWorkspace Dim pFields As IFields Dim pGeometryColl As IGeometryCollection Dim pInsertFeatureBuffer As IFeatureBuffer Dim pInsertFeatureCursor As IFeatureCursor Dim pMxDoc As IMxDocument Dim pNewFeatureClass As IFeatureClass Dim pPolygon As IPolygon2 Dim pPolygonArray() As IPolygon Dim strNewFeatureClassName As String Dim GeometryCount As Integer Dim lShapeFieldIndex As Long On Error GoTo ErrorHandler Set pMxDoc = Application.Document 'Make certain the selected item in the toc is a feature layer If pMxDoc.SelectedItem Is Nothing Then MsgBox "Select a feature layer in the table of contents as the input feature class." Exit Sub End If If Not TypeOf pMxDoc.SelectedItem Is IFeatureLayer Then MsgBox "No feature layer selected." Exit Sub End If Set pFeatureLayer = pMxDoc.SelectedItem Set pFeatureClass = pFeatureLayer.FeatureClass 'Don't process point layers, they have no multi-part features If pFeatureClass.ShapeType = esriGeometryPoint Then MsgBox "Point layers do not have multi-parts. Exiting." Exit Sub End If strNewFeatureClassName = InputBox("Enter New Shapefile name:", "New Shapefile") If strNewFeatureClassName = "" Then Exit Sub 'Create a new feature class to store the new features 'Create the feature class in the same dataset if one exists - shapefiles don't have one Set pFields = pFeatureLayer.FeatureClass.Fields If pFeatureClass.FeatureDataset Is Nothing Then Set pDataset = pFeatureClass Set pFeatureWorkspace = pDataset.Workspace Set pNewFeatureClass = pFeatureWorkspace.CreateFeatureClass(strNewFeatureClassName, pFields, Nothing, Nothing, esriFTSimple, pFeatureClass.ShapeFieldName, "") Else Set pNewFeatureClass = pFeatureClass.FeatureDataset.CreateFeatureClass(strNewFeatureClassName, pFields, Nothing, Nothing, esriFTSimple, pFeatureClass.ShapeFieldName, "") End If 'Create an insert cursor Set pInsertFeatureCursor = pNewFeatureClass.Insert(True) Set pInsertFeatureBuffer = pNewFeatureClass.CreateFeatureBuffer 'Copy each feature from the original feature class to the new feature class Set pFeatureCursor = pFeatureClass.Search(Nothing, True) Set pFeature = pFeatureCursor.NextFeature Do While Not pFeature Is Nothing Set pGeometryColl = pFeature.Shape If pGeometryColl.GeometryCount = 1 Then 'Single part feature, straight copy InsertFeature pInsertFeatureCursor, pInsertFeatureBuffer, pFeature, pFeature.Shape ElseIf pFeature.Shape.GeometryType = esriGeometryPolygon Then Set pPolygon = pFeature.Shape ReDim pPolygonArray(pPolygon.ExteriorRingCount) pPolygon.GetConnectedComponents pPolygon.ExteriorRingCount, pPolygonArray(0) For GeometryCount = 0 To pPolygon.ExteriorRingCount - 1 InsertFeature pInsertFeatureCursor, pInsertFeatureBuffer, pFeature, pPolygonArray(GeometryCount) Next GeometryCount Else 'Multipart feature, create a new feature from each part For GeometryCount = 0 To pGeometryColl.GeometryCount - 1 InsertFeature pInsertFeatureCursor, pInsertFeatureBuffer, pFeature, pGeometryColl.Geometry(GeometryCount) Next GeometryCount End If 'Get the next feature Set pFeature = pFeatureCursor.NextFeature Loop Exit Sub 'Exit sub to avoid error handler ErrorHandler: MsgBox "An error occurred. Stellen Sie sicher, dass das angegebene Shapefile noch nicht vorhanden ist." Exit Sub End Sub Private Sub InsertFeature(pInsertFeatureCursor As IFeatureCursor, pInsertFeatureBuffer As IFeatureBuffer, pOrigFeature As IFeature, pGeometry As IGeometry) Dim pGeometryColl As IGeometryCollection Dim pFields As IFields Dim pField As IField Dim pPoint As IPoint Dim pPointColl As IPointCollection Dim FieldCount As Integer 'Copy the attributes of the orig feature the new feature Set pFields = pOrigFeature.Fields For FieldCount = 0 To pFields.FieldCount - 1 'skip OID and geometry Set pField = pFields.Field(FieldCount) If Not pField.Type = esriFieldTypeGeometry And Not pField.Type = esriFieldTypeOID _ And pField.Editable Then pInsertFeatureBuffer.Value(FieldCount) = pOrigFeature.Value(FieldCount) End If Next FieldCount 'Handle cases where parts are passed down If pGeometry.GeometryType = esriGeometryPath Then Set pGeometryColl = New Polyline pGeometryColl.AddGeometries 1, pGeometry Set pGeometry = pGeometryColl ElseIf pGeometry.GeometryType = esriGeometryRing Then Set pGeometryColl = New Polygon pGeometryColl.AddGeometries 1, pGeometry Set pGeometry = pGeometryColl ElseIf pOrigFeature.Shape.GeometryType = esriGeometryMultipoint Then If TypeOf pGeometry Is IMultipoint Then Set pPointColl = pGeometry Set pGeometry = pPointColl.Point(0) End If Set pGeometryColl = New Multipoint pGeometryColl.AddGeometries 1, pGeometry Set pGeometry = pGeometryColl End If Set pInsertFeatureBuffer.Shape = pGeometry pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer pInsertFeatureCursor.Flush End Sub

Hinweis: Weitere Informationen finden Sie in dem ArcMap Online-Hilfethema "Creating, editing, and running macros".

2. Wählen Sie den Layer, den Sie puffern möchten, im Inhaltsverzeichnis aus.
3. Führen Sie das Makro "Explode" aus.
4. Das Ergebnis wird in demselben Dataset wie die ausgewählten Features gespeichert, oder im selben Verzeichnis wie das Shapefile, wenn der ausgewählte Layer ein Shapefile ist.
5. Puffern Sie das Ergebnis der Trennung mit einem Attribut als Pufferabstand.
6. Löschen Sie den Ergebnislayer der Trennung.