CAD vba 实现批量修改dwg文件字体类型

    对于大批量修改dwg文件字体,逐文件打开并修改费时又费力，此vba代码可一键轻松搞定。

    第一步：本例中替换后的字体及路径为"c:\windows\fonts\simplex.ttf"，如需改为特定字体，需找到特定字体的完整路径，并在代码中替换掉"c:\windows\fonts\simplex.ttf" 。（引号为英文状态下，切记不可错）

    第二部：运行程序，选择dwg文件所在的文件夹，即可。

(备注：引用此代码请注明来源；若需修改都行文字字体及其他业务合作需求，请联系qq:443440204)       

Sub changtextstyle()
'yngqq443440204
On Error Resume Next
Dim mytxtstyle As AcadTextStyle
 '添加mytxt样式
Dim result
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim sel As AcadSelectionSet
ftype(0) = 0: fdata(0) = "text"
Dim ent As AcadEntity
Dim myfolder As String: Dim folderfile As String
myfolder = "C:\Users\Administrator\Desktop\新建文件夹" '替换成你的文件夹路径
folderfile = Dir(myfolder & "\*.dwg")

Do While folderfile <> ""
Documents.Open myfolder & "\" & folderfile
Set mytxtstyle = ThisDrawing.TextStyles.Add("mytxt")
mytxtstyle.fontFile = "c:\windows\fonts\simplex.ttf" '设置字体文件为仿宋体

ThisDrawing.ActiveTextStyle = mytxtstyle  '将当前文字样式设置为mytxt
Set sel = ThisDrawing.SelectionSets.Add("mysel")
sel.Select acSelectionSetAll, , , ftype, fdata
    For Each ent In sel
        ent.StyleName = "mytxt"
    Next ent
sel.Delete
ThisDrawing.Close
folderfile = Dir
Loop

result = MsgBox("ok!已完成" & vbCr & "若需合并多行文字及其他业务合作请联系qq:443440204", 0, "业务合作请联系qq:443440204")
End Sub