请高手帮我编个修改字体的CAD宏
ltj6407
ltj6407 Lv.7
2007年11月02日 22:05:29
来自于行业脉动
只看楼主

我经常要遇到一张图子的的多行文字字体设为中文后(如宋体),无法统一改为CAD系统子体。手工修改只能一组组修改,很烦,若能像Excel一样用宏做重复的工作,那就简单了。附操作过程录修(中间选择文字过程不明显)

我经常要遇到一张图子的的多行文字字体设为中文后(如宋体),无法统一改为CAD系统子体。手工修改只能一组组修改,很烦,若能像Excel一样用宏做重复的工作,那就简单了。附操作过程录修(中间选择文字过程不明显)
a21955bd1715e30ad6d4.rar
766 KB
立即下载
免费打赏
tongmingniao
2009年03月16日 22:54:37
2楼
这个问题也是困扰我好久的问题,现在终于有了完整的解决方案。以下是vba程序。
Option Explicit

'提取和替换多行文字内容
Public Sub GetAndReplaceMTextString()
Dim SSet As AcadSelectionSet
Set SSet = ThisDrawing.PickfirstSelectionSet
If SSet.Count = 0 Then
MsgBox "未选择对象"
Exit Sub
End If
Dim objMText As AcadEntity
Dim ptMin As Variant, ptMax As Variant
Dim ptCenter(0 To 2) As Double
Dim radius As Double
For Each objMText In SSet
If TypeOf objMText Is AcadMText Then
objMText.TextString = GetMTextUnformatString(objMText.TextString)
End If
Next
ThisDrawing.Regen True
End Sub

Public Function GetMTextUnformatString(MTextString As String) As String
Dim s As String
Dim RE As Object
' 获取Regular Expressions组件
Set RE = ThisDrawing.Application.GetInterfaceObject("Vbscript.RegExp")
' 忽略大小写
RE.IgnoreCase = True
' 搜索整个字符串
RE.Global = True
s = MTextString

'替换\\字符
RE.Pattern = "\\\\"
s = RE.Replace(s, Chr(1))
'替换\{字符
RE.Pattern = "\\{"
s = RE.Replace(s, Chr(2))
'替换\}字符
RE.Pattern = "\\}"
s = RE.Replace(s, Chr(3))

'删除段落缩进格式
RE.Pattern = "\\pi(.[^;]*);"
s = RE.Replace(s, "")
'删除制表符格式
RE.Pattern = "\\pt(.[^;]*);"
s = RE.Replace(s, "")
'删除堆迭格式
RE.Pattern = "\\S(.[^;]*)(\^|#|\\)(.[^;]*);"
s = RE.Replace(s, "$1$3")
'删除字体、颜色、字高、字距、倾斜、字宽、对齐格式
RE.Pattern = "(\\F|\\C|\\H|\\T|\\Q|\\W|\\A)(.[^;]*);"
s = RE.Replace(s, "")
'删除下划线、删除线格式
RE.Pattern = "(\\L|\\O|\\l|\\o)"
s = RE.Replace(s, "")
'删除不间断空格格式
RE.Pattern = "\\~"
s = RE.Replace(s, " ")
'删除换行符格式
RE.Pattern = "\\P"
s = RE.Replace(s, "")
'删除换行符格式(针对Shift+Enter格式)
RE.Pattern = vbLf
s = RE.Replace(s, "")
'删除{}
RE.Pattern = "({|})"
s = RE.Replace(s, "")

'替换回\\,\{,\}字符
RE.Pattern = "\x01"
s = RE.Replace(s, "\")
RE.Pattern = "\x02"
s = RE.Replace(s, "{")
RE.Pattern = "\x03"
s = RE.Replace(s, "}")

Set RE = Nothing

GetMTextUnformatString = s
End Function
回复

相关推荐

APP内打开