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