VBA:AutoCAD批量提取文本，并按区间排序，复制
2012-09-29 08:50阅读：
适用于提取cad图纸里的文本，并进行排序（针对整型数据）。按区间分类，并自动复制到剪贴板中。可适当修改，提高工作效率。
步骤及效果：
1、运行vba宏，框选数字文本框
![]( "VBA:AutoCAD批量提取文本，并按区间排序，复制")
2、空格继续执行后，宏会自动排序并复制到剪贴板中。在excel中粘贴的内容如下图，第一格为排
序好后的数字区间及组合，第二个为cad选框选中文本的总数。
![]( "VBA:AutoCAD批量提取文本，并按区间排序，复制")
VBA代码如下：
_____________________________________________________________________
Private Type mystr
str As
String
x As
Double
y As
Double
End Type
Sub TQ()
On Error Resume Next
Dim i As Integer
Dim j As Integer
Dim m As Integer
Dim step As Integer
Dim E As Excel.Application, B
As Workbook, S As Worksheet
Dim SS As AcadSelectionSet, T As Object,
FT(3) As Integer, FD(3) As Variant
Dim search As String
Dim mstrcount As Integer
Dim lengthstr As Integer
Dim block(0 To 50) As Integer
Dim seltext(0 To 255) As mystr
Dim counter As Integer
'Dim midnum As Double
Dim midstr As mystr
search = '\pt1;'
'下面定义选择集过滤器列表为多行文字或单行文字
FT(0) = -4: FD(0) = '<or'
FT(1) = 0: FD(1) = 'mtext'
FT(2) = 0: FD(2) = 'text'
FT(3) = -4: FD(3) = 'or>'
'创建选择集
Set SS =
ThisDrawing.SelectionSets.Add('SS')
'在屏幕上选择多行文字或单行文字对象'
SS.SelectOnScreen FT, FD
'如果选择集不为空则运行以下代码
If SS.Count > 0 Then
'运行EXCEL程序
Set E = New
Excel.Application
'在EXCEL中插入工作薄
Set B =
E.Workbooks.Add
Set S =
B.ActiveSheet
'设置一列宽度
S.Columns(1).ColumnWidth = 30
'显示EXCEL程序
E.Visible =
False
'把所有字符串及坐标保存起来
For Each T
In SS
seltext(i).str = T.TextString
i = i + 1
Next
counter = i
- 1
'把单行文字或多行文字的内容写入表格
'对于多行文字，如果直接写入则字符串中很可能包含转义符，使用者可根据需要对字符串运算处理后再写入表格
For i = 0
To counter
mstrcount = InStr(1,
seltext(i).str, search) '判断是否为多行文字
If mstrcount > 0 Then
lengthstr =
Len(seltext(i).str)
'去除多行文字前面多余的部分
seltext(i).str =
Right(seltext(i).str, lengthstr - 5)
End If
S.Cells(i + 1, 1).Value =
seltext(i).str
Next
i
'sort ，
放在excel中排序可以简单解决string和integer排序的次序问题,但排序速度慢
For i = 1
To counter
For j = i + 1 To counter + 1
If
S.Cells(i, 1) > S.Cells(j, 1) Then
'If
CInt(Val(seltext(i).str)) > CInt(Val(seltext(j).str)) Then
S.Cells(1, 2) = S.Cells(i, 1)
S.Cells(i, 1) = S.Cells(j, 1)
S.Cells(j, 1) = S.Cells(1, 2)
End
If
Next j
Next
i
'区间组合，判断整数连续区间，可做适当修改
m = 1
j = 1
For i = 1 To
counter + 1
step = 1
For j = i + 1 To counter + 2
If
CInt(Val(S.Cells(i, 1))) + step = CInt(Val(S.Cells(j, 1))) And
Len(S.Cells(i, 1)) = Len(S.Cells(j, 1)) Then
step = step + 1
Else
S.Cells(m, 3) = S.Cells(i, 1)
If j - i
<> 1 Then
S.Cells(m,
4) = S.Cells(j - 1, 1)
End
If
m = m + 1
Exit For
End
If
Next j
i = j - 1
Next
i
'为区间范围添加“-”连接符
For i = 1
To m - 1
If Len(S.Cells(i, 4)) <> 0 Then
S.Cells(i, 5).Value = S.Cells(i, 3).Value
& '-' & S.Cells(i, 4).Value
Else
S.Cells(i, 5).Value = S.Cells(i,
3).Value
End If
Next
i
S.Cells(1,
6).Value = S.Cells(1, 5).Value
'为区间范围添加“、”分隔
For
i = 2 To m - 1
S.Cells(1, 6).Value = S.Cells(1, 6).Value
& '、' & S.Cells(i, 5).Value
Next i
End If
'计算区间范围内总的整数个数
S.Cells(1, 7) = counter + 1
'复制到剪贴板
S.Range('F1:G1').Copy
'删除用过的选择集
SS.Delete
End Sub
