如何在CAD中编程实现一次选中同一层中不同内容的文字？文字的内容可以自行定义。

bigmonster

如何在CAD中编程实现一次选中同一层中不同内容的文字？文字的内容可以自行定义。

如在道路层中一次选中“沥”和“碎石”，文字内容可以在程序中写死。望有码，感谢！

wylong

2. Sub SelectTexts()
   
3.     Dim sS As AcadSelectionSet
   
4.     Dim fType(0 To 2) As Integer
   
5.     Dim fData(0 To 2) As Variant
   
6.     Dim AutoSelect As Boolean
   
7.    
   
8.     '更改变量值 True/False 可以实现自动全选或手动框选
   
9.     AutoSelect = True
   
10. 
    
11.     On Error Resume Next
    
12.     ThisDrawing.SelectionSets("SelectTexts").Delete
    
13.     Set sS = ThisDrawing.SelectionSets.Add("SelectTexts")
    
14.     On Error GoTo 0
    
15. 
    
16.     On Error GoTo ErrHandle
    
17. 
    
18.     '创建过滤机制
    
19.     fType(0) = 0: fData(0) = "TEXT,MTEXT"             '单行或多行文字
    
20.    
    
21.     '更改下面的文字内容可以实现选择不同的文字
    
22.     'fType(1) = 1: fData(1) = "*碎石*,*沥*"           '文字内容-模糊选择
    
23.     fType(1) = 1: fData(1) = "碎石,沥"                '文字内容-精确选择
    
24.    
    
25.     fType(2) = 8: fData(2) = "道路"                   '图层名称
    
26. 
    
27.     '选择符合条件的所有图元－单行文字和多行文字
    
28.     If AutoSelect Then
    
29.         '自动选择方式
    
30.         sS.Select acSelectionSetAll, , , fType, fData
    
31.     Else
    
32.         '提示用户手动选择区域
    
33.         sS.SelectOnScreen fType, fData
    
34.     End If
    
35.    
    
36.     If sS.Count = 0 Then Exit Sub
    
37.    
    
38.     sS.Highlight True
    
39.    
    
40.     '此处加入你的处理代码
    
41.     '....................
    
42. 
    
43.     '删除数组
    
44.     Erase fType: Erase fData
    
45.    
    
46.     '删除选择集
    
47.     sS.Clear: sS.Delete
    
48.     Set sS = Nothing
    
49.    
    
50.     Exit Sub
    
51. ErrHandle:
    
52.     MsgBox Err.Description, vbCritical, "产生了以下错误:"
    
53.     Err.Clear
    
54. End Sub

Sub SelectTexts()<br />     Dim sS As AcadSelectionSet<br />     Dim fType(0 To 2) As Integer<br />     Dim fData(0 To 2) As Variant<br />     Dim AutoSelect As Boolean<br />     <br />     '更改变量值 True/False 可以实现自动全选或手动框选<br />     AutoSelect = True<br /> <br />     On Error Resume Next<br />     ThisDrawing.SelectionSets("SelectTexts").Delete<br />     Set sS = ThisDrawing.SelectionSets.Add("SelectTexts")<br />     On Error GoTo 0<br /> <br />     On Error GoTo ErrHandle<br /> <br />     '创建过滤机制<br />     fType(0) = 0: fData(0) = "TEXT,MTEXT"             '单行或多行文字<br />     <br />     '更改下面的文字内容可以实现选择不同的文字<br />     'fType(1) = 1: fData(1) = "*碎石*,*沥*"           '文字内容-模糊选择<br />     fType(1) = 1: fData(1) = "碎石,沥"                '文字内容-精确选择<br />     <br />     fType(2) = 8: fData(2) = "道路"                   '图层名称<br /> <br />     '选择符合条件的所有图元－单行文字和多行文字<br />     If AutoSelect Then<br />         '自动选择方式<br />         sS.Select acSelectionSetAll, , , fType, fData<br />     Else<br />         '提示用户手动选择区域<br />         sS.SelectOnScreen fType, fData<br />     End If<br />     <br />     If sS.Count = 0 Then Exit Sub<br />     <br />     sS.Highlight True<br />     <br />     '此处加入你的处理代码<br />     '....................<br /> <br />     '删除数组<br />     Erase fType: Erase fData<br />     <br />     '删除选择集<br />     sS.Clear: sS.Delete<br />     Set sS = Nothing<br />     <br />     Exit Sub<br /> ErrHandle:<br />     MsgBox Err.Description, vbCritical, "产生了以下错误:"<br />     Err.Clear<br /> End Sub