Как создать коробку в VBA

Option Explicit
Public ptArr As Variant
Public kword As String
Public Wid As Double
Public Leng As Double
Public Hgt As Double
Public Thk As Double
Public retPnt As Variant
Private Sub CommandButton1_Click()
Dim Space As AcadBlock
Dim objRect1 As AcadLWPolyline
Dim objRect2 As AcadLWPolyline
Dim objRegion1 As AcadRegion
Dim objRegion2 As AcadRegion
Dim objSolid1 As Acad3DSolid
Dim objSolid2 As Acad3DSolid
Me.Hide
On Error Resume Next
If Err = 0 Then
If ThisDrawing.ActiveSpace = acModelSpace Then
Set Space = ThisDrawing.ModelSpace
Else
Set Space = ThisDrawing.PaperSpace
End If
kword = vbCr & "Specify center point of box:"
retPnt = Get_Point(kword)
Leng = CDbl(txtLength.Text)
Wid = CDbl(txtWidth.Text)
Hgt = CDbl(txtHeight.Text)
Thk = CDbl(txtThikness.Text)
txtLength.Text = ""
txtWidth.Text = ""
ptArr = Middle_Center_Points(retPnt, Leng, Wid)
Dim regObj1 As Variant
Dim objArr1(0) As AcadEntity
Set objRect1 = Draw_Rectang(Space, ptArr)
Set objArr1(0) = objRect1
regObj1 = Space.AddRegion(objArr1)
Set objSolid1 = Space.AddExtrudedSolid(regObj1(0), Hgt, 0#)
ptArr = Middle_Center_Points(retPnt, Leng - (Thk * 2), Wid - (Thk * 2))
Dim regObj2 As Variant
Dim objArr2(0) As AcadEntity
Set objRect2 = Draw_Rectang(Space, ptArr)
objRect2.Elevation = Thk
Set objArr2(0) = objRect2
regObj2 = Space.AddRegion(objArr2)
Set objSolid2 = Space.AddExtrudedSolid(regObj2(0), Hgt - Thk, 0#)
objSolid1.Boolean acSubtraction, objSolid2
objRect1.Delete
objRect2.Delete
regObj1(0).Delete
regObj2(0).Delete
ZoomAll
End If
CommandButton2.SetFocus
CommandButton2.ForeColor = &H40C0&
Me.Show
End Sub
Private Sub CommandButton2_Click()
End
End Sub
Public Function Draw_Rectang(objSpace As AcadBlock, ptArr As Variant) As AcadLWPolyline
Dim oPline As AcadLWPolyline
Dim acmCol As AcadAcCmColor
Set acmCol = New AcadAcCmColor
Set oPline = objSpace.AddLightWeightPolyline(ptArr)
oPline.Closed = True
oPline.Layer = "0"
acmCol.ColorIndex = acByLayer
oPline.TrueColor = acmCol
oPline.LineType = "Continuous"
oPline.LinetypeScale = 1#
oPline.ConstantWidth = 0#
oPline.Update
Set Draw_Rectang = oPline
End Function
Function Get_Point(kword) As Variant
ThisDrawing.Utility.InitializeUserInput 128
retPnt = ThisDrawing.Utility.GetPoint(, kword)
Get_Point = retPnt
End Function
Public Function Middle_Center_Points(pickPnt As Variant, Leng As Double, Wid As Double) _
As Variant
Dim ptArr(0 To 7) As Double
Dim x As Double
Dim y As Double
x = pickPnt(0)
y = pickPnt(1)
ptArr(0) = x - Leng / 2: ptArr(1) = y - Wid / 2
ptArr(2) = x + Leng / 2: ptArr(3) = y - Wid / 2
ptArr(4) = x + Leng / 2: ptArr(5) = y + Wid / 2
ptArr(6) = x - Leng / 2: ptArr(7) = y + Wid / 2
Middle_Center_Points = ptArr
End Function

Option Explicit
Public ptArr As New Collection
Public kword As String
Public Wid As Double
Public Leng As Double
Public Hgt As Double
Public Thk As Double
Public retPnt As Variant
Public insPt(2) As Double
Dim i As Long
Sub DrawBoxCell()
Dim Space As AcadBlock
Dim obkRef As AcadBlockReference
On Error Resume Next
If Err = 0 Then
If ThisDrawing.ActiveSpace = acModelSpace Then
Set Space = ThisDrawing.ModelSpace
Else
Set Space = ThisDrawing.PaperSpace
End If
kword = vbCr & "Specify center point of box:"
retPnt = Get_Point(kword)
Leng = CDbl(InputBox("Enter box length:", "LENGTH"))
Wid = CDbl(InputBox("Enter box width:", "WIDTH"))
Hgt = CDbl(InputBox("Enter box height:", "HEIGHT"))
Thk = CDbl(InputBox("Enter wall thikness:", "THIKNESS"))
Set ptArr = Middle_Center_Points(retPnt, Leng, Wid, Thk)
insPt(0) = ptArr(1)(0): insPt(1) = ptArr(1)(1): insPt(2) = ptArr(1)(2)
Set obkRef = Space.InsertBlock(insPt, "Cub", Thk, Wid - Thk * 2, Hgt, 0#)
insPt(0) = ptArr(2)(0): insPt(1) = ptArr(2)(1): insPt(2) = ptArr(2)(2)
Set obkRef = Space.InsertBlock(insPt, "Cub", Leng, Thk, Hgt, 0#)
insPt(0) = ptArr(3)(0): insPt(1) = ptArr(3)(1): insPt(2) = ptArr(3)(2)
Set obkRef = Space.InsertBlock(insPt, "Cub", Thk, Wid - Thk * 2, Hgt, 0#)
insPt(0) = ptArr(4)(0): insPt(1) = ptArr(4)(1): insPt(2) = ptArr(4)(2)
Set obkRef = Space.InsertBlock(insPt, "Cub", Leng, Thk, Hgt, 0#)
ZoomExtents
End If
End Sub
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
Function Get_Point(kword) As Variant
ThisDrawing.Utility.InitializeUserInput 128
retPnt = ThisDrawing.Utility.GetPoint(, kword)
Get_Point = retPnt
End Function
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
Public Function Middle_Center_Points(pickPnt As Variant, Leng As Double, Wid As Double, Thik As Double) _
As Collection
Dim ptArr As New Collection
Dim tmp(2) As Double
Dim x As Double
Dim y As Double
x = pickPnt(0)
y = pickPnt(1)
tmp(0) = x + (Leng - Thik) / 2
tmp(1) = y
tmp(2) = 0#
ptArr.Add tmp
tmp(0) = x
tmp(1) = y + (Wid - Thik) / 2
tmp(2) = 0#
ptArr.Add tmp
tmp(0) = x - (Leng - Thik) / 2
tmp(1) = y
tmp(2) = 0#
ptArr.Add tmp
tmp(0) = x
tmp(1) = y - (Wid - Thik) / 2
tmp(2) = 0#
ptArr.Add tmp
Set Middle_Center_Points = ptArr
End Function