|
|
先忙代码是图片1的，图片2的代码改怎么写
Public Sub Sub3DObjWithUCS()
Documents.Add
'创建一个正方体实体
Dim objBox As Acad3DSolid
Dim lenOfBox As Double, widthOfBox As Double, heightOfBox As Double
Dim cenPntOfBox(0 To 2) As Double
cenPntOfBox(0) = 100: cenPntOfBox(1) = 100: cenPntOfBox(2) = 50
lenOfBox = 100: widthOfBox = 100: heightOfBox = 100
Set objBox = ThisDrawing.ModelSpace.AddBox(cenPntOfBox, lenOfBox, widthOfBox, heightOfBox)
'以该正方体顶面中心为原点，建立一个用户坐标系
Dim ucs As AcadUCS
Dim origin(0 To 2) As Double
Dim xA(0 To 2) As Double
Dim yA(0 To 2) As Double
origin(0) = cenPntOfBox(0): origin(1) = cenPntOfBox(1): origin(2) = cenPntOfBox(2) + heightOfBox / 2
xA(0) = origin(0) + 1: xA(1) = origin(1): xA(2) = origin(2)
yA(0) = origin(0): yA(1) = origin(1) + 1: yA(2) = origin(2)
Set ucs = ThisDrawing.UserCoordinateSystems.Add(origin, xA, yA, "MYUCS")
ThisDrawing.ActiveUCS = ucs
Dim ucsMat As Variant
ucsMat = ucs.GetUCSMatrix
'在该用户坐标系中创建一个球体
Dim objSphere As Acad3DSolid
Dim sphCenPnt(0 To 2) As Double
Dim sphRadius As Double
sphCenPnt(0) = 0: sphCenPnt(1) = 0: sphCenPnt(2) = 0
sphRadius = 45
Set objSphere = ThisDrawing.ModelSpace.AddSphere(sphCenPnt, sphRadius)
objSphere.TransformBy ucsMat
'改变视口的观测方向
Dim newDir(0 To 2) As Double
newDir(0) = 1: newDir(1) = -1: newDir(2) = 1
ThisDrawing.ActiveViewport.Direction = newDir
ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport
ZoomExtents
ThisDrawing.Regen acActiveViewport
ThisDrawing.SendCommand "shademode G "
MsgBox "将进行差集操作..."
'进行差集运算
objBox.Boolean acSubtraction, objSphere
objBox.Color = acCyan
End Sub
|
-
图片1
-
图片2
|
