一个画管道的程序,可有点问题,大家来帮我看看啊,救命的!!!!

singlegu

      是通过拉伸路径来画管道的,输入两个点时能画出管道,当输入三个及三个以上的点是就有问题了,对于三个和三个以上的点的思路是这样的:

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

xyy_82216

我也在写管道的程序，我也遇到同样的问题，求高手帮忙吧~~

xinghesnak

搞不清楚你得P怎么定义的，还有一个FOR.......Next.  能不能把前面缺的那段程序也贴上，也许问题就处在你的For.......Next上。

singlegu

下面是我全部的程序：

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).x <> p(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).y <> p(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

 

singlegu

高手们快来看看,帮帮我啊!!!!

谢谢各位啊!!!

xinghesnak

虽然不懂管道是怎么回事，不过说说

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这句是你的笔误还是什么就不知道，直接导致了后面点的错误

2  ThisDrawing.ActiveUCS = myUCS这种方法好像转不动坐标系吧，不如

    ThisDrawing.SendCommand "ucs" & vbCr & "r" & vbCr & myUCS.Name & vbCr

你这种写法好像处理的情况考虑的太少了，也可能我不懂这方面，比如说圆环截面到底是沿哪个方向我也没看懂，随便写了几个数，到这就卡住了

Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(regionObj1(0), line1)  

一看截面和拉伸路径在一个平面上。。。呵呵！真是门外汉啊^_^