一个画管道的程序,可有点问题,大家来帮我看看啊,救命的!!!!
是通过拉伸路径来画管道的,输入两个点时能画出管道,当输入三个及三个以上的点是就有问题了,对于三个和三个以上的点的思路是这样的:1.取第一点,第二点,第三点分别赋给point1,point2,point3(在这里遇到一个问题,point1和point3的点是正确的,point2的点就不正确,不知道是为什么),
2.根据这三个点,确立用户坐标系,在用户坐标系中画出多段线,回复到WCS坐标系,
3.在point1处,生成管道的剖面,根据多段线来进行三维旋转,最后进行拉伸
基本思路就是这样,下面是程序,各位高手帮我看看哪要改,是毕业设计的东西,求助大家了
说明:p(i)是自定义类型,用来存放输入的点的XYZ坐标的
For i = 1 To (UBound(p) - 1)
point1(0) = p(i - 1).x: point1(1) = p(i - 1).y: point1(2) = p(i - 1).z
point2(0) = p(i).x: point2(0) = p(i).y: point2(2) = p(i).z
point3(0) = p(i + 1).x: point3(1) = p(i + 1).y: point3(2) = p(i + 1).z
If p(i - 1).z = p(i).z & p(i).z = p(i + 1).z Then
'设定坐标系
'定义UCS参数
UCSorigin(0) = 0:UCSorigin(1) = 0:UCSorigin(2) = p(i).z
UCS1Point(0) = 10:UCS1Point(1) = 0:UCS1Point(2) = p(i).z
UCS1Point(0) = 0:UCS1Point(1) = 10:UCS1Point(2) = p(i).z
'创建UCS
Set myUCS=ThisDrawing.UserCoordinateSystems.Add(UCSorigin,UCS1Point, UCS2Point, "新建UCS")
'设置当前UCS
ThisDrawing.ActiveUCS = myUCS
'画多段线
point5(0) = point1(0): point5(1) = point1(1)
point5(2) = point2(0): point5(3) = point2(1)
point5(4) = point3(0): point5(5) = point3(1)
Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(point5)
'回复WCS
ThisDrawing.SendCommand "UCS" & vbCr & vbCr
ElseIf p(i - 1).y = p(i).y & p(i).y = p(i + 1).y Then
'设定坐标系
'定义UCS参数
UCSorigin(0) = 0:UCSorigin(1) = p(i).y:UCSorigin(2) = 0
UCS1Point(0) = 10:UCS1Point(1) = p(i).y:UCS1Point(2) = 0
UCS2Point(0) = 0:UCS2Point(1) = p(i).y:UCS2Point(2) = 10
'创建UCS
Set myUCS = ThisDrawing.UserCoordinateSystems.Add(UCSorigin, UCS1Point, UCS2Point, "新建UCS")
'设置当前UCS
ThisDrawing.ActiveUCS = myUCS
'画多段线
point5(0) = point1(0): point5(1) = point1(2)
point5(2) = point2(0): point5(3) = point2(2)
point5(4) = point3(0): point5(5) = point3(2)
Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(point5)
'回复WCS
ThisDrawing.SendCommand "UCS" & vbCr & vbCr
ElseIf p(i - 1).x = p(i).x & p(i).x = p(i + 1).x Then
'设定坐标系
'定义UCS参数
UCSorigin(0) = p(i).x:UCSorigin(1) = 0:UCSorigin(2) = 0
UCS1Point(0) = p(i).x:UCS1Point(1) = 10:UCS1Point(2) = 0
UCS1Point(0) = p(i).x:UCS1Point(1) = 0:UCS1Point(2) = 10
'创建UCS
Set myUCS = ThisDrawing.UserCoordinateSystems.Add(UCSorigin, UCS1Point, UCS2Point, "新建UCS")
'设置当前UCS
ThisDrawing.ActiveUCS = myUCS
'画多段线
point5(0) = point1(1): point5(1) = point1(2)
point5(2) = point2(1): point5(3) = point2(2)
point5(4) = point3(1): point5(5) = point3(2)
Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(point5)
'回复WCS
ThisDrawing.SendCommand "UCS" & vbCr & vbCr
End If
'创建面域
Set circle1(0) = ThisDrawing.ModelSpace.AddCircle(point1, radius1)
Set circle2(0) = ThisDrawing.ModelSpace.AddCircle(point1, radius2)
regionObj1 = ThisDrawing.ModelSpace.AddRegion(circle1)
regionObj2 = ThisDrawing.ModelSpace.AddRegion(circle2)
'布尔运算
regionObj1(0).Boolean acSubtraction, regionObj2(0)
'三维旋转
If point1(0)point2(0) & point1(1) = point2(1) & point1(2) = point2(2) Then
point4(0) = point1(0)
point4(1) = point1(1) + 10
point4(2) = point1(2)
Set line1 = ThisDrawing.ModelSpace.AddLine(point1, point4)
regionObj1(0).Rotate3D point1, point4, rotateAngle
line1.Delete
circle1(0).Delete
circle2(0).Delete
ElseIf point1(0) = point2(0) & point1(1)point2(1) & point1(2) = point2(2) Then
point4(0) = point1(0) + 10
point4(1) = point1(1)
point4(2) = point1(2)
Set line1 = ThisDrawing.ModelSpace.AddLine(point1, point3)
regionObj1(0).Rotate3D point1, point4, rotateAngle
line1.Delete
circle1(0).Delete
circle2(0).Delete
End If
'拉伸
Set regionObj1(0) = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(regionObj1(0), polyObj)
Next i
我也在写管道的程序，我也遇到同样的问题，求高手帮忙吧~~
搞不清楚你得P怎么定义的，还有一个FOR.......Next.能不能把前面缺的那段程序也贴上，也许问题就处在你的For.......Next上。 下面是我全部的程序：
Option Explicit
Private Type POINTAPI
x As Double
y As Double
z As Double
End Type
Dim p() As POINTAPI
Private Sub UserForm_Initialize()
ReDim p(0) As POINTAPI
End Sub
Private Sub CommandButton1_Click()
p(UBound(p)).x = Val(TextBox1.Text)
p(UBound(p)).y = Val(TextBox2.Text)
p(UBound(p)).z = Val(TextBox3.Text)
ReDim Preserve p(UBound(p) + 1)
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
TextBox1.SetFocus
End Sub
Private Sub CommandButton2_Click()
'存点
p(UBound(p)).x = Val(TextBox1.Text)
p(UBound(p)).y = Val(TextBox2.Text)
p(UBound(p)).z = Val(TextBox3.Text)
' 定义变量
Dim i As Integer
Dim j As Integer
Dim rotateAngle As Double
Dim point1(0 To 2) As Double, point2(0 To 2) As Double, point3(0 To 2) As Double, point4(0 To 2) As Double
Dim point5(0 To 5) As Double
Dim circle1(0) As AcadEntity, circle2(0) As AcadEntity
Dim regionObj1 As Variant, regionObj2 As Variant
Dim radius1 As Double, radius2 As Double
Dim line1 As AcadLine
Dim solidObj As Acad3DSolid
Dim polyObj As AcadLWPolyline
Dim myUCS As AcadUCS
Dim UCSorigin(0 To 2) As Double
Dim UCS1Point(0 To 2) As Double
Dim UCS2Point(0 To 2) As Double
radius1 = 10
radius2 = 8
rotateAngle = 90 * 3.141592 / 180
i = UBound(p)
j = UBound(p) - 1
If i = 0 Then
MsgBox "请输入两个以上定位点！"
ElseIf i = 1 Then
Call AddPipeline1
Else
For i = 1 To j
point1(0) = p(i - 1).x: point1(1) = p(i - 1).y: point1(2) = p(i - 1).z
point2(0) = p(i).x: point2(0) = p(i).y: point2(2) = p(i).z
point3(0) = p(i + 1).x: point3(1) = p(i + 1).y: point3(2) = p(i + 1).z
If p(i - 1).z = p(i).z And p(i).z = p(i + 1).z Then
'设定坐标系
'定义UCS参数
UCSorigin(0) = 0:UCSorigin(1) = 0:UCSorigin(2) = p(i).z
UCS1Point(0) = 10:UCS1Point(1) = 0:UCS1Point(2) = p(i).z
UCS1Point(0) = 0:UCS1Point(1) = 10:UCS1Point(2) = p(i).z
'创建UCS
Set myUCS = ThisDrawing.UserCoordinateSystems.Add(UCSorigin, UCS1Point, UCS2Point, "新建UCS")
'设置当前UCS
ThisDrawing.ActiveUCS = myUCS
'画多段线
point5(0) = point1(0): point5(1) = point1(1)
point5(2) = point2(0): point5(3) = point2(1)
point5(4) = point3(0): point5(5) = point3(1)
Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(point5)
'回复WCS
ThisDrawing.SendCommand "UCS" & vbCr & vbCr
ElseIf p(i - 1).y = p(i).y And p(i).y = p(i + 1).y Then
'设定坐标系
'定义UCS参数
UCSorigin(0) = 0:UCSorigin(1) = p(i).y:UCSorigin(2) = 0
UCS1Point(0) = 10:UCS1Point(1) = p(i).y:UCS1Point(2) = 0
UCS2Point(0) = 0:UCS2Point(1) = p(i).y:UCS2Point(2) = 10
'创建UCS
Set myUCS = ThisDrawing.UserCoordinateSystems.Add(UCSorigin, UCS1Point, UCS2Point, "新建UCS")
'设置当前UCS
ThisDrawing.ActiveUCS = myUCS
'画多段线
point5(0) = point1(0) : point5(1) = point1(2)
point5(2) = point2(0): point5(3) = point2(2)
point5(4) = point3(0): point5(5) = point3(2)
Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(point5)
'回复WCS
ThisDrawing.SendCommand "UCS" & vbCr & vbCr
ElseIf p(i - 1).x = p(i).x And p(i).x = p(i + 1).x Then
'设定坐标系
'定义UCS参数
UCSorigin(0) = p(i).x : UCSorigin(1) = 0 : UCSorigin(2) = 0
UCS1Point(0) = p(i).x : UCS1Point(1) = 10 : UCS1Point(2) = 0
UCS1Point(0) = p(i).x : UCS1Point(1) = 0 : UCS1Point(2) = 10
'创建UCS
Set myUCS = ThisDrawing.UserCoordinateSystems.Add(UCSorigin, UCS1Point, UCS2Point, "新建UCS")
'设置当前UCS
ThisDrawing.ActiveUCS = myUCS
'画多段线
point5(0) = point1(1): point5(1) = point1(2)
point5(2) = point2(1): point5(3) = point2(2)
point5(4) = point3(1): point5(5) = point3(2)
Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(point5)
'回复WCS
ThisDrawing.SendCommand "UCS" & vbCr & vbCr
End If
'创建面域
Set circle1(0) = ThisDrawing.ModelSpace.AddCircle(point1, radius1)
Set circle2(0) = ThisDrawing.ModelSpace.AddCircle(point1, radius2)
regionObj1 = ThisDrawing.ModelSpace.AddRegion(circle1)
regionObj2 = ThisDrawing.ModelSpace.AddRegion(circle2)
'布尔运算
regionObj1(0).Boolean acSubtraction, regionObj2(0)
'三维旋转
If point1(0)point2(0) And point1(1) = point2(1) And point1(2) = point2(2) Then
point4(0) = point1(0)
point4(1) = point1(1) + 10
point4(2) = point1(2)
Set line1 = ThisDrawing.ModelSpace.AddLine(point1, point4)
regionObj1(0).Rotate3D point1, point4, rotateAngle
line1.Delete
circle1(0).Delete
circle2(0).Delete
ElseIf point1(0) = point2(0) And point1(1)point2(1) And point1(2) = point2(2) Then
point4(0) = point1(0) + 10
point4(1) = point1(1)
point4(2) = point1(2)
Set line1 = ThisDrawing.ModelSpace.AddLine(point1, point3)
regionObj1(0).Rotate3D point1, point4, rotateAngle
line1.Delete
circle1(0).Delete
circle2(0).Delete
End If
'拉伸
Set regionObj1(0) = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(regionObj1(0), polyObj)
Next i
End If
End
End Sub
Public Function AddPipeline1()
'定义变量
Dim line1 As AcadLine
Dim line2 As AcadLine
Dim circle1(0) As AcadEntity
Dim circle2(0) As AcadEntity
Dim regionObj1 As Variant
Dim regionObj2 As Variant
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
Dim point3(0 To 2) As Double
Dim radius1 As Double
Dim radius2 As Double
Dim solidObj As Acad3DSolid
Dim rotateAngle As Double
Dim LWPolyLine As AcadLWPolyline
radius1 = 15
radius2 = 10
point1(0) = p(0).x: point1(1) = p(0).y: point1(2) = p(0).z
point2(0) = p(1).x: point2(1) = p(1).y: point2(2) = p(1).z
Set line1 = ThisDrawing.ModelSpace.AddLine(point1, point2)
rotateAngle = 90 * 3.141592 / 180#
'创建面域
Set circle1(0) = ThisDrawing.ModelSpace.AddCircle(point1, radius1)
Set circle2(0) = ThisDrawing.ModelSpace.AddCircle(point1, radius2)
regionObj1 = ThisDrawing.ModelSpace.AddRegion(circle1)
regionObj2 = ThisDrawing.ModelSpace.AddRegion(circle2)
'布尔运算
regionObj1(0).Boolean acSubtraction, regionObj2(0)
'三维旋转
If p(0).xp(1).x Then
point3(0) = p(0).x
point3(1) = p(0).y + 10
point3(2) = p(0).z
Set line2 = ThisDrawing.ModelSpace.AddLine(point1, point3)
regionObj1(0).Rotate3D point1, point3, rotateAngle
line2.Delete
ElseIf p(0).yp(1).y Then
point3(0) = p(0).x + 10
point3(1) = p(0).y
point3(2) = p(0).z
Set line2 = ThisDrawing.ModelSpace.AddLine(point1, point3)
regionObj1(0).Rotate3D point1, point3, rotateAngle
line2.Delete
End If
circle1(0).Delete
circle2(0).Delete
'拉伸
Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(regionObj1(0), line1)
End Function
高手们快来看看,帮帮我啊!!!!
谢谢各位啊!!!
虽然不懂管道是怎么回事，不过说说
1 先回答你为什么第二个点不对的原因，这是你的程序：
point1(0) = p(i - 1).x: point1(1) = p(i - 1).y: point1(2) = p(i - 1).z
point2(0) = p(i).x: point2(0) = p(i).y: point2(2) = p(i).z
point3(0) = p(i + 1).x: point3(1) = p(i + 1).y: point3(2) = p(i + 1).z
point2(0) = p(i).y这句是你的笔误还是什么就不知道，直接导致了后面点的错误
2ThisDrawing.ActiveUCS = myUCS这种方法好像转不动坐标系吧，不如
ThisDrawing.SendCommand "ucs" & vbCr & "r" & vbCr & myUCS.Name & vbCr
你这种写法好像处理的情况考虑的太少了，也可能我不懂这方面，比如说圆环截面到底是沿哪个方向我也没看懂，随便写了几个数，到这就卡住了
Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(regionObj1(0), line1)
一看截面和拉伸路径在一个平面上。。。呵呵！真是门外汉啊^_^
页:
[1]