CAD VBA 绘制一般棱台

'**********************************************************************************************

'绘制圆台***********************************************绘制圆台*********************************
'    PA------A1-------PB
'     |                   |
'     B1                B1
'     |                   |
'    PC------A1-------PD
'

Sub DrawLT()
    Dim A1 As Double, B1 As Double, A2 As Double, B2 As Double, H As Double
    On Error GoTo ex:
    '输入棱台的尺寸
    ThisDrawing.Utility.InitializeUserInput 1, ""
    A1 = ThisDrawing.Utility.GetReal("棱台底面长(A1):")
    ThisDrawing.Utility.InitializeUserInput 1, ""
    B1 = ThisDrawing.Utility.GetReal("棱台底面宽(B1):")
    ThisDrawing.Utility.InitializeUserInput 1, ""
    A2 = ThisDrawing.Utility.GetReal("棱台顶面长(A2):")
    ThisDrawing.Utility.InitializeUserInput 1, ""
    B2 = ThisDrawing.Utility.GetReal("棱台顶面宽(B2):")
    ThisDrawing.Utility.InitializeUserInput 1, ""
    H = ThisDrawing.Utility.GetReal("棱台高(H):")
    Dim PO As Variant
    ThisDrawing.Utility.InitializeUserInput 1, ""
    PO = ThisDrawing.Utility.GetPoint(, "指定基点:  ")

    '计算棱台的八个角点的坐标
    Dim PA(2) As Double, PB(2) As Double, PC(2) As Double, PD(2) As Double
    Dim PE(2) As Double, PF(2) As Double, PG(2) As Double, PH(2) As Double
    PA(0) = 0 + PO(0):    PA(1) = 0 + PO(1):     PA(2) = 0 + PO(2)
    PB(0) = A1 + PO(0):   PB(1) = 0 + PO(1):     PB(2) = 0 + PO(2)
    PC(0) = 0 + PO(0):    PC(1) = 0 + PO(1):     PC(2) = B1 + PO(2)
    PD(0) = A1 + PO(0):   PD(1) = 0 + PO(1):     PD(2) = B1 + PO(2)
    PE(0) = (A1 - A2) / 2 + PO(0):      PE(1) = H + PO(1):    PE(2) = (B1 - B2) / 2 + PO(2)
    PF(0) = (A1 - A2) / 2 + A2 + PO(0): PF(1) = H + PO(1):    PF(2) = (B1 - B2) / 2 + PO(2)
    PG(0) = (A1 - A2) / 2 + PO(0):      PG(1) = H + PO(1):    PG(2) = (B1 - B2) / 2 + B2 + PO(2)
    PH(0) = (A1 - A2) / 2 + A2 + PO(0): PH(1) = H + PO(1):    PH(2) = (B1 - B2) / 2 + B2 + PO(2)

    ' ThisDrawing.ModelSpace.AddPoint PA
    ' ThisDrawing.ModelSpace.AddPoint PB
    ' ThisDrawing.ModelSpace.AddPoint PC
    ' ThisDrawing.ModelSpace.AddPoint PD
    ' ThisDrawing.ModelSpace.AddPoint PE
    ' ThisDrawing.ModelSpace.AddPoint PF
    ' ThisDrawing.ModelSpace.AddPoint PG
    ' ThisDrawing.ModelSpace.AddPoint PH
    '找出五个尺寸中最大的一个,用来绘制正方体
    Dim Max As Double
    Max = 0
    If A1 > Max Then Max = A1
    If B1 > Max Then Max = B1
    If A2 > Max Then Max = A2
    If B2 > Max Then Max = B2
    If H > Max Then Max = H

    '绘制的正方体中心
    Dim PO_1(2) As Double
    PO_1(0) = PO(0) + A1 / 2: PO_1(1) = PO(1) + H / 2: PO_1(2) = PO(2) + B1 / 2
    '绘制正方体，之所以绘制出个最大尺寸的正方，而不是长方体。是因为WPS和UPS坐标的问题，容易出现棱台的八个点不在长方体内。
    Dim xRecTangle As Acad3DSolid
    Set xRecTangle = ThisDrawing.ModelSpace.AddBox(PO_1, Max, Max, Max)
    '按照的八个顶点做成的六个面分别剖切正方体，从而生成一个棱台。
    Dim SliceObj1 As Acad3DSolid, SliceObj2 As Acad3DSolid ', SliceObj3 As Acad3DSolid, SliceObj4 As Acad3DSolid
    Set SliceObj1 = xRecTangle.SliceSolid(PA, PB, PE, True)
    xRecTangle.Delete
    Set SliceObj2 = SliceObj1.SliceSolid(PA, PC, PE, True)
    SliceObj2.Delete
    Set SliceObj2 = SliceObj1.SliceSolid(PC, PD, PH, True)
    SliceObj2.Delete
    Set SliceObj2 = SliceObj1.SliceSolid(PB, PD, PH, True)
    SliceObj1.Delete
    Set SliceObj1 = SliceObj2.SliceSolid(PA, PB, PC, True)
    SliceObj1.Delete
    Set SliceObj1 = SliceObj2.SliceSolid(PE, PF, PG, True)
    SliceObj2.Delete
    Exit Sub
ex:
    ThisDrawing.Utility.Prompt Err.Description
    Err.Clear
    Exit Sub
End Sub