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

获取CAD中线的每个节点坐标，线包括polyline、3D polyline、Spline等等！

程序代码如下：


Imports System
Imports System.IO
Imports System.Math
Public Class 获取CAD中点坐标
Public AcadApp As AutoCAD.AcadApplication
Public xx(), yy(), zz() As Double
Public Count As Integer
Public returnObj As Object
Public FolderPath As String = "C:/"
Public StepNum As Integer = 0
Private Declare Auto Function SetProcessWorkingSetSize Lib "kernel32.dll" (ByVal procHandle As IntPtr, ByVal min As Int32, ByVal max As Int32) As Boolean
Public Sub SetProcessWorkingSetSize() '节约系统内存
Try
Dim Mem As Process
Mem = Process.GetCurrentProcess()
SetProcessWorkingSetSize(Mem.Handle, -1, -1)
Catch ex As Exception
MsgBox(ex.ToString)
End Try
End Sub
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 获取样条线节点坐标()
Dim i As Integer
For i = 0 To 10000 Step StepNum
On Error GoTo handle01
Count = i
ReDim 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.elevation
Next
handle01:
Count = Count - 1
End Sub
Public Sub 获取Spline线节点坐标()
Dim fitPoints As Object
Dim i As Integer
For i = 0 To returnObj.NumberOfControlPoints - 1 Step StepNum
fitPoints = returnObj.GetControlPoint(i)
Count = i
ReDim Preserve xx(i)
ReDim Preserve yy(i)
ReDim Preserve zz(i)
xx(i) = fitPoints(0)
yy(i) = fitPoints(1)
zz(i) = fitPoints(2)
Next
End Sub
Public Sub 获取Spline线拟合点坐标()
Dim fitPoints As Object
Dim pp As AutoCAD.AcadSpline
Dim i As Integer
For i = 0 To returnObj.NumberOfFitPoints - 1 Step StepNum
fitPoints = returnObj.GetFitPoint(i)
Count = i
ReDim Preserve xx(i)
ReDim Preserve yy(i)
ReDim Preserve zz(i)
xx(i) = fitPoints(0)
yy(i) = fitPoints(1)
zz(i) = fitPoints(2)
Next
End Sub

