如何用VBA更改字体的字形名称（黑体，宋体等）

兰州人 · 发表于 2015-10-11 22:52:55

本帖最后由兰州人于 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

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

mikewolf2k · 发表于 2015-10-12 10:46:47

如果没记错的话，不能改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

兰州人 · 发表于 2015-10-12 19:19:20

谢谢回复
附件第三软件(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

mikewolf2k · 发表于 2015-10-13 09:19:41

同样问题哈。以下是我的代码
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

账号		自动登录	找回密码
密码			注册

如何用VBA更改字体的字形名称（黑体，宋体等）

相关帖子

本帖子中包含更多资源