cad vba 拉伸面域成四面体

Private Sub 正4面体()

    Dim n As Integer
    n = ThisDrawing.ModelSpace.Count
    '当前模型空间的对象数

    Dim L As Double
    L = InputBox("请输入正4面体的棱长", , "100")          '1、画原点为中心画等边三角形         Dim p(5) As Double
    p(0) = -0.5 * L: p(1) = -0.5 * L / Sqr(3)
    p(2) = 0.5 * L: p(3) = -0.5 * L / Sqr(3)
    p(4) = 0: p(5) = L / Sqr(3)
    Dim pLine(0) As AcadEntity
    Set pLine(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(p)
    pLine(0).Closed = True
    '2、创建面域     Dim reg As Variant
    reg = ThisDrawing.ModelSpace.AddRegion(pLine)
    pLine(0).Delete                          '删除三角形
    '3、拉伸面域
    Dim Angle As Double, h As Double
    Angle = Atn(1 / Sqr(8))
    h = L * Sqr(2 / 3)
    Dim Solid As Acad3DSolid
    Set Solid = ThisDrawing.ModelSpace.AddExtrudedSolid(reg(0), h, Angle)                       '4、删除已无用的面域
    Dim Ent As AcadEntity
    If ThisDrawing.ModelSpace.Count > n Then
        Set Ent = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 2)
        Ent.Delete
    End If          '5、更改视口的观察方向

    Dim NewDirection(0 To 2) As Double
    NewDirection(0) = 1
    NewDirection(1) = 1
    NewDirection(2) = 0.5

    ThisDrawing.ActiveViewport.Direction = NewDirection
    ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport

    ZoomExtents
 End Sub