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

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) = ""
    ''
    '选择过滤出图形中所有的标注对象
    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

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

请点击此处下载

请先注册会员后在进行下载

已注册会员，请先登录后下载

文件名称:nwqpbnwt4dk.dwg 
下载次数:0  文件大小:58.9 KB  售价:2银币 [记录]
下载权限: 不限 以上或 Vip会员   [开通Vip]   [签到领银币]  [免费赚银币]