Private Sub CommandButton1_Click()
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 pFeatureClass As IFeatureClass
Dim pFLayer As IFeatureLayer
Set pFLayer = pMap.Layer(0)
Set pFeatureClass = pFLayer.FeatureClass
Dim pFeatureCursor As IFeatureCursor
Set pFeatureCursor = pFeatureClass.Search(Nothing, True)
Dim totalcount As Integer
totalcount = pFeatureClass.FeatureCount(Nothing)
Dim pFeature As IFeature
Set pFeature = pFeatureCursor.NextFeature
Dim xmax As Double
Dim ymax As Double
Dim xmin As Double
Dim ymin As Double
Dim pPoint As IPoint
Dim pPolygon As IPolygon
Dim pArea As IArea
Dim pNewPolygon As IPolygon
Dim pNewPoints As IPointCollection
Dim pNewPoint As IPoint
Dim count As Integer
count = 0
Dim xdistance As Double
xdistance = CDbl(TextBox1.Text)
Dim ydistance As Double
ydistance = CDbl(TextBox2.Text)
While Not pFeature Is Nothing
Set pPolygon = pFeature.Shape
Set pArea = pPolygon
Set pPoint = pArea.Centroid
xmax = pPoint.X + xdistance
ymax = pPoint.Y + ydistance
xmin = pPoint.X - xdistance
ymin = pPoint.Y - ydistance
Set pNewPoints = New Polygon
Set pNewPoint = New Point
pNewPoint.X = xmin
pNewPoint.Y = ymax
pNewPoints.AddPoint pNewPoint
Set pNewPoint = New Point
pNewPoint.X = xmax
pNewPoint.Y = ymax
pNewPoints.AddPoint pNewPoint
Set pNewPoint = New Point
pNewPoint.X = xmax
pNewPoint.Y = ymin
pNewPoints.AddPoint pNewPoint
Set pNewPoint = New Point
pNewPoint.X = xmin
pNewPoint.Y = ymin
pNewPoints.AddPoint pNewPoint
Set pNewPolygon = pNewPoints
pNewPolygon.Close
Set pFeature.Shape = pNewPolygon
pFeature.Store
Set pFeature = pFeatureCursor.NextFeature
count = count + 1
Label1.Caption = "第" & count & "个" & " / " & "共计：" & totalcount
UserForm1.Repaint
Wend
MsgBox "done!"
End Sub
————————————————————————————————————————————————————
Sub point2polygon()
UserForm1.Show
End Sub
