获取CAD中线的每个节点坐标程序设计

1、获取 CAD 中线的每个节点坐标，线包括polyline 、3D polyline 、Spline 等等！程序代码如下：Imports SystemImports System.IOImports System.MathPublic Class获取 CAD 中点坐标Public AcadApp As AutoCAD.AcadApplicationPublic xx(), yy(), zz() As DoublePublic Count As IntegerPublic returnObj As ObjectPublic FolderPath As String = C:/Public Step

2、Num As Integer = 0Private Declare Auto Function SetProcessWorkingSetSize Lib kernel32.dll (ByVal procHandle As IntPtr, ByVal min As Int32, ByVal max As Int32) As BooleanPublic Sub SetProcessWorkingSetSize() 节约系统内存 TryDim Mem As ProcessMem = Process.GetCurrentProcess()SetProcessWorkingSetSize(Mem.Han

3、dle, -1, -1)Catch ex As ExceptionMsgBox(ex.ToString)End TryEnd SubPublic Sub启动 CAD()On Error Resume NextAcadApp = GetObject(, AutoCAD.Application)If Err.Number ThenErr.Clear()AcadApp = CreateObject(AutoCAD.Application)End IfAcadApp.Visible = TrueEnd SubPublic Sub获取样条线节点坐标 ()Dim i As IntegerFor i = 0

4、 To 10000 Step StepNumOn Error GoTo handle01Count = iReDim Preserve xx(i)ReDim Preserve yy(i)ReDim Preserve zz(i)xx(i) = returnObj.Coordinate(i)(0)yy(i) = returnObj.Coordinate(i)(1)zz(i) = returnObj.elevationNexthandle01:Count = Count - 1End SubPublic Sub获取 Spline 线节点坐标 ()Dim fitPoints As ObjectDim

5、i As IntegerFor i = 0 To returnObj.NumberOfControlPoints - 1 Step StepNum fitPoints = returnObj.GetControlPoint(i)Count = iReDim Preserve xx(i)ReDim Preserve yy(i)ReDim Preserve zz(i)xx(i) = fitPoints(0)yy(i) = fitPoints(1)zz(i) = fitPoints(2)NextEnd SubPublic Sub获取 Spline 线拟合点坐标 ()Dim fitPoints As

6、ObjectDim pp As AutoCAD.AcadSplineDim i As IntegerFor i = 0 To returnObj.NumberOfFitPoints - 1 Step StepNum fitPoints = returnObj.GetFitPoint(i)Count = iReDim Preserve xx(i)ReDim Preserve yy(i)ReDim Preserve zz(i)xx(i) = fitPoints(0)yy(i) = fitPoints(1)zz(i) = fitPoints(2)NextEnd SubPublic Sub获取 lin

7、e 线节点坐标 ()Dim StartPoints As ObjectDim EndPoints As ObjectReDim Preserve xx(1)ReDim Preserve yy(1)ReDim Preserve zz(1)Count = 1returnObj.highlight(True)StartPoints = returnObj.StartPointEndPoints = returnObj.EndPointxx(0) = StartPoints(0)yy(0) = StartPoints(1)zz(0) = StartPoints(2)xx(1) = EndPoints(

8、0)yy(1) = EndPoints(1)zz(1) = EndPoints(2)End SubPublic Sub获取 2DPolyline 节点坐标 ()Dim sss As AutoCAD.AcadLWPolylinereturnObj.highlight(True)Dim i As IntegerFor i = 0 To 10000 Step StepNumOn Error GoTo handle01Count = iReDim Preserve xx(i)ReDim Preserve yy(i)ReDim Preserve zz(i)xx(i) = returnObj.Coordi

9、nate(i)(0)yy(i) = returnObj.Coordinate(i)(1)zz(i) = returnObj.elevationNexthandle01:Count = Count - 1End SubPrivate Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.ClickOn Error GoTo handle01Call启动 CAD()Dim basePnt As ObjectreturnObj.highlight(True)判断线的类

10、型Dim LineTypenName As StringIf LineTypenName = AcDbLine ThenCall获取 line 线节点坐标 ()ElseIf LineTypenName = AcDbSpline ThenCall获取 Spline 线节点坐标 ()ElseIf LineTypenName = AcDbPolyline ThenCall获取样条线节点坐标 ()Else : Exit SubEnd IfIf TextBox1.Text 0 Or TextBox2.Text 0 Or TextBox4.Text 0 ThenCall CalculateCoordina

