求助，关于修改文字的问题

xgngg

我想用VBA编一个修改文字的程序，


就好象CAD的特性匹配一样，只要选择了参照文字，其他被选择的文字对象都改变了


比如：图中有是个文字，分别是“A”，“B”，“C”，“D”


我想把“B”改成“A”，只要选择“A”，再刷一下“B”，“B”就变成“A”了。

myfreemind

错误处理没写，所以一点要点准，呵呵 Sub tt()
Dim pnt As Variant
Dim ent As AcadEntity
Dim stxt As String
Dim mtxt As String
Dim sset As AcadSelectionSet
Dim i As Integer
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Clear
ThisDrawing.SelectionSets.Item(i).Delete
Next
ThisDrawing.Utility.GetEntity ent, pnt, "choose"
stxt = ent.TextString
Set sset = ThisDrawing.SelectionSets.Add("tt") sset.SelectOnScreen
For i = 0 To sset.Count - 1
sset.Item(i).TextString = stxt
Next
End Sub

subtlation

这个我写过，和楼主所说的功能一模一样。对于属性文字也可以（不过属性中只提取第一个文字），不过对于Mtext没有试过，不知道好不好用。代码如下：

2. '主程序如下
3. Sub SameText()   ThisDrawing.Utility.Prompt "欢迎使用《文字变相同》"
4.    
5.    Dim getobj1 As Object
6.    Dim getObj2 As Object
7.    Dim basePnt As Variant
8.    Dim getaReal As Variant
9.    Dim ssetobj As AcadSelectionSet '声明一个集合
10.    Dim Att1 As Variant   '声明一个属性变量
11.    Dim Att2 As Variant
12.    On Error Resume Next
13.    ThisDrawing.SelectionSets("被改变文字").Delete
14.    Set ssetobj = ThisDrawing.SelectionSets.Add("被改变文字")
15.    
16.    On Error GoTo Finish
17.    gwGetEntity getobj1, basePnt, "选择被复制文字或属性:", "AcDbBlockReference", "AcDb*text"
18.    If getobj1 Is Nothing Then GoTo Finish
19.    
20.    Dim FType, FData
21.    BuildFilter FType, FData, -4, "<or", 0, "insert", 0, "*text", -4, "or>"
22.    ssetobj.SelectOnScreen FType, FData
23.    If ssetobj.Count = 0 Then GoTo Finish '如果没有选择物体，结束程序
24.    Dim textStr As String
25.    
26.        If getobj1.ObjectName = "AcDbBlockReference" Then
27.            Att1 = getobj1.GetAttributes()
28.            textStr1 = Att1(0).TextString
29.        ElseIf getobj1.ObjectName = "AcDbText" Then
30.            textStr1 = getobj1.TextString
31.        End If
32.    
33.    For Each pickedObjs In ssetobj
34.        If pickedObjs.ObjectName = "AcDbBlockReference" Then
35.            Att2 = pickedObjs.GetAttributes()
36.            Att2(0).TextString = textStr1
37.        Else
38.            pickedObjs.TextString = textStr1
39.        End If
40.    NextFinish:
41.    ssetobj.Delete
42. End Sub'函数如下Public Sub gwGetEntity(ent As Object, pickedPoint, Prompt As String, ParamArray gType())
43.   '选择某一类型的实体，如果选择错误则继续，按ESC退出
44.   'gtype是实体名称，不区分大小写，可以用通配符号，如"AcDbBlockReference"，"acdb*text"等
45.   Dim i As Integer
46.   Dim pd As Boolean
47.   pd = False
48.   Do
49.    GetEntityEx ent, pickedPoint, Prompt
50.    
51.    If ent Is Nothing Then
52.        Exit Do
53.    ElseIf UBound(gType) - LBound(gType) + 1 = 0 Then
54.        Exit Do
55.    Else
56.        For i = LBound(gType) To UBound(gType)
57.            If UCase(ent.ObjectName) Like UCase(gType(i)) Then
58.                Exit Do
59.            Else
60.                pd = True
61.            End If
62.        Next i
63.        If pd Then ThisDrawing.Utility.Prompt "选择的实体不符合要求．"
64.    End If
65.   Loop
66.   
67. End Sub
68. Public Sub GetEntityEx(ent As Object, pickedPoint, Optional Prompt)
69.    '选择实体，直到用户取消操作
70.        On Error Resume Next
71. StartLoop:
72.        ThisDrawing.Utility.GetEntity ent, pickedPoint, Prompt
73.        If Err Then
74.                If ThisDrawing.GetVariable("errno") = 7 Then
75.                        Err.Clear
76.                        GoTo StartLoop
77.                Else                       Err.Raise vbObjectError + 5, , "用户取消操作"
78.                End If
79.        End IfEnd Sub
80. Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
81.        '用数组方式填充一对变量以用作为选择集过滤器使用
82.        Dim FType() As Integer, FData()
83.        Dim index As Long, i As Long
84.       
85.        index = LBound(gCodes) - 1
86.                
87.        For i = LBound(gCodes) To UBound(gCodes) Step 2
88.                index = index + 1
89.                ReDim Preserve FType(0 To index)
90.                ReDim Preserve FData(0 To index)
91.                FType(index) = CInt(gCodes(i))
92.                FData(index) = gCodes(i + 1)
93.        Next
94.        typeArray = FType: dataArray = FData
95. End Sub

