vba create rectangle 矩形

Sub createrectangle()

Dim pWorkspaceFactory As IWorkspaceFactory
Set pWorkspaceFactory = New ShapefileWorkspaceFactory
Dim pFeatureWorkspace As IFeatureWorkspace
Set pFeatureWorkspace = _
pWorkspaceFactory.OpenFromFile("D:\数据\2222", 0)
Dim pFeatureClass As IFeatureClass
Set pFeatureClass = pFeatureWorkspace.OpenFeatureClass("text2")

Dim XY(8, 4, 2) As Double

XY(0, 0, 0) = 145#
XY(0, 0, 1) = 50#
XY(0, 1, 0) = 200#
XY(0, 1, 1) = 50#
XY(0, 2, 0) = 200#
XY(0, 2, 1) = 30#
XY(0, 3, 0) = 145#
XY(0, 3, 1) = 30#

XY(1, 0, 0) = 130#
XY(1, 0, 1) = 20#
XY(1, 1, 0) = 200#
XY(1, 1, 1) = 20
XY(1, 2, 0) = 200#
XY(1, 2, 1) = -20#
XY(1, 3, 0) = 130#
XY(1, 3, 1) = -20#

XY(2, 0, 0) = -150#
XY(2, 0, 1) = 10#
XY(2, 1, 0) = -80#
XY(2, 1, 1) = 10#
XY(2, 2, 0) = -80#
XY(2, 2, 1) = -20#
XY(2, 3, 0) = -150#
XY(2, 3, 1) = -20#

XY(3, 0, 0) = -140#
XY(3, 0, 1) = -20#
XY(3, 1, 0) = -75#
XY(3, 1, 1) = -20#
XY(3, 2, 0) = -75#
XY(3, 2, 1) = -50#
XY(3, 3, 0) = -140#
XY(3, 3, 1) = -50#

XY(4, 0, 0) = -70#
XY(4, 0, 1) = -25#
XY(4, 1, 0) = -40#
XY(4, 1, 1) = -25#
XY(4, 2, 0) = -40#
XY(4, 2, 1) = -55#
XY(4, 3, 0) = -70#
XY(4, 3, 1) = -55#

XY(5, 0, 0) = -50#
XY(5, 0, 1) = 30#
XY(5, 1, 0) = 0#
XY(5, 1, 1) = 30#
XY(5, 2, 0) = 0#
XY(5, 2, 1) = -30#
XY(5, 3, 0) = -50#
XY(5, 3, 1) = -30#

XY(6, 0, 0) = 40#
XY(6, 0, 1) = 15#
XY(6, 1, 0) = 95#
XY(6, 1, 1) = 15#
XY(6, 2, 0) = 95#
XY(6, 2, 1) = -15#
XY(6, 3, 0) = 40#
XY(6, 3, 1) = -15#

XY(7, 0, 0) = 105#
XY(7, 0, 1) = 50#
XY(7, 1, 0) = 145#
XY(7, 1, 1) = 50#
XY(7, 2, 0) = 145#
XY(7, 2, 1) = 10#
XY(7, 3, 0) = 105#
XY(7, 3, 1) = 10#


Dim pColl As IPointCollection4
Dim pPoint As IPoint
Dim pPoly As IPolygon4

For i = 0 To 7

Set pColl = New Polygon

For j = 0 To 3

Set pPoint = New Point
pPoint.PutCoords XY(i, j, 0), XY(i, j, 1)
pColl.AddPoint pPoint

Next j


Set pPoly = pColl
pPoly.Close

Dim pFeature As IFeature
Set pFeature = pFeatureClass.CreateFeature

Set pFeature.Shape = pPoly
pFeature.Store

Next i

End Sub