11、te()End IfDim i As IntegerDim s As String = For i = 0 To Counts = s + xx(i).ToString() + , + yy(i).ToString() + , + zz(i).ToString() + Chr(13)NextRichTextBox1.Text = sButton3.Enabled = TrueAppActivate(Me.Text)Exit Subhandle01:MsgBox(Err.Description)End SubPrivate Sub Button2_Click(ByVal sender As Sy

12、stem.Object, ByVal e As System.EventArgs) Handles Button2.ClickOn Error GoTo handle01Dim dg As New OpenFileDialogdg.Filter = CAD files (*.dwg)|*.dwg|All files (*.*)|*.*dg.ShowDialog()Dim s As String = dg.FileNameIf s = Then Exit Sub启动 CAD()AppActivate(Me.Text)Button1.Enabled = TrueExit Subhandle01:M

13、sgBox(Err.Description)End SubPrivate Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.ClickOn Error GoTo handle01Dim dg As New SaveFileDialogdg.Filter = txt files (*.txt)|*.txt|dat files (*.dat)|*.datdg.ShowDialog()Dim s As String = dg.FileNameDim i As In

14、tegerDim s1 As String = Using sw As StreamWriter = New StreamWriter(s)For i = 0 To Counts1 = xx(i).ToString() + , + yy(i).ToString() + , + zz(i).ToString()sw.WriteLine(s1)Nextsw.Close()End UsingExit Subhandle01:MsgBox(Err.Description)End SubPrivate Sub Button4_Click(ByVal sender As System.Object, By

15、Val e As System.EventArgs) Handles Button4.Clickport)End SubPublic Sub CalculateCoordinate()On Error GoTo handle01Dim x0, y0, Rotangle As Doublex0 = TextBox1.Texty0 = TextBox2.TextRotangle = (TextBox4.Text) * 3.1415926 / 180Dim i As IntegerDim x1, y1 As DoubleIf Cos(Rotangle) = 0 ThenFor i = 0 To Co

16、untx1 = xx(i)xx(i) = yy(i) - y0yy(i) = x0 - x1NextExit SubEnd IfFor i = 0 To County1 = (yy(i) - y0 - (xx(i) - x0) * Tan(Rotangle) * Cos(Rotangle)x1 = (xx(i) - x0) / Cos(Rotangle) + y1 * Tan(Rotangle)If Abs(x1) 0.00001 Then x1 = 0 设置精度If Abs(y1) 0.00001 Then y1 = 0 xx(i) = x1yy(i) = y1NextExit Subhan

17、dle01:MsgBox(Err.Description)End SubPrivate Sub TextBox2_TextChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles TextBox2.TextChangedEnd SubPrivate Sub批量获取节点坐标Button_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs) Handles 批量获取节点坐标 Button.ClickStatic ExitNum A

18、s IntegerOn Error GoTo handle01Static SaveNum As IntegerCall启动 CAD()Dim basePnt As ObjectreturnObj.highlight(True)选取下一条线 !连续在空白地方点击两次将会自动退出批量存储状态 ! + vbCr)判断线的类型Dim LineTypenName As StringIf LineTypenName = AcDbLine ThenCall获取 line 线节点坐标 ()ElseIf LineTypenName = AcDbSpline ThenCall获取 Spline 线节点坐标 ()

19、ElseIf LineTypenName = AcDbPolyline ThenCall获取样条线节点坐标 ()End IfIf TextBox1.Text 0 Or TextBox2.Text 0 Or TextBox4.Text 0 ThenCall CalculateCoordinate()End IfDim j As IntegerDim s1 As String = Using sw As StreamWriter = New StreamWriter(FolderPath + SaveNum.ToString() + .txt)For j = 0 To Counts1 = xx(j

20、).ToString() + , + yy(j).ToString() + , + zz(j).ToString()sw.WriteLine(s1)Nextsw.Close()SaveNum = SaveNum + 1End UsingExitNum = 0Call批量获取节点坐标Button_Click(sender, e)Exit Subhandle01:ExitNum = ExitNum + 1If ExitNum = 2 ThenExitNum = 0Exit SubElse : Call批量获取节点坐标Button_Click(sender, e)End IfEnd SubPriva

