Problem: 当使用属性字段值做为缓冲距离时ArcMap缓冲结果不正确

错误信息：
在ArcMap缓冲区生成向导中，可以使用属性字段值做为缓冲距离。当使用“基于属性值做为缓冲距离”（Based on a distance from an attribute）选项时，结果有时并不正确。
原因： 当对多点要素进行缓冲，并以属性值做为缓冲距离时就会出现该问题。只有多点中的一个点被缓冲。

解决方法：
对多点进行缓冲，并使用属性值做为缓冲距离时，需要先创建一个临时的单点类型图层而非多点类型。使用VBA宏把要进行缓冲的多点要素图层中的要素拆分到临时创建的单点类型图层中。该宏创建了一个新的图层——原先的多点类型图层并没有收到影响。对新创建的单点类型图层进行缓冲。 1. 把如下VBA代码粘贴到ArcMap中。 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. Check that the shapefile specified doesn't already exist."
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
查看ArcMap在线帮助“Creating, editing, and running macros”查看更详细信息。
2. 在内容列表中选择要缓冲的图层。
3. 运行Explode宏。
4. 结果将和选中的要素图层保存在相同的数据集中，如果选中的是shapefile图层，则结果将和其保存在同一目录下。
5. 对拆解后的图层进行缓冲，并选择属性字段值做为换充值。
6. 删除拆解后的结果图层。


创建时间：2002-04-09
最近更新： 2010-06-17


【原文链接】
http://support.esrichina.com.cn/2002/0409/756.html