AutoCAD VB.NET 代码：提取所有 'zhix' 和 'dmx' 图层相交点下方文字

使用 VB.NET 代码提取 AutoCAD 中所有 'zhix' 和 'dmx' 图层相交点下方文字

此代码将在当前 AutoCAD 文档中遍历模型空间中的每个实体，如果实体位于 'zhix' 或 'dmx' 图层上，则查找与实体相交的第一个文字实体，并将其内容保存到指定的文本文件中。

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

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

        ' 新建一个文件用于存储结果
        Dim outputPath As String = "C:\output.txt"
        If File.Exists(outputPath) Then
            File.Delete(outputPath)
        End If

        ' 打开数据库事务
        Using trans As Transaction = db.TransactionManager.StartTransaction()
            ' 获取当前空间的块表
            Dim bt As BlockTable = trans.GetObject(db.BlockTableId, OpenMode.ForRead)

            ' 获取模型空间块表记录
            Dim ms As BlockTableRecord = trans.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForRead)

            ' 遍历模型空间中的每个实体
            For Each objId As ObjectId In ms
                Dim ent As Entity = trans.GetObject(objId, OpenMode.ForRead)

                ' 仅处理线和文字实体
                If TypeOf ent Is Line OrElse TypeOf ent Is DBText Then
                    ' 获取实体的图层名
                    Dim layerName As String = ent.Layer

                    ' 判断是否为'zhix'或'dmx'图层
                    If layerName.Equals("zhix", StringComparison.OrdinalIgnoreCase) OrElse
                       layerName.Equals("dmx", StringComparison.OrdinalIgnoreCase) Then
                        ' 获取与实体相交的文字实体
                        Dim intersectingText As DBText = GetIntersectingText(ent, trans)

                        ' 如果找到相交的文字实体，则输出其内容到文本文件
                        If intersectingText IsNot Nothing Then
                            SaveTextToFile(intersectingText.TextString, outputPath)
                        End If
                    End If
                End If
            Next
        End Using
    End Sub

    ' 获取与实体相交的文字实体
    Private Shared Function GetIntersectingText(ByVal entity As Entity, ByVal trans As Transaction) As DBText
        ' 获取实体的几何信息
        Dim entGeom As Curve = TryCast(entity, Curve)
        Dim entExtents As Extents3d = entGeom.GetBoundingBox()

        ' 定义一个过滤器，用于查询与实体相交的文字实体
        Dim filter As New SelectionFilter(New TypedValue() {New TypedValue(CInt(DxfCode.Start), "TEXT")})

        ' 定义一个选择集用于存储相交的文字实体
        Dim selSet As SelectionSet = Nothing

        ' 创建一个选择集过滤器，并设置过滤条件为相交
        Dim selSetFilter As New BoundingIntersectFilter(entExtents)

        ' 在当前空间中选择相交的文字实体
        Dim promptResult As PromptSelectionResult = trans.GetObject(entity.BlockId, OpenMode.ForRead).GetSubentPaths(selSetFilter)
        If promptResult.Status = PromptStatus.OK Then
            selSet = promptResult.Value
        End If

        ' 遍历选择集中的每个文字实体
        For Each id As ObjectId In selSet.GetObjectIds()
            Dim text As DBText = trans.GetObject(id, OpenMode.ForRead)

            ' 判断文字实体是否在实体下方
            If text.Position.Y < entity.Bounds.Value.MinPoint.Y Then
                Return text
            End If
        Next

        Return Nothing
    End Function

    ' 将文本内容保存到文件
    Private Shared Sub SaveTextToFile(ByVal text As String, ByVal outputPath As String)
        Using writer As New StreamWriter(outputPath, True)
            writer.WriteLine(text)
        End Using
    End Sub
End Class

请确保已将对应的 AutoCAD 扩展程序引用添加到您的项目中。

您可以根据需要修改输出路径和图层名称。