21、te Sub设置文件保存路径Button5_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs) Handles 设置文件保存路径 Button5.ClickDim fdg As FolderBrowserDialogfdg = New FolderBrowserDialogfdg.ShowDialog()If fdg.SelectedPath = Then Exit SubFolderPath = fdg.SelectedPathEnd SubPrivate Sub Button5_Click(ByVal sende

22、r As System.Object, ByVal e As System.EventArgs) Handles Button5.ClickOn Error GoTo Handle01Call启动 CAD()Dim sset As AutoCAD.AcadSelectionSet提示用户选择对象sset.SelectOnScreen()Dim ent As ObjectDim sss As AutoCAD.AcadPointCount = -1For Each ent In ssetIf ent.Objectname = AcDbPoint ThenCount = Count + 1ReDim

23、 Preserve xx(Count)ReDim Preserve yy(Count)ReDim Preserve zz(Count)xx(Count) = ent.Coordinates(0)yy(Count) = ent.Coordinates(1)zz(Count) = ent.Coordinates(2)End IfNext entIf TextBox1.Text 0 Or TextBox2.Text 0 Or TextBox4.Text 0 ThenCall CalculateCoordinate()End IfDim i As IntegerDim s As String = Fo

24、r i = 0 To Counts = s + xx(i).ToString() + , + yy(i).ToString() + , + zz(i).ToString() + Chr(13)NextRichTextBox1.Text = se()AppActivate(Me.Text)Button3.Enabled = TrueExit SubHandle01:e()Button5_Click(sender, e)MsgBox(Err.Description)End SubPrivate Sub Button6_Click_1(ByVal sender As System.Object, B

25、yVal e As System.EventArgs) Handles Button6.ClickOn Error GoTo Handle01Handle01:MsgBox(Err.Description)End SubPrivate Sub Button7_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button7.ClickCall启动 CAD()Dim basePnt As ObjectreturnObj.highlight(True)AppActivate(AcadApp.Capti

26、on)Dim i As IntegerFor i = 0 To 500On Error GoTo handle01Count = iReDim Preserve xx(i)ReDim Preserve yy(i)ReDim Preserve zz(i)xx(i) = returnObj.Coordinate(i)(0)yy(i) = returnObj.Coordinate(i)(1)zz(i) = returnObj.Coordinate(i)(2)Nexthandle01:Count = Count - 1Dim j As IntegerDim s As String = For j =

27、0 To Counts = s + xx(j).ToString() + , + yy(j).ToString() + , + zz(j).ToString() + Chr(13)NextRichTextBox1.Text = sButton3.Enabled = TrueAppActivate(Me.Text)End SubPrivate Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.LoadCall SetProcessWorkingSetSize()End

28、 SubPrivate Sub Button8_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button8.ClickOn Error GoTo handle01Call启动 CAD()Dim basePnt As ObjectreturnObj.highlight(True)Call获取 2DPolyline 节点坐标 ()If TextBox1.Text 0 Or TextBox2.Text 0 Or TextBox4.Text 0 ThenCall CalculateCoordinat

29、e()End IfDim i As IntegerDim s As String = For i = 0 To Counts = s + xx(i).ToString() + , + yy(i).ToString() + , + zz(i).ToString() + Chr(13)NextRichTextBox1.Text = sButton3.Enabled = TrueAppActivate(Me.Text)Exit Subhandle01:MsgBox(Err.Description)End SubPrivate Sub Button9_Click(ByVal sender As Sys

30、tem.Object, ByVal e As System.EventArgs) Handles Button9.ClickCall启动 CAD()Dim basePnt As ObjectMsgBox( 当前点击坐标位置为： + basePnt(0).ToString() + ， + basePnt(1).ToString()End SubPrivate Sub打开 CAD 文件 OToolStripMenuItem_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs) Handles 打开 CAD 文件 OTool

31、StripMenuItem.ClickOn Error GoTo handle01Dim dg As New OpenFileDialogdg.Filter = CAD files (*.dwg)|*.dwg|All files (*.*)|*.*dg.ShowDialog()Dim s As String = dg.FileNameIf s = Then Exit Sub启动 CAD()AppActivate(Me.Text)Button1.Enabled = TrueExit Subhandle01:MsgBox(Err.Description)End SubPrivate Sub保存 C

32、AD 文件 CToolStripMenuItem_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs) Handles保存CAD文件CToolStripMenuItem.ClickOn Error GoTo Handle01Exit SubHandle01:MsgBox(Err.Description)End SubPrivate Sub保存坐标数据文件SToolStripMenuItem_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs)

