[原创]：通配符替换程序

雪山飞狐(lzh)

Public Sub SuperReplace()
'支持通配符*格式的替换
'例：*(*)->*

或A*B*->B*C*
'保证替换前后*的数量相同
On Error Resume Next
    Dim ss As AcadSelectionSet
    Dim str As String
    Dim pStart As String, pEnd As String
    Dim i As AcadEntity, j
    Dim ft(1) As Integer, fd(1)
    Dim pSS, pES
    Dim pStrs() As String
    Dim pSpec As String

    ThisDrawing.SelectionSets("*TlsText*").Delete
    Set ss = ThisDrawing.SelectionSets.Add("*TlsText*")
   
    pStart = Trim(ThisDrawing.Utility.GetString(False, "替换前："))
    pEnd = Trim(ThisDrawing.Utility.GetString(False, "替换后："))
    pSS = Split(pStart, "*")
    pES = Split(pEnd, "*")
   
    pSpec = Replace(pStart, "`", "``")
    pSpec = Replace(pSpec, "[", "`[")
    pSpec = Replace(pSpec, "]", "`]")
    pSpec = Replace(pSpec, ",", "`,")
    pSpec = Replace(pSpec, "@", "`@")
    pSpec = Replace(pSpec, "~", "`~")
    pSpec = Replace(pSpec, ".", "`.")
    pSpec = Replace(pSpec, "?", "`?")
    ft(0) = 0: fd(0) = "*Text"
    ft(1) = 1: fd(1) = pSpec
    ss.Select acSelectionSetAll, , , ft, fd
   
   
    For Each i In ss
   
        str = i.TextString
        
        ReDim pStrs(UBound(pSS) + 1) As String
        For j = 0 To UBound(pSS)
            pStrs(j) = LeftStr(str, pSS(j)) & pES(j)
            str = RightStr(str, pSS(j))
        Next j
        
        pStrs(UBound(pSS) + 1) = str
        i.TextString = Join(pStrs, "")
        
    Next i
   
    ThisDrawing.SelectionSets("*TlsText*").Delete

End Sub

Public Function LeftStr(ByVal String1 As Variant, ByVal String2 As Variant)
On Error Resume Next
    LeftStr = Left(String1, InStr(String1, String2) - 1)
    If Err Then LeftStr = ""
End Function

Public Function RightStr(ByVal String1 As Variant, ByVal String2 As Variant)
On Error Resume Next
    RightStr = Right(String1, Len(String1) - Len(String2) - InStr(String1, String2) + 1)
    If Err Then RightStr = ""
End Function

自由的鱼

好程序，L兄这个就是个通用版本了~~~

雪山飞狐(lzh)

升级版，支持输入空格，应该是说消除Bug，支持替换前后*的数量不等
Public Sub SuperReplace()
On Error Resume Next
    Dim ss As AcadSelectionSet
    Dim str As String
    Dim pStart As String, pEnd As String
    Dim i As AcadEntity, j
    Dim ft(1) As Integer, fd(1)
    Dim pSS, pES
    Dim pStrs() As String
    Dim pSpec As String

    ThisDrawing.SelectionSets("*TlsText*").Delete
    Set ss = ThisDrawing.SelectionSets.Add("*TlsText*")
   
    pStart = Trim(ThisDrawing.Utility.GetString(True, "替换前："))
    pEnd = Trim(ThisDrawing.Utility.GetString(True, "替换后："))
    pSS = Split(pStart, "*")
    pES = Split(pEnd, "*")
    pSpec = Replace(pStart, "`", "``")
    pSpec = Replace(pSpec, "[", "`[")
    pSpec = Replace(pSpec, "]", "`]")
    pSpec = Replace(pSpec, ",", "`,")
    pSpec = Replace(pSpec, "@", "`@")
    pSpec = Replace(pSpec, "~", "`~")
    pSpec = Replace(pSpec, ".", "`.")
    pSpec = Replace(pSpec, "?", "`?")
    ft(0) = 0: fd(0) = "*Text"
    ft(1) = 1: fd(1) = pSpec
    ss.SelectOnScreen ft, fd
   
   
    For Each i In ss
    If UBound(pES) = 0 Then
        i.TextString = pEnd
    Else
        str = i.TextString
        ReDim pStrs(UBound(pSS) + 1) As String
        For j = 0 To UBound(pSS)
            pStrs(j) = LeftStr(str, pSS(j)) & pES(j)
            str = RightStr(str, pSS(j))
        Next j
        
        pStrs(UBound(pSS) + 1) = str
        i.TextString = Join(pStrs, "")
    End If
    Next i
   
    ThisDrawing.SelectionSets("*TlsText*").Delete

End Sub

r33d

在VBA 高级开发指南 中有，  这个*字符英文叫法好象是 Token之类吧

好为人师

用不了,支持cad2002吗?再问个很菜问题,怎么把上述文字加载到cad里

雪山飞狐(lzh)

[工具]->[宏]->[VB编辑器]->双击[Thisdrawing]
把代码Copy到右边
运行vbarun命令

好为人师

不行啊,cad2002下提示子过程或函数未定义,加载一楼未升级版本就行,请教原因?
另外,命令好像全部替换,不支持选择范围或单个替换?如果那样局限太大,期待改进

雪山飞狐(lzh)

添加下列代码：
Public Function LeftStr(ByVal String1 As Variant, ByVal String2 As Variant)
On Error Resume Next
LeftStr = Left(String1, InStr(String1, String2) - 1)
If Err Then LeftStr = ""
End Function

Public Function RightStr(ByVal String1 As Variant, ByVal String2 As Variant)
On Error Resume Next
RightStr = Right(String1, Len(String1) - Len(String2) - InStr(String1, String2) + 1)
If Err Then RightStr = ""
End Function
选择范围或单个替换的你可以自己试试：）

好为人师

不行啊,版主,我把以上代码添加到最后,提示找不到工程或库

cityplan

好东东，学了一招！

好为人师

奇怪,重启cad后又得了,

pyzwlp

PKPM版本中提供了一个“ETR.LSP”就是一个这样的修改程序的。
还有CHTEXT.LSP也可以完成这工作的。