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

发布一个根据剖面图及路径自动建立模型程序！
原理比较简单，但是很实用！只需要选取模型的断面图和路径，就可自动生成三维实体模型！省去了在空间旋转、移动、生成面域、拉升等操作！如果手动要花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