33、HandlesSToolStripMenuItem.ClickOn Error GoTo handle01Dim dg As New SaveFileDialogdg.Filter = txt files (*.txt)|*.txt|dat files (*.dat)|*.datdg.ShowDialog()Dim s As String = dg.FileNameDim i As IntegerDim s1 As String = 保存坐标数据文件Using sw As StreamWriter = New StreamWriter(s)For i = 0 To Counts1 = xx(i

34、).ToString() + , + yy(i).ToString() + , + zz(i).ToString()sw.WriteLine(s1)Nextsw.Close()End UsingExit Subhandle01:MsgBox(Err.Description)End SubPrivate Sub刷新 CAD 图形 RToolStripMenuItem_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs) Handles刷新 CAD 图形RToolStripMenuItem.ClickOn Error Go

35、To Handle01Exit SubHandle01:MsgBox(Err.Description)End SubPrivate Sub退出 EToolStripMenuItem1_Click(ByVal sender As System.Object, ByVale As System.EventArgs) Handles退出 EToolStripMenuItem1.ClickOn Error GoTo Handle01Application.Exit()Exit SubHandle01:MsgBox(Err.Description)End SubPrivate Sub获取线条上节点坐标L

36、ToolStripMenuItem1_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs) Handles获取线条上节点坐标LToolStripMenuItem1.ClickOn Error GoTo handle01Call启动 CAD()Dim basePnt As ObjectreturnObj.highlight(True)判断线的类型Dim LineTypenName As StringIf LineTypenName = AcDbLine ThenCall获取 line 线节点坐标 ()ElseIf Lin

37、eTypenName = AcDbSpline ThenCall获取 Spline 线拟合点坐标()ElseIf LineTypenName = AcDbPolyline ThenCall获取样条线节点坐标()Else : Exit SubEnd IfIf TextBox1.Text 0 Or TextBox2.Text 0 Or TextBox4.Text 0 ThenCall CalculateCoordinate()End IfDim i As IntegerDim s As String = For i = 0 To Counts = s + xx(i).ToString() + ,

38、+ yy(i).ToString() + , + zz(i).ToString() + Chr(13)NextRichTextBox1.Text = sButton3.Enabled = TrueAppActivate(Me.Text)Exit Subhandle01:MsgBox(Err.Description)End SubPrivate Sub获取多段线上节点坐标SToolStripMenuItem_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs) HandlesSToolStripMenuItem.Clic

39、kOn Error GoTo handle01获取多段线上节点坐标Call启动 CAD()Dim basePnt As ObjectreturnObj.highlight(True)判断线的类型Dim LineTypenName As StringIf LineTypenName = AcDbPolyline ThenCall获取样条线节点坐标()Else : Exit SubEnd IfIf TextBox1.Text 0 Or TextBox2.Text 0 Or TextBox4.Text 0 ThenCall CalculateCoordinate()End IfDim i As In

40、tegerDim s As String = For i = 0 To Counts = s + xx(i).ToString() + , + yy(i).ToString() + , + zz(i).ToString() + Chr(13)NextRichTextBox1.Text = sButton3.Enabled = TrueAppActivate(Me.Text)Exit Subhandle01:MsgBox(Err.Description)End SubPrivate Sub获取样条线上节点坐标ToolStripMenuItem_Click(ByVal sender AsSyste

41、m.Object, ByVal e As System.EventArgs) Handles ToolStripMenuItem.Click获取样条线上节点坐标On Error GoTo handle01Call启动 CAD()Dim basePnt As ObjectreturnObj.highlight(True)判断线的类型Dim LineTypenName As StringIf LineTypenName = AcDbSpline ThenCall获取 Spline 线节点坐标 ()Else : Exit SubEnd IfIf TextBox1.Text 0 Or TextBox2

42、.Text 0 Or TextBox4.Text 0 ThenCall CalculateCoordinate()End IfDim i As IntegerDim s As String = For i = 0 To Counts = s + xx(i).ToString() + , + yy(i).ToString() + , + zz(i).ToString() + Chr(13)NextRichTextBox1.Text = sButton3.Enabled = TrueAppActivate(Me.Text)Exit Subhandle01:MsgBox(Err.Descriptio

43、n)End SubPrivate Sub获取样条线上拟合点坐标NToolStripMenuItem_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs) Handles获取样条线上拟合点坐标NToolStripMenuItem.ClickOn Error GoTo handle01Call启动 CAD()Dim basePnt As ObjectreturnObj.highlight(True)判断线的类型Dim LineTypenName As StringIf LineTypenName = AcDbSpline

44、ThenCall获取 Spline 线拟合点坐标()Else : Exit SubEnd IfIf TextBox1.Text 0 Or TextBox2.Text 0 Or TextBox4.Text 0 ThenCall CalculateCoordinate()End IfDim i As IntegerDim s As String = For i = 0 To Counts = s + xx(i).ToString() + , + yy(i).ToString() + , + zz(i).ToString() + Chr(13)NextRichTextBox1.Text = sBut

