Private Sub CommandButton1_Click()
bufferrectangle
End Sub
Sub bufferrectangle()
Dim pMxDoc As IMxDocument
Set pMxDoc = Application.Document
Dim pMap As IMap
Set pMap = pMxDoc.FocusMap
Dim pActiveView As IActiveView
Set pActiveView = pMxDoc.FocusMap
Dim pFeatureClassOne As IFeatureClass
Dim pFLayerOne As IFeatureLayer
Dim pFeatureClassTwo As IFeatureClass
Dim pFLayerTwo As IFeatureLayer
Dim pFeatureClassNew As IFeatureClass
Dim pFLayerNew As IFeatureLayer
Set pFLayerOne = pMap.Layer(0)
Set pFeatureClassOne = pFLayerOne.FeatureClass
Dim pFeatureCursorOne As IFeatureCursor
Set pFeatureCursorOne = pFeatureClassOne.Search(Nothing, True)
Dim pFeatureOne As IFeature
Set pFeatureOne = pFeatureCursorOne.NextFeature
Dim xmax As Double
Dim ymax As Double
Dim xmin As Double
Dim ymin As Double
Dim pPolygonOne As IPolygon
Dim pPolygonNew As IPolygon
Dim pOnePoints As IPointCollection
Dim pNewPoints As IPointCollection
Dim i As Integer
Dim count As Integer
count = 0
Dim pNewPoint As IPoint
Dim distance As Double
distance = CDbl(TextBox1.Text)
While Not pFeatureOne Is Nothing
Set pPolygonOne = pFeatureOne.Shape
Set pOnePoints = pPolygonOne
For i = 0 To pOnePoints.PointCount - 1
xmax = findxmax(pOnePoints)
ymax = findymax(pOnePoints)
xmin = findxmin(pOnePoints)
ymin = findymin(pOnePoints)
Set pNewPoints = New Polygon
Set pNewPoint = New Point
pNewPoint.X = xmin - distance
pNewPoint.Y = ymax + distance
pNewPoints.AddPoint pNewPoint
Set pNewPoint = New Point
pNewPoint.X = xmax + distance
pNewPoint.Y = ymax + distance
pNewPoints.AddPoint pNewPoint
Set pNewPoint = New Point
pNewPoint.X = xmax + distance
pNewPoint.Y = ymin - distance
pNewPoints.AddPoint pNewPoint
Set pNewPoint = New Point
pNewPoint.X = xmin - distance
pNewPoint.Y = ymin - distance
pNewPoints.AddPoint pNewPoint
Next i
Set pPolygonNew = pNewPoints
pPolygonNew.Close
Set pFeatureOne.Shape = pPolygonNew
pFeatureOne.Store
Set pFeatureOne = pFeatureCursorOne.NextFeature
count = count + 1
Label3.Caption = Str(count) & "个feature"
UserForm1.Repaint
Wend
MsgBox "done!"
End Sub
Public Function findxmax(points As IPointCollection) As Double
Dim xmax As Double
Dim ppoint As IPoint
Dim i As Integer
Set ppoint = points.Point(0)
xmax = ppoint.X
For i = 1 To points.PointCount - 1
Set ppoint = points.Point(i)
If xmax < ppoint.X Then
xmax = ppoint.X
End If
Next i
findxmax = xmax
End Function
Public Function findymax(points As IPointCollection) As Double
Dim ymax As Double
Dim ppoint As IPoint
Dim i As Integer
Set ppoint = points.Point(0)
ymax = ppoint.Y
For i = 1 To points.PointCount - 1
Set ppoint = points.Point(i)
If ymax < ppoint.Y Then
ymax = ppoint.Y
End If
Next i
findymax = ymax
End Function
Public Function findxmin(points As IPointCollection) As Double
Dim xmin As Double
Dim ppoint As IPoint
Dim i As Integer
Set ppoint = points.Point(0)
xmin = ppoint.X
For i = 1 To points.PointCount - 1
Set ppoint = points.Point(i)
If xmin > ppoint.X Then
xmin = ppoint.X
End If
Next i
findxmin = xmin
End Function
Public Function findymin(points As IPointCollection) As Double
Dim ymin As Double
Dim ppoint As IPoint
Dim i As Integer
Set ppoint = points.Point(0)
ymin = ppoint.Y
For i = 1 To points.PointCount - 1
Set ppoint = points.Point(i)
If ymin > ppoint.Y Then
ymin = ppoint.Y
End If
Next i
findymin = ymin
End Function