'主程序如下 Sub SameText()   ThisDrawing.Utility.Prompt "欢迎使用《文字变相同》"        Dim getobj1 As Object    Dim getObj2 As Object    Dim basePnt As Variant    Dim getaReal As Variant    Dim ssetobj As AcadSelectionSet '声明一个集合    Dim Att1 As Variant   '声明一个属性变量    Dim Att2 As Variant    On Error Resume Next    ThisDrawing.SelectionSets("被改变文字").Delete    Set ssetobj = ThisDrawing.SelectionSets.Add("被改变文字")        On Error GoTo Finish    gwGetEntity getobj1, basePnt, "选择被复制文字或属性:", "AcDbBlockReference", "AcDb*text"    If getobj1 Is Nothing Then GoTo Finish        Dim FType, FData    BuildFilter FType, FData, -4, "<or", 0, "insert", 0, "*text", -4, "or>"    ssetobj.SelectOnScreen FType, FData    If ssetobj.Count = 0 Then GoTo Finish '如果没有选择物体，结束程序    Dim textStr As String            If getobj1.ObjectName = "AcDbBlockReference" Then            Att1 = getobj1.GetAttributes()            textStr1 = Att1(0).TextString        ElseIf getobj1.ObjectName = "AcDbText" Then            textStr1 = getobj1.TextString        End If        For Each pickedObjs In ssetobj        If pickedObjs.ObjectName = "AcDbBlockReference" Then            Att2 = pickedObjs.GetAttributes()            Att2(0).TextString = textStr1        Else            pickedObjs.TextString = textStr1        End If    NextFinish:    ssetobj.Delete End Sub'函数如下Public Sub gwGetEntity(ent As Object, pickedPoint, Prompt As String, ParamArray gType())   '选择某一类型的实体，如果选择错误则继续，按ESC退出   'gtype是实体名称，不区分大小写，可以用通配符号，如"AcDbBlockReference"，"acdb*text"等   Dim i As Integer   Dim pd As Boolean   pd = False   Do    GetEntityEx ent, pickedPoint, Prompt        If ent Is Nothing Then        Exit Do    ElseIf UBound(gType) - LBound(gType) + 1 = 0 Then        Exit Do    Else        For i = LBound(gType) To UBound(gType)            If UCase(ent.ObjectName) Like UCase(gType(i)) Then                Exit Do            Else                pd = True            End If        Next i        If pd Then ThisDrawing.Utility.Prompt "选择的实体不符合要求．"    End If   Loop    End Sub Public Sub GetEntityEx(ent As Object, pickedPoint, Optional Prompt)    '选择实体，直到用户取消操作        On Error Resume Next StartLoop:        ThisDrawing.Utility.GetEntity ent, pickedPoint, Prompt        If Err Then                If ThisDrawing.GetVariable("errno") = 7 Then                        Err.Clear                        GoTo StartLoop                Else                       Err.Raise vbObjectError + 5, , "用户取消操作"                End If        End IfEnd Sub Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())        '用数组方式填充一对变量以用作为选择集过滤器使用        Dim FType() As Integer, FData()        Dim index As Long, i As Long               index = LBound(gCodes) - 1                        For i = LBound(gCodes) To UBound(gCodes) Step 2                index = index + 1                ReDim Preserve FType(0 To index)                ReDim Preserve FData(0 To index)                FType(index) = CInt(gCodes(i))                FData(index) = gCodes(i + 1)        Next        typeArray = FType: dataArray = FData End Sub

雪山飞狐_lzh

myfreemind发表于2004-6-6 11:51:00错误处理没写，所以一点要点准，呵呵 Sub tt()Dim pnt As VariantDim ent As AcadEntityDim stxt As StringDim mtxt As StringDim sset ...

可以用过滤器，只选择文字对象

xgngg

我试了一下，可以的，但是还有一个小问题，


就是在使用中我想同时可以使用CAD的某些功能，如实时缩放，平移等


不知以上程序如何处理，如果VBA运行的同时不能使用CAD命令，那画图的速度很慢的！

subtlation

如果要要使用缩放和平移等透明命令，那要用本版面的置顶帖子 getxx类。


我当时写的时候没有考虑用透明命令。


楼主用的cad版本是什么？autocad2004以上就有滚轮缩放功能，不需要缩放平移等透明命令了，滚轮缩放功能在vba中能用的。