45、ton3.Enabled = TrueAppActivate(Me.Text)Exit Subhandle01:MsgBox(Err.Description)End SubPrivate Sub获取点的坐标DToolStripMenuItem1_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs) Handles获取点的坐标DToolStripMenuItem1.ClickOn Error GoTo Handle01Call启动 CAD()Dim sset As AutoCAD.AcadSelectionSet提示用户

46、选择对象sset.SelectOnScreen()Dim ent As ObjectDim sss As AutoCAD.AcadPointCount = -1For Each ent In ssetIf ent.Objectname = AcDbPoint ThenCount = Count + 1ReDim Preserve xx(Count)ReDim Preserve yy(Count)ReDim Preserve zz(Count)xx(Count) = ent.Coordinates(0)yy(Count) = ent.Coordinates(1)zz(Count) = ent.C

47、oordinates(2)End IfNext entIf TextBox1.Text 0 Or TextBox2.Text 0 Or TextBox4.Text 0 ThenCall CalculateCoordinate()End IfDim i As IntegerDim s As String = For i = 0 To Counts = s + xx(i).ToString() + , + yy(i).ToString() + , + zz(i).ToString() + Chr(13)NextRichTextBox1.Text = sAppActivate(Me.Text)But

48、ton3.Enabled = TrueExit SubHandle01:Call获取点的坐标DToolStripMenuItem1_Click(sender, e)MsgBox(Err.Description)End SubPrivate Sub设置自动保存路径ToolStripMenuItem_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs) Handles设置自动保存路径ToolStripMenuItem.ClickDim fdg As FolderBrowserDialogfdg = New FolderBr

49、owserDialogfdg.ShowDialog()If fdg.SelectedPath = Then Exit SubFolderPath = fdg.SelectedPathEnd SubPrivate Sub取线条上节点坐标并自动保存LToolStripMenuItem2_Click(ByVal senderAs System.Object, ByVal e As System.EventArgs) Handles上节点坐标并自动保存LToolStripMenuItem2.ClickStatic ExitNum As IntegerOn Error GoTo handle01Stat

50、ic SaveNum As Integer获取线条上节点坐标获取线条Call启动 CAD()Dim basePnt As ObjectreturnObj.highlight(True)选取下一条线 ! 连续在空白地方点击两次将会自动退出批量存储状态 ! + vbCr)判断线的类型Dim LineTypenName As StringIf LineTypenName = AcDbLine ThenCall获取 line 线节点坐标 ()ElseIf LineTypenName = AcDbSpline ThenCall获取 Spline 线节点坐标 ()ElseIf LineTypenName

51、= AcDbPolyline ThenCall获取样条线节点坐标()End IfIf TextBox1.Text 0 Or TextBox2.Text 0 Or TextBox4.Text 0 ThenCall CalculateCoordinate()End IfDim j As IntegerDim s1 As String = Using sw As StreamWriter = New StreamWriter(FolderPath + SaveNum.ToString() + .txt)For j = 0 To Counts1 = xx(j).ToString() + , + yy(

52、j).ToString() + , + zz(j).ToString()sw.WriteLine(s1)Nextsw.Close()SaveNum = SaveNum + 1End UsingExitNum = 0Call取线条上节点坐标并自动保存LToolStripMenuItem2_Click(sender, e)Exit Subhandle01:ExitNum = ExitNum + 1If ExitNum = 2 ThenExitNum = 0Exit SubElse : Call取线条上节点坐标并自动保存LToolStripMenuItem2_Click(sender, e)End

53、IfEnd SubPrivate Sub获取 3D 多段线上节点坐标TToolStripMenuItem_Click(ByVal sender AsSystem.Object, ByVal e As System.EventArgs) Handles获取 3D 多段线上节点坐标TToolStripMenuItem.ClickCall启动 CAD()Dim basePnt As ObjectreturnObj.highlight(True)AppActivate(AcadApp.Caption)If returnObj.objectname = AcDb3DPolyline ThenDim i As IntegerFor i = 0 To 500On Error GoTo handle01Count = iReDim Preserve xx(i)ReDim Preserve yy(i)ReDim Preserve zz(i)xx(i) = returnObj.Coordinate(i)(0)yy(i) = returnObj.Coordinate(i)(1)zz(i) = returnObj.Coordinate(i)(2)Nexthandle01:Count = Count - 1Dim j As