AutoCAD VBA 实现批量文字提取

做电气,拿别人的图纸做接线表,需要在dwg图纸中提取大量的信息.

找到别人写的代码,如下

Sub AcadGetText备份()
    
    Dim sset As AcadSelectionSet   '声明定义选择集
    Dim ent As AcadEntity          '声明实体
    Dim fso, f
    Dim filename As String         '声明文件字符串
    Dim str As String
    
    filename = "C:/Users/jichao/Documents/CAD_VBA/output.txt"
    
    Do While ThisDrawing.SelectionSets.Count > 0
        ThisDrawing.SelectionSets.Item(0).Delete
    Loop
    
    Set sset = ThisDrawing.SelectionSets.Add("sst")  '添加选择集
    sset.SelectOnScreen                              '在屏幕上选择对象
    
    
    
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.OpenTextFile(filename, 8, True)
    
    ' 可能选取到非文本，所以。。。
    On Error Resume Next
    For Each ent In sset
        str = ""
        str = ent.TextString
        
        If str <> "" Then
            f.Write str
            f.Write Chr(9)
        End If
        
    Next
    f.Write Chr(13) + Chr(10)
    f.Close
    
End Sub

使用过程中,发现,只能逐一拾取文字,如果圈选,则会得到随机顺序的文字.

我需要拾取的文字,都是竖向,一列一列的.于是改写了这部分代码,让圈选的文字,自动按坐标排序.

Public Sub AcadGetText()
    Dim sset As AcadSelectionSet   '声明定义选择集
    Dim ent As AcadEntity          '声明实体
    Dim minP, maxP As Variant
    Dim 字符串数量, i, 比较失败数量 As Integer
    Dim mystr As String
    Dim fso, f
    Dim filename As String         '声明文件字符串
    
    filename = "C:/Users/jichao/Documents/CAD_VBA/output.txt"
    
    '清空选择集
    Do While ThisDrawing.SelectionSets.Count > 0
        ThisDrawing.SelectionSets.Item(0).Delete
    Loop
    
    Set sset = ThisDrawing.SelectionSets.Add("sst")  '添加选择集
    sset.SelectOnScreen                              '在屏幕上选择对象
    
    '获得选择集元素数量
    字符串数量 = 0
    For Each ent In sset
        字符串数量 = 字符串数量 + 1
    Next
    '重定义一个数组,用于保存数据,其中(0,*)用于排序时作为缓存
    ReDim 选择集数组(字符串数量 + 1, 2) As Variant
    '遍历选择集,收集数据,因为我要竖直方向上排序,只收集Y坐标
    i = 1
    On Error Resume Next
    For Each ent In sset
        选择集数组(i, 1) = ent.TextString
        ent.GetBoundingBox minP, maxP
        选择集数组(i, 2) = minP(1)
        i = i + 1
    Next
    '对数据排序,
    比较失败数量 = 8
    Do While 比较失败数量 > 0
        比较失败数量 = 0
        For i = 1 To 字符串数量
            If 选择集数组(i, 2) < 选择集数组(i + 1, 2) Then
                选择集数组(0, 1) = 选择集数组(i, 1)
                选择集数组(0, 2) = 选择集数组(i, 2)
                选择集数组(i, 1) = 选择集数组(i + 1, 1)
                选择集数组(i, 2) = 选择集数组(i + 1, 2)
                选择集数组(i + 1, 1) = 选择集数组(0, 1)
                选择集数组(i + 1, 2) = 选择集数组(0, 2)
                比较失败数量 = 比较失败数量 + 1
            End If
        Next
    Loop
    '文件操作
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.OpenTextFile(filename, 8, True)
    On Error Resume Next
    For i = 1 To 字符串数量 + 1
        mystr = ""
        mystr = 选择集数组(i, 1)
        
        If mystr <> "" Then
            f.Write mystr
            f.Write Chr(9)
        End If
        
    Next
    f.Write Chr(13) + Chr(10)
    f.Close
    
End Sub

另外,配合autoLisp代码,实现在命令行直接调用

(defun c:dd()
  (command "-vbarun" "AcadGetText")
  (prin1)
 )

在CAD中,先打开图纸,再加载以上2个工程,即可用"dd"命令调用VBA程序.