AutoCAD VBA提取图层交点坐标及变化点距离和高差

以下是一个实现此功能的示例代码：

Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Geometry
Imports System.IO

Public Class MyCommands
    <CommandMethod('ExtractPoints')>
    Public Sub ExtractPoints()
        ' 获取当前文档和数据库
        Dim doc As Document = Application.DocumentManager.MdiActiveDocument
        Dim db As Database = doc.Database

        ' 开启事务
        Using trans As Transaction = db.TransactionManager.StartTransaction()
            ' 打开模型空间块表记录
            Dim bt As BlockTable = trans.GetObject(db.BlockTableId, OpenMode.ForRead)
            Dim btr As BlockTableRecord = trans.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForRead)

            ' 定义需要提取的图层名
            Dim layer1Name As String = 'zhix'
            Dim layer2Name As String = 'dmx'

            ' 获取图层1和图层2的图层ID
            Dim layer1Id As ObjectId = GetLayerId(layer1Name, trans)
            Dim layer2Id As ObjectId = GetLayerId(layer2Name, trans)

            If layer1Id = ObjectId.Null OrElse layer2Id = ObjectId.Null Then
                doc.Editor.WriteMessage('图层不存在。')
                Return
            End If

            ' 提取相交点坐标
            Dim intersectionPoints As New List(Of Point3d)
            For Each objId1 As ObjectId In btr
                Dim ent1 As Entity = trans.GetObject(objId1, OpenMode.ForRead)
                If ent1.LayerId = layer1Id AndAlso TypeOf ent1 Is Curve Then
                    For Each objId2 As ObjectId In btr
                        Dim ent2 As Entity = trans.GetObject(objId2, OpenMode.ForRead)
                        If ent2.LayerId = layer2Id AndAlso TypeOf ent2 Is Curve Then
                            Dim intersectionPt As Point3d = GetIntersectionPoint(ent1, ent2)
                            If Not intersectionPt.Equals(Point3d.Origin) Then
                                intersectionPoints.Add(intersectionPt)
                            End If
                        End If
                    Next
                End If
            Next

            ' 按照x轴排序
            intersectionPoints.Sort(Function(p1, p2) p1.X.CompareTo(p2.X))

            ' 提取左侧dmx图层的变化点坐标
            Dim changePoints As New List(Of Point3d)
            For Each pt As Point3d In intersectionPoints
                For Each objId As ObjectId In btr
                    Dim ent As Entity = trans.GetObject(objId, OpenMode.ForRead)
                    If ent.LayerId = layer2Id AndAlso TypeOf ent Is Curve AndAlso ent.GetClosestPointTo(pt, False).Equals(pt) Then
                        changePoints.Add(pt)
                        Exit For
                    End If
                Next
            Next

            ' 计算距离和高差，并输出到文本
            Dim outputFilePath As String = 'C:\Output.txt'
            Using writer As StreamWriter = File.CreateText(outputFilePath)
                For i As Integer = 1 To changePoints.Count - 1
                    Dim dist As Double = changePoints(i - 1).DistanceTo(changePoints(i))
                    Dim elevationDiff As Double = changePoints(i).Z - changePoints(i - 1).Z
                    writer.WriteLine($'点{i}坐标：{changePoints(i)}, 距离：{dist}, 高差：{elevationDiff}')
                Next
            End Using

            trans.Commit()
        End Using

        doc.Editor.WriteMessage('提取完成。')
    End Sub

    ' 获取图层ID
    Private Function GetLayerId(layerName As String, trans As Transaction) As ObjectId
        Dim layerId As ObjectId = ObjectId.Null
        Dim lt As LayerTable = trans.GetObject(trans.Database.LayerTableId, OpenMode.ForRead)
        If lt.Has(layerName) Then
            layerId = lt(layerName)
        End If
        Return layerId
    End Function

    ' 获取两个曲线的交点
    Private Function GetIntersectionPoint(ent1 As Entity, ent2 As Entity) As Point3d
        Dim intersectionPt As Point3d = Point3d.Origin
        Dim res As New Point3dCollection()
        If ent1.IntersectWith(ent2, Intersect.OnBothOperands, res, IntPtr.Zero, IntPtr.Zero) = Intersect.OnBothOperands Then
            If res.Count > 0 Then
                intersectionPt = res(0)
            End If
        End If
        Return intersectionPt
    End Function
End Class

要使用此代码，您需要在AutoCAD中创建一个VB.NET项目，并将以上代码添加到MyCommands类中。然后，使用NETLOAD命令加载此项目生成的DLL文件，并运行EXTRACTPOINTS命令来提取数据并输出到文本文件。请确保将图层名称和输出文件路径更改为您实际使用的值。