Public Sub 获取line线节点坐标()
Dim StartPoints As Object
Dim EndPoints As Object
ReDim Preserve xx(1)
ReDim Preserve yy(1)
ReDim Preserve zz(1)
Count = 1
returnObj.highlight(True)
StartPoints = returnObj.StartPoint
EndPoints = returnObj.EndPoint
xx(0) = StartPoints(0)
yy(0) = StartPoints(1)
zz(0) = StartPoints(2)
xx(1) = EndPoints(0)
yy(1) = EndPoints(1)
zz(1) = EndPoints(2)
End Sub
Public Sub 获取2DPolyline节点坐标()
'Dim sss As AutoCAD.AcadLWPolyline
returnObj.highlight(True)
Dim i As Integer
For i = 0 To 10000 Step StepNum
On Error GoTo handle01
Count = i
ReDim 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.elevation
Next
handle01:
Count = Count - 1
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
On Error GoTo handle01
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 = "AcDbLine" Then
Call 获取line线节点坐标()
ElseIf LineTypenName = "AcDbSpline" Then
Call 获取Spline线节点坐标()
ElseIf LineTypenName = "AcDbPolyline" Then
Call 获取样条线节点坐标()
Else : Exit Sub
End If
If TextBox1.Text <> 0 Or TextBox2.Text <> 0 Or TextBox4.Text <> 0 Then
Call CalculateCoordinate()
End If
Dim i As Integer
Dim s As String = ""
For i = 0 To Count
s = s + xx(i).ToString() + "," + yy(i).ToString() + "," + zz(i).ToString() + Chr(13)
Next
RichTextBox1.Text = s
Button3.Enabled = True
AppActivate(Me.Text)
Exit Sub
handle01:
MsgBox(Err.Description)
End Sub
Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
On Error GoTo handle01
Dim dg As New OpenFileDialog
dg.Filter = "CAD files (*.dwg)|*.dwg|All files (*.*)|*.*"
dg.ShowDialog()
Dim s As String = dg.FileName
If s = "" Then Exit Sub
启动CAD()
AcadApp.Application.Documents.Open(s)
AcadApp.ActiveDocument.WindowState = AutoCAD.AcWindowState.acMax
AppActivate(Me.Text)
Button1.Enabled = True
Exit Sub
handle01:
MsgBox(Err.Description)
End Sub
Private Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click
On Error GoTo handle01
Dim dg As New SaveFileDialog
dg.Filter = "txt files (*.txt)|*.txt|dat files (*.dat)|*.dat"
dg.ShowDialog()
Dim s As String = dg.FileName
Dim i As Integer
Dim s1 As String = ""
Using sw As StreamWriter = New StreamWriter(s)
For i = 0 To Count
s1 = xx(i).ToString() + "," + yy(i).ToString() + "," + zz(i).ToString()
sw.WriteLine(s1)
Next
sw.Close()
End Using
Exit Sub
handle01:
MsgBox(Err.Description)
End Sub
Private Sub Button4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button4.Click
AcadApp.ActiveDocument.Regen(AutoCAD.AcRegenType.acActiveViewport)
End Sub
Public Sub CalculateCoordinate()
On Error GoTo handle01
Dim x0, y0, Rotangle As Double
x0 = TextBox1.Text
y0 = TextBox2.Text
Rotangle = (TextBox4.Text) * 3.1415926 / 180
Dim i As Integer
Dim x1, y1 As Double
If Cos(Rotangle) = 0 Then
For i = 0 To Count
x1 = xx(i)
xx(i) = yy(i) - y0
yy(i) = x0 - x1
Next
Exit Sub
End If
For i = 0 To Count
y1 = (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) = x1
yy(i) = y1
Next
Exit Sub
handle01:
MsgBox(Err.Description)
End Sub
Private Sub TextBox2_TextChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles TextBox2.TextChanged
End Sub
Private Sub 批量获取节点坐标Button_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles 批量获取节点坐标Button.Click
Static ExitNum As Integer
On Error GoTo handle01
Static SaveNum As Integer
Call 启动CAD()
Dim basePnt As Object
AcadApp.ActiveDocument.Utility.GetEntity(returnObj, basePnt)
returnObj.highlight(True)
AcadApp.ActiveDocument.SendCommand("@选取下一条线!连续在空白地方点击两次将会自动退出批量存储状态!" + vbCr)
'判断线的类型
Dim LineTypenName As String
LineTypenName = returnObj.ObjectName.ToString()
If LineTypenName = "AcDbLine" Then
Call 获取line线节点坐标()
ElseIf LineTypenName = "AcDbSpline" Then
Call 获取Spline线节点坐标()
ElseIf LineTypenName = "AcDbPolyline" Then
Call 获取样条线节点坐标()
End If
If TextBox1.Text <> 0 Or TextBox2.Text <> 0 Or TextBox4.Text <> 0 Then
Call CalculateCoordinate()
End If
Dim j As Integer
Dim s1 As String = ""
Using sw As StreamWriter = New StreamWriter(FolderPath + SaveNum.ToString() + ".txt")
For j = 0 To Count
s1 = xx(j).ToString() + "," + yy(j).ToString() + "," + zz(j).ToString()
sw.WriteLine(s1)
Next
sw.Close()
SaveNum = SaveNum + 1
End Using
ExitNum = 0
Call 批量获取节点坐标Button_Click(sender, e)
Exit Sub
handle01:
ExitNum = ExitNum + 1
If ExitNum = 2 Then
ExitNum = 0
Exit Sub
Else : Call 批量获取节点坐标Button_Click(sender, e)
End If
End Sub
Private Sub 设置文件保存路径Button5_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles 设置文件保存路径Button5.Click
Dim fdg As FolderBrowserDialog
fdg = New FolderBrowserDialog
fdg.ShowDialog()
If fdg.SelectedPath = "" Then Exit Sub
FolderPath = fdg.SelectedPath
End Sub
Private Sub Button5_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button5.Click
On Error GoTo Handle01
Call 启动CAD()
Dim sset As AutoCAD.AcadSelectionSet
sset = AcadApp.ActiveDocument.SelectionSets.Add("NewSelectionSet")
' 提示用户选择对象
sset.SelectOnScreen()
Dim ent As Object
Dim sss As AutoCAD.AcadPoint
Count = -1
For Each ent In sset
If ent.Objectname = "AcDbPoint" Then
Count = Count + 1
ReDim 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 If
Next ent
If TextBox1.Text <> 0 Or TextBox2.Text <> 0 Or TextBox4.Text <> 0 Then
Call CalculateCoordinate()
End If
Dim i As Integer
Dim s As String = ""
For i = 0 To Count
s = s + xx(i).ToString() + "," + yy(i).ToString() + "," + zz(i).ToString() + Chr(13)
Next
RichTextBox1.Text = s
AcadApp.ActiveDocument.SelectionSets.Item("NewSelectionSet").Delete()
AppActivate(Me.Text)
Button3.Enabled = True
Exit Sub
Handle01:
AcadApp.ActiveDocument.SelectionSets.Item("NewSelectionSet").Delete()
Button5_Click(sender, e)
MsgBox(Err.Description)
End Sub
Private Sub Button6_Click_1(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button6.Click
On Error GoTo Handle01
AcadApp.ActiveDocument.Save()
Handle01:
MsgBox(Err.Description)
End Sub
Private Sub Button7_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button7.Click
Call 启动CAD()
Dim basePnt As Object
AcadApp.ActiveDocument.Utility.GetEntity(returnObj, basePnt)
returnObj.highlight(True)
AppActivate(AcadApp.Caption)
Dim i As Integer
For i = 0 To 500
On Error GoTo handle01
Count = i
ReDim 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)
Next
handle01:
Count = Count - 1
Dim j As Integer
Dim s As String = ""
For j = 0 To Count
s = s + xx(j).ToString() + "," + yy(j).ToString() + "," + zz(j).ToString() + Chr(13)
Next
RichTextBox1.Text = s
Button3.Enabled = True
AppActivate(Me.Text)
End Sub
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Call SetProcessWorkingSetSize()
End Sub
Private Sub Button8_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button8.Click
On Error GoTo handle01
Call 启动CAD()
Dim basePnt As Object
AcadApp.ActiveDocument.Utility.GetEntity(returnObj, basePnt)
returnObj.highlight(True)
Call 获取2DPolyline节点坐标()
If TextBox1.Text <> 0 Or TextBox2.Text <> 0 Or TextBox4.Text <> 0 Then
Call CalculateCoordinate()
End If
Dim i As Integer
Dim s As String = ""
For i = 0 To Count
s = s + xx(i).ToString() + "," + yy(i).ToString() + "," + zz(i).ToString() + Chr(13)
Next
RichTextBox1.Text = s
Button3.Enabled = True
AppActivate(Me.Text)
Exit Sub
handle01:
MsgBox(Err.Description)
End Sub
Private Sub Button9_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button9.Click
Call 启动CAD()
Dim basePnt As Object
basePnt = AcadApp.ActiveDocument.Utility.GetPoint()
MsgBox("当前点击坐标位置为：Ｘ＝" + basePnt(0).ToString() + "，Ｙ＝" + basePnt(1).ToString())
End Sub
Private Sub 打开CAD文件OToolStripMenuItem_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles 打开CAD文件OToolStripMenuItem.Click
On Error GoTo handle01
Dim dg As New OpenFileDialog
dg.Filter = "CAD files (*.dwg)|*.dwg|All files (*.*)|*.*"
dg.ShowDialog()
Dim s As String = dg.FileName
If s = "" Then Exit Sub
启动CAD()
AcadApp.Application.Documents.Open(s)
AcadApp.ActiveDocument.WindowState = AutoCAD.AcWindowState.acMax
AppActivate(Me.Text)
Button1.Enabled = True
Exit Sub
handle01:
MsgBox(Err.Description)
End Sub
Private Sub 保存CAD文件CToolStripMenuItem_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles 保存CAD文件CToolStripMenuItem.Click
On Error GoTo Handle01
AcadApp.ActiveDocument.Save()
Exit Sub
Handle01:
MsgBox(Err.Description)
End Sub
<!--v:3.2-->