求助，关于修改文字的问题
我想用VBA编一个修改文字的程序，就好象CAD的特性匹配一样，只要选择了参照文字，其他被选择的文字对象都改变了
比如：图中有是个文字，分别是“A”，“B”，“C”，“D”
我想把“B”改成“A”，只要选择“A”，再刷一下“B”，“B”就变成“A”了。 错误处理没写，所以一点要点准，呵呵
Sub tt()<BR>Dim pnt As Variant<BR>Dim ent As AcadEntity<BR>Dim stxt As String<BR>Dim mtxt As String<BR>Dim sset As AcadSelectionSet<BR>Dim i As Integer<BR>For i = 0 To ThisDrawing.SelectionSets.Count - 1<BR> ThisDrawing.SelectionSets.Item(i).Clear<BR> ThisDrawing.SelectionSets.Item(i).Delete<BR>Next<BR>ThisDrawing.Utility.GetEntity ent, pnt, "choose"<BR>stxt = ent.TextString<BR>Set sset = ThisDrawing.SelectionSets.Add("tt")
sset.SelectOnScreen<BR>For i = 0 To sset.Count - 1<BR>sset.Item(i).TextString = stxt<BR>Next<BR>End Sub<BR> 这个我写过，和楼主所说的功能一模一样。对于属性文字也可以（不过属性中只提取第一个文字），不过对于Mtext没有试过，不知道好不好用。代码如下：'主程序如下
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
myfreemind发表于2004-6-6 11:51:00static/image/common/back.gif错误处理没写，所以一点要点准，呵呵
Sub tt()Dim pnt As VariantDim ent As AcadEntityDim stxt As StringDim mtxt As StringDim sset ...
可以用过滤器，只选择文字对象<BR> 我试了一下，可以的，但是还有一个小问题，
就是在使用中我想同时可以使用CAD的某些功能，如实时缩放，平移等
不知以上程序如何处理，如果VBA运行的同时不能使用CAD命令，那画图的速度很慢的！ 如果要要使用缩放和平移等透明命令，那要用本版面的置顶帖子 getxx类。
我当时写的时候没有考虑用透明命令。
楼主用的cad版本是什么？autocad2004以上就有滚轮缩放功能，不需要缩放平移等透明命令了，滚轮缩放功能在vba中能用的。
页:
[1]