vba buffer rectangle 矩形外边框

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