根据剖面图及路径自动建立模型

 发布一个根据剖面图及路径自动建立模型程序！
原理比较简单，但是很实用！只需要选取模型的断面图和路径，就可自动生成三维实体模型！省去了在空间旋转、移动、生成面域、拉升等操作！如果手动要花2天的时间建模，用这个程序最大2个小时就可以搞定！欢迎试用！

程序界面：


编译程序下载地址：
http://www.brsbox.com/filebox/down/fc/818f8ddf395af42c927d4b2875172365
程序源代码：
Public Class Form1
    Public AcadApp As AutoCAD.AcadApplication
    Public xx(), yy(), zz() As Double
    Public Px(), Py(), Pz() As Double
    Public Count As Integer
    Public PCount As Integer
    Public returnObj As Object
    Public myPathLine As Object
    Public Sub 启动CAD()
        On Error Resume Next
        AcadApp = GetObject(, "AutoCAD.Application")
        If Err.Number Then
            Err.Clear()
            AcadApp = CreateObject("AutoCAD.Application")
        End If
        AcadApp.Visible = True
        AcadApp.WindowState = AutoCAD.AcWindowState.acMax
        AppActivate(AcadApp.Caption)
    End Sub
    Public Sub 获取2DPolyline节点坐标(ByVal lineObject As Object) 'AcDbPolyline
        ComboBox1.Items.Clear()
        Dim i As Integer
        For i = 0 To 10000
            On Error GoTo handle01
            Count = i
            ReDim Preserve xx(i)
            ReDim Preserve yy(i)
            ReDim Preserve zz(i)
            xx(i) = lineObject.Coordinate(i)(0)
            yy(i) = lineObject.Coordinate(i)(1)
            ComboBox1.Items.Add(i)
        Next
handle01:
        Count = Count - 1
    End Sub
    Public Sub 获取3DPolyline线节点坐标(ByVal lineObject As Object) 'AcDb3dPolyline
        Dim i As Integer
        For i = 0 To 1000
            On Error GoTo handle01
            PCount = i
            ReDim Preserve Px(i)
            ReDim Preserve Py(i)
            ReDim Preserve Pz(i)
            Px(i) = lineObject.Coordinate(i)(0)
            Py(i) = lineObject.Coordinate(i)(1)
            Pz(i) = lineObject.Coordinate(i)(2)
        Next
handle01:
        PCount = PCount - 1
    End Sub
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Call 启动CAD()
        Dim myReturnObj, basePnt As Object
        AcadApp.ActiveDocument.Utility.GetEntity(myReturnObj, basePnt)
        myReturnObj.highlight(True)
        '判断线的类型
        Dim LineTypenName As String
        LineTypenName = myReturnObj.ObjectName.ToString()
        If LineTypenName = "AcDb3dPolyline" Then
            Call 获取3DPolyline线节点坐标(myReturnObj)
            myPathLine = myReturnObj
            Call DoModeling()
            Button1.Enabled = False
        Else
            MsgBox("请确保选取的路径线为3DPolyline线条！" + Chr(13) + "提示：绘制3DPolyline线的命令为3DPoly")
        End If
        AppActivate(Me.Text)
    End Sub
    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
        Call 启动CAD()
        Dim basePnt As Object
        AcadApp.ActiveDocument.Utility.GetEntity(returnObj, basePnt)
        returnObj.highlight(True)
        '判断线的类型
        Dim LineTypenName As String
        LineTypenName = returnObj.ObjectName.ToString()
        If LineTypenName = "AcDbPolyline" And returnObj.Closed Then
            '获取选取的剖面线的坐标点
            Call 获取2DPolyline节点坐标(returnObj)
            Button1.Enabled = True
            If CheckBox1.Checked Then
                returnObj.Delete()
            End If
        Else
            MsgBox("请确保剖面线为2D的Polyline线且闭合!")
            Exit Sub
        End If
        AppActivate(Me.Text)
    End Sub
    Public Sub DoModeling()
        '沿着X轴旋转这些坐标点90度
        Dim i As Integer
        For i = 0 To Count
            zz(i) = yy(i)
            yy(i) = 0
        Next
        '根据旋转后的坐标绘制面域的来源边界线
        Dim PointArray() As Double
        ReDim PointArray(3 * (Count + 1) - 1)
        For i = 0 To Count
            PointArray(3 * i) = xx(i)
            PointArray(3 * i + 1) = yy(i)
            PointArray(3 * i + 2) = zz(i)
        Next
        Dim RegionObjects(0 To 0) As AutoCAD.Acad3DPolyline
        RegionObjects(0) = AcadApp.ActiveDocument.ModelSpace.Add3DPoly(PointArray)
        RegionObjects(0).Closed = True
        '移动并旋转边界线
        Dim createRegionObjects As Object
        Dim createSolidRegion As AutoCAD.AcadRegion
        createRegionObjects = AcadApp.ActiveDocument.ModelSpace.AddRegion(RegionObjects)
        createSolidRegion = createRegionObjects(0)
        Dim movePoint1(0 To 2) As Double
        Dim movePoint2(0 To 2) As Double
        Dim rotateAngle As Double
        movePoint1(0) = xx(ComboBox1.Text) : movePoint1(1) = yy(ComboBox1.Text) : movePoint1(2) = zz(ComboBox1.Text)
        If RadioButton1.Checked Then
            movePoint2(0) = Px(0) : movePoint2(1) = Py(0) : movePoint2(2) = Pz(0)
            rotateAngle = -Math.Atan((Px(1) - Px(0)) / (Py(1) - Py(0)))
        Else
            movePoint2(0) = Px(PCount) : movePoint2(1) = Py(PCount) : movePoint2(2) = Pz(PCount)
            rotateAngle = -Math.Atan((Px(PCount) - Px(PCount - 1)) / (Py(PCount) - Py(PCount - 1)))
        End If
        createSolidRegion.Move(movePoint1, movePoint2)
        If Py(0) = Py(1) Then
            GoTo step01
        Else
            createSolidRegion.Rotate(movePoint2, rotateAngle)
        End If
step01:
        AcadApp.ActiveDocument.ModelSpace.AddExtrudedSolidAlongPath(createSolidRegion, myPathLine)
        RegionObjects(0).Delete()
        createSolidRegion.Delete()
        If CheckBox2.Checked Then
            myPathLine.delete()
        End If
    End Sub
End Class