批量替换多个dwg内文字和多行文字（CAD vba）

打开一个新建DWG图形，运行CAD VBA，根据弹出对话框提示选择文件夹，点击确定即可自动执行程序，替换文件夹内所有DWG文件的字体（替换前文字和替换后文字需在代码中自己修改）。

插件使用方法：cad命令行输入：appload,加载此插件，然后运行宏即可（有其他事项请联系博主）。

代码如下：

Sub 替换cad文字()
'yngqq443440204
Dim ftype(0) As Integer, fdata(0) As Variant
Dim folderPath As String
Dim path As String
Dim oldText As String
oldText = "王" '需要替换的文字 旧文字
Dim newText As String
newText = "汪" '替换后的文字
Dim counter As Integer
counter = 0 '计数器，记录替换的文字数量
Dim fileName As String
folderPath = "C:\Users\Administrator\Desktop\新建文件夹" '替换成你的文件夹路径
fileName = Dir(folderPath & "\*.dwg")  '获取文件夹中的DWG文件
Do While fileName <> ""
    ftype(0) = 0: fdata(0) = "text,mtext"
    Dim acadDoc As AcadDocument
    Set acadDoc = Documents.Open(folderPath & "\" & fileName)
    Dim selSet As AcadSelectionSet
    Set selSet = ThisDrawing.SelectionSets.Add("MySelectionSet")
    selSet.Select acSelectionSetAll, , , ftype, fdata
    Dim objText As Object
    For Each objText In selSet
        If InStr(1, objText.TextString, oldText, vbTextCompare) > 0 Then
        objText.TextString = Replace(objText.TextString, oldText, newText, , , vbTextCompare)
        ThisDrawing.Regen acActiveViewport
        counter = counter + 1
        End If
    Next objText
    selSet.Delete
    ThisDrawing.Close
    fileName = Dir()
Loop
MsgBox "共替换了 " & counter & " 个文字 " & Space(20) & vbCr & "业务合作请联系qq:443440204", , "版权所有qq:443440204"
End Sub