[求助]：请各位大虾帮忙看看错在哪里 该怎么修改 急~~

120010139

小弟初学VBA不久,最近做了一个练习.这个程序的目的可以实现CAD图中实体变成三视图

但小弟在运行过程中老是出错,请教各位大虾帮帮忙!!谢谢了!!!!

Sub 三视图显示()

'俯视显示视图
ThisDrawing.SendCommand ("_-view" + vbCr + "_top" + vbCr)

'找出图中齿轮实体
Dim returnObj As Object
Dim Obj3D As Boolean

For Each returnObj In ThisDrawing.ModelSpace
    If returnObj.ObjectName = "AcDb3dsolid" Then
    Obj3D = True
    Exit For
    End If
Next

'若图中无齿轮实体，退出过程
If Obj3D = False Then
   MsgBox "图中无齿轮实体", vbOKOnly, "重要提示!"
   Exit Sub
End If

'获取包含实体外框的最大、最小点坐标
Dim minExt As Variant
Dim maxExt As Variant

returnObj.GetBoundingBox minExt, maxExt

'将齿轮实体复制3份
Dim returnObjLeft As Object '左视图
Dim returnObjTop As Object '俯视图
Dim returnObjSouthWest As Object '轴测视图

Set returnObjLeft = returnObj.Copy
Set returnObjTop = returnObj.Copy
Set returnObjSouthWest = returnObj.Copy

'生成左视图
Dim pt1(2), pt2(2) As Double
pt1(0) = (minExt(0) + maxExt(0)) / 2: pt1(1) = (minExt(1) + maxExt(1)) / 2: pt1(2) = _
(minExt(2) + maxExt(2)) / 2
pt2(0) = pt1(0): pt2(1) = pt1(1) + 1: pt2(2) = pt1(2)

'旋转90度得左视图
returnObjLeft.Rotate3D pt1, pt2, 3.1415 / 2

Dim ScaleD As Double '放大视图间的距离
ScaleD = 1.2

pt1(0) = (minExt(0) + maxExt(0)) / 2: pt1(1) = (minExt(1) + maxExt(1)) / 2: pt1(2) = _
(minExt(2) + maxExt(2)) / 2
pt2(0) = pt1(0) + (maxExt(0) - minExt(0)) * ScaleD: pt2(1) = pt1(1): pt2(2) = pt1(2)

'向右移动左视图
returnObjLeft.Move pt1, pt2

'生成俯视图
pt1(0) = (minExt(0) + maxExt(0)) / 2: pt1(1) = (minExt(1) + maxExt(1)) / 2: pt1(2) = _
(minExt(2) + maxExt(2)) / 2
pt2(0) = pt1(0) + 1: pt2(1) = pt1(1): pt2(2) = pt1(2)

'旋转90度得俯视图
returnObjTop.Rotate3D pt1, pt2, 3.1415 / 2

pt1(0) = (minExt(0) + maxExt(0)) / 2: pt1(1) = (minExt(1) + maxExt(1)) / 2: pt1(2) = _
(minExt(2) + maxExt(2)) / 2
pt2(0) = pt1(0): pt2(1) = pt1(1) - (maxExt(0) - minExt(0)) * ScaleD: pt2(2) = pt1(2)

'向下移动俯视图
returnObjTop.Move pt1, pt2

'生成轴测视图
pt1(0) = (minExt(0) + maxExt(0)) / 2: pt1(1) = (minExt(1) + maxExt(1)) / 2: pt1(2) = _
(minExt(2) + maxExt(2)) / 2
pt2(0) = pt1(0) + 1: pt2(1) = pt1(1): pt2(2) = pt1(2)

'旋转45度
returnObjSouthWest.Rotate3D pt1, pt2, -3.1415 / 4

pt1(0) = (minExt(0) + maxExt(0)) / 2: pt1(1) = (minExt(1) + maxExt(1)) / 2: pt1(2) = _
(minExt(2) + maxExt(2)) / 2
pt2(0) = pt1(0): pt2(1) = pt1(1) + 1: pt2(2) = pt1(2)

'旋转45度
returnObjSouthWest.Rotate3D pt1, pt2, -3.1415 / 4

pt1(0) = (minExt(0) + maxExt(0)) / 2: pt1(1) = (minExt(1) + maxExt(1)) / 2: pt1(2) = _
(minExt(2) + maxExt(2)) / 2
pt2(0) = pt1(0) + (maxExt(0) - minExt(0)) * ScaleD: pt2(1) = pt1(1) - (maxExt(1) - _
minExt(1)) * ScaleD: pt2(2) = pt1(2)

'向右下移动轴测视图
returnObjSouthWest.Move pt1, pt2

'三点定义左视图的剖切平面
Dim slicePt1(2) As Double
Dim slicePt2(2) As Double
Dim slicePt3(2) As Double

slicePt1(0) = (minExt(0) + maxExt(0)) / 2: slicePt1(1) = (minExt(1) + maxExt(1)) / 2: _
slicePt1(2) = (minExt(2) + maxExt(2)) / 2
slicePt2(0) = slicePt1(0): slicePt2(1) = slicePt1(1) + 1: slicePt2(2) = slicePt1(2)
slicePt3(0) = slicePt1(0) + 1: slicePt3(1) = slicePt1(1): slicePt3(2) = slicePt1(2)

'剖切左视图
Dim sliceObj As AutoCAD.Acad3DSolid
Set sliceObj = returnObjLeft.SliceSolid(slicePt1, slicePt2, slicePt3, True)
returnObjLeft.Delete '删除returnObjLeft,余下剖切图

ThisDrawing.SendCommand ("_Shademode" + vbCr + "_G" + vbCr) '着色

ThisDrawing.Application.ZoomExtents
End Sub

misters

up，关注！

zt17

学习VBA有什么窍门吗