[编程申请]：如何实现所有文字的字体格式与指定文字一致

liangjw

用CAD所提供的格式刷无法实现文字字体的格式与指定字体一致，请高手帮忙编程，具体要求见附件。

XDSoft

最初由 liangjw 发布
[B]用CAD所提供的格式刷无法实现文字字体的格式与指定字体一致，请高手帮忙编程，具体要求见附件。 [/B]

晓东工具箱－文字部分提供了50多个命令，足够解决文字应用问题了，去下载看看。

efan2000

最初由 liangjw 发布
[B]用CAD所提供的格式刷无法实现文字字体的格式与指定字体一致，请高手帮忙编程，具体要求见附件。 [/B]

        其实这是CAD中多行文字所设置的格式引起的，红色部分的文字的格式为\fTahoma;\C1;，绿色部分的文字的格式为\f宋体，故格式刷无法实现。

yy225cn

估计是因为用的是多行文字的问题，如果用单行文字的话，应该很好编辑了

wufei1

我的办法是先将它们炸掉，在用格式刷即可！

efan2000

附上一段程序，你可以试一试。

2. 
   
3.   [FONT=courier new]
   
4. 
   
5. '注意本程序只更改字体和颜色，在使用前请先使用格式刷更改其它格式
   
6. Sub Test()
   
7.     Dim EntObj As AcadEntity
   
8.     Dim pPt As Variant
   
9.     Dim sTextString As String
   
10.     Dim iFontPos As Integer
    
11.     Dim sFont As String
    
12.     Dim iColorPos As Integer
    
13.     Dim sColor As String
    
14.    
    
15.     On Error GoTo ErrTrap
    
16.     ThisDrawing.Utility.GetEntity EntObj, pPt, "指定参照的多行文本: "
    
17.     EntObj.Highlight True '实体亮显
    
18.     If Not (TypeOf EntObj Is AcadMText) Then
    
19.         EntObj.Highlight False
    
20.         Exit Sub
    
21.     End If
    
22.     sTextString = EntObj.TextString
    
23.     iFontPos = InStr(sTextString, "\f")
    
24.     sFont = Mid(sTextString, iFontPos, InStr(iFontPos, sTextString, ";") - iFontPos) '要参照的多行文本字体格式
    
25.     iColorPos = InStr(sTextString, "\C")
    
26.     If iColorPos <> 0 Then sColor = Mid(sTextString, iColorPos, InStr(iColorPos, sTextString, ";") - iColorPos) '要参照的多行文本颜色格式
    
27.     ThisDrawing.Utility.GetEntity EntObj, pPt, "指定变更的多行文本: "
    
28.     If Not (TypeOf EntObj Is AcadMText) Then Exit Sub
    
29.     sTextString = EntObj.TextString
    
30.     iFontPos = InStr(sTextString, "\f")
    
31.     EntObj.TextString = Left(sTextString, iFontPos - 1) & sFont & Mid(sTextString, InStr(iFontPos, sTextString, ";"))
    
32.     sTextString = EntObj.TextString
    
33.     iColorPos = InStr(sTextString, "\C")
    
34.     If iColorPos = 0 Then '要变更的多行文本颜色格式不存在
    
35.         iFontPos = InStr(sTextString, "\f")
    
36.         iFontPos = InStr(iFontPos, sTextString, ";")
    
37.         If sColor <> "" Then EntObj.TextString = Left(sTextString, iFontPos) & sColor & ";" & Mid(sTextString, iFontPos + 1)
    
38.     Else
    
39.         If sColor = "" Then '要参照的多行文本颜色格式不存在
    
40.             EntObj.TextString = Left(sTextString, iColorPos - 1) & Mid(sTextString, InStr(iColorPos, sTextString, ";") + 1)
    
41.         Else
    
42.              EntObj.TextString = Left(sTextString, iColorPos - 1) & sColor & Mid(sTextString, InStr(iColorPos, sTextString, ";"))
    
43.         End If
    
44.     End If
    
45.     Set EntObj = Nothing
    
46.     ThisDrawing.Regen acActiveViewport
    
47.     Exit Sub
    
48.    
    
49. ErrTrap:
    
50.     If ThisDrawing.GetVariable("errno") = 7 Then Resume
    
51.     If Not (EntObj Is Nothing) Then
    
52.         EntObj.Highlight False
    
53.         Set EntObj = Nothing
    
54.     End If
    
55.     On Error GoTo 0
    
56. End Sub
    
57.   [/FONT]
    

<br />   [FONT=courier new]<br /> <br /> '注意本程序只更改字体和颜色，在使用前请先使用格式刷更改其它格式<br /> Sub Test()<br />     Dim EntObj As AcadEntity<br />     Dim pPt As Variant<br />     Dim sTextString As String<br />     Dim iFontPos As Integer<br />     Dim sFont As String<br />     Dim iColorPos As Integer<br />     Dim sColor As String<br />     <br />     On Error GoTo ErrTrap<br />     ThisDrawing.Utility.GetEntity EntObj, pPt, "指定参照的多行文本: "<br />     EntObj.Highlight True '实体亮显<br />     If Not (TypeOf EntObj Is AcadMText) Then<br />         EntObj.Highlight False<br />         Exit Sub<br />     End If<br />     sTextString = EntObj.TextString<br />     iFontPos = InStr(sTextString, "\f")<br />     sFont = Mid(sTextString, iFontPos, InStr(iFontPos, sTextString, ";") - iFontPos) '要参照的多行文本字体格式<br />     iColorPos = InStr(sTextString, "\C")<br />     If iColorPos <> 0 Then sColor = Mid(sTextString, iColorPos, InStr(iColorPos, sTextString, ";") - iColorPos) '要参照的多行文本颜色格式<br />     ThisDrawing.Utility.GetEntity EntObj, pPt, "指定变更的多行文本: "<br />     If Not (TypeOf EntObj Is AcadMText) Then Exit Sub<br />     sTextString = EntObj.TextString<br />     iFontPos = InStr(sTextString, "\f")<br />     EntObj.TextString = Left(sTextString, iFontPos - 1) & sFont & Mid(sTextString, InStr(iFontPos, sTextString, ";"))<br />     sTextString = EntObj.TextString<br />     iColorPos = InStr(sTextString, "\C")<br />     If iColorPos = 0 Then '要变更的多行文本颜色格式不存在<br />         iFontPos = InStr(sTextString, "\f")<br />         iFontPos = InStr(iFontPos, sTextString, ";")<br />         If sColor <> "" Then EntObj.TextString = Left(sTextString, iFontPos) & sColor & ";" & Mid(sTextString, iFontPos + 1)<br />     Else<br />         If sColor = "" Then '要参照的多行文本颜色格式不存在<br />             EntObj.TextString = Left(sTextString, iColorPos - 1) & Mid(sTextString, InStr(iColorPos, sTextString, ";") + 1)<br />         Else<br />              EntObj.TextString = Left(sTextString, iColorPos - 1) & sColor & Mid(sTextString, InStr(iColorPos, sTextString, ";"))<br />         End If<br />     End If<br />     Set EntObj = Nothing<br />     ThisDrawing.Regen acActiveViewport<br />     Exit Sub<br />     <br /> ErrTrap:<br />     If ThisDrawing.GetVariable("errno") = 7 Then Resume<br />     If Not (EntObj Is Nothing) Then<br />         EntObj.Highlight False<br />         Set EntObj = Nothing<br />     End If<br />     On Error GoTo 0<br /> End Sub<br />   [/FONT]<br />