获取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