如何用VBA更改字体的字形名称（黑体，宋体等）
本帖最后由 兰州人 于 2015-10-12 07:28 编辑下面代码是通过数据集，fDataArr = Array("MText", "Text"): fTypeArr = Array("0", "0")
通过ReturnAllSelectSet获得MText,Text集。
Case "AcDbText"
Set objTxt = objSet.Item(ii)
With objTxt
'Debug.Print .TextString
'Debug.Print .ScaleFactor
.ScaleFactor = 0.5
End With
请求帮助，如何更改text的字体字形名，如更改为黑体，宋体字Sub ls1()
Dim objSet As AcadSelectionSet
Dim fDataArr, fTypeArr
fDataArr = Array("Line", "Arc"): fTypeArr = Array("0", "0")
fDataArr = Array("Line", "Text"): fTypeArr = Array("0", "0")
fDataArr = Array("Text"): fTypeArr = Array("0")
fDataArr = Array("MText", "Text"): fTypeArr = Array("0", "0")
Dim objLine As AcadLine, objArc As AcadArc, objText As AcadText
Set objSet = ReturnAllSelectSet(fTypeArr, fDataArr)
Dim objTxt As AcadText, objMTxt As AcadMText
''
For ii = 0 To objSet.Count - 1
'Debug.Print objSet.Item(ii).ObjectName
Select Case objSet.Item(ii).ObjectName
Case "AcDbText"
Set objTxt = objSet.Item(ii)
With objTxt
'Debug.Print .TextString
'Debug.Print .ScaleFactor
.ScaleFactor = 0.5
End With
Case "AcDbMText"
Set objMTxt = objSet.Item(ii)
With objMTxt
Debug.Print .TextString
End With
End Select
Next ii
End Sub
Function ReturnAllSelectSet(fTypeArray As Variant, fDataArray As Variant) As AcadSelectionSet
Dim Sset As AcadSelectionSet
On Error Resume Next
'建立选择集
ThisDrawing.SelectionSets("aa").Delete
Set Sset = ThisDrawing.SelectionSets.Add("aa")
'建立过滤器
Dim fType, fData
ReDim fType(0 To UBound(fTypeArray) + 2) As Integer
ReDim fData(0 To UBound(fDataArray) + 2) As Variant
fType(0) = -4
For ii = 0 To UBound(fTypeArray)
fType(ii + 1) = fTypeArray(ii)
Next ii
fType(UBound(fType)) = -4
''
fData(0) = "<Or"
For ii = 0 To UBound(fDataArray)
fData(ii + 1) = fDataArray(ii)
Next ii
fData(UBound(fData)) = "Or>"
''
'选择过滤出图形中所有的标注对象
Sset.Select acSelectionSetAll, , , fType, fData
Set ReturnAllSelectSet = Sset
End Function
Private Sub ll()
Dim Count As Integer
Dim Ent As AcadEntity, BlkRef As AcadBlockReference
Dim mTxtEnt As AcadMText, TxtEnt As AcadText
For ii = 0 To ThisDrawing.ModelSpace.Count - 1
Set Ent = ThisDrawing.ModelSpace.Item(ii)
Select Case Ent.ObjectName
Case "AcDbBlockReference"
Set BlkRef = Ent
Case "AcDbMText"
Set mTxtEnt = Ent
Debug.Print mTxtEnt.TextString
End Select
Next ii
End Sub 如果没记错的话，不能改text的font，只能改该text所属的textstyle的fontfile。
For I = 0 To ActiveDocument.TextStyles.Count - 1
Select Case ActiveDocument.TextStyles.Item(I).Name
Case "KADER35", "KADER50", "HELVL", "ST1", "ISO2_5"
ActiveDocument.TextStyles.Item(I).fontFile = Application.Path & "\fonts\txt.shx"
Case Else
End Select
Next I
谢谢回复
附件第三软件(Solidworks)自动生成的DWG文件。
文字处理格式总会有些问题，只能用AutoCAD的VBA方法处理。
、
现在解决方法用人工爆炸文字后，用下面代码进行处理。Private Sub ll3()
Dim Ent As AcadEntity, BlkRef As AcadBlockReference, E() As AcadEntity
Dim mTxtEnt As AcadMText, TxtEnt As AcadText, Kk As Integer
For ii = 0 To ThisDrawing.ModelSpace.Count - 1
Set Ent = ThisDrawing.ModelSpace.Item(ii)
Select Case Ent.ObjectName
Case "AcDbText"
Set TxtEnt = Ent
TxtEnt.ScaleFactor = 0.7
End Select
Next ii
End Sub
同样问题哈。以下是我的代码
Sub ChangeFontWidth()
Dim I As Integer, J As Integer, K As Integer
Dim varAttributes As Variant
Dim ssetObj As AcadSelectionSet
For I = 0 To ActiveDocument.TextStyles.Count - 1
Select Case ActiveDocument.TextStyles.Item(I).Name
Case "KADER35", "KADER50", "HELVL", "ST1", "ISO2_5"
ActiveDocument.TextStyles.Item(I).fontFile = Application.Path & "\fonts\txt.shx"
Case Else
End Select
Next I
Set ssetObj = CreateSelectionSet("textobj")
Dim FType, FData
BuildFilter FType, FData, -4, "<or", 0, "text", 0, "mtext", 0, "insert", -4, "or>"
'SsetObj.SelectOnScreen ftype, fdata
ssetObj.Select acSelectionSetAll, , , FType, FData
For I = 0 To ssetObj.Count - 1
Select Case ssetObj.Item(I).ObjectName
Case "AcDbText" ', "AcDbMText"
Select Case ssetObj.Item(I).StyleName
Case "KADER35", "KADER50", "HELVL", "ST1", "ISO2_5"
ssetObj.Item(I).ScaleFactor = 0.64
Case Else
End Select
ssetObj.Item(I).Update
Case "AcDbBlockReference"
If ssetObj.Item(I).HasAttributes Then
varAttributes = ssetObj.Item(I).GetAttributes
For J = LBound(varAttributes) To UBound(varAttributes)
Select Case varAttributes(J).StyleName
Case "KADER35", "KADER50", "HELVL", "ST1", "ISO2_5"
varAttributes(J).ScaleFactor = 0.64
Case Else
End Select
varAttributes(J).Update
Next J
End If
End Select
ssetObj.Item(I).Update
Next I
ssetObj.Clear
'ActiveDocument.Utility.Prompt vbLf & replacedtext & " text(s) replaced!" & vbLf
End Sub
页:
[1]