024集——批量复制文字样式、改变文本文字样式——vba代码实现

CAD vba 不可直接修改文字样式的名称，可复制文字样式，文字样式名称前加特定前缀

要为对象改变文字样式，可使用 StyleName 属性。

If ent.ObjectName = "AcDbText" Then ent.StyleName = "新的"

     Set sel = creatsel("mysell")
     sel.Select acSelectionSetAll, , , ftype, fdata
     For i = 0 To sel.Count - 1
        sel.Item(i).StyleName = "新的Standard"
     Next i

原始文字样式如下：

复制后： 

代码如下：

Public Function creatsel(Optional ByVal mys As String = "mysel") As AcadSelectionSet
On Error Resume Next
Dim sel As AcadSelectionSet
   If Not IsNull(ThisDrawing.SelectionSets.Item(mys)) Then
       Set creatsel = ThisDrawing.SelectionSets.Item(mys)
       creatsel.Delete
''如果图中有名为"mysel"的选择集，那么把这个选择集放入sel中，然后删除这个选择集
    End If
''如果图中没有"mysel"，那么新建一个名为"mysel"的选择集，赋给sel这个对象
Set creatsel = ThisDrawing.SelectionSets.Add(mys)
End Function

Sub copy_textstyle()
On Error Resume Next
Dim oldtextstyle As AcadTextStyle
Dim newtextstyle As AcadTextStyle
Dim ent As AcadEntity
Dim mytext As AcadText
Dim mydoc As AcadDocument
Dim mylayoutt As AcadLayout
Dim ftype(0) As Integer, fdata(0) As Variant
Dim ftype2(0) As Integer, fdata2(0) As Variant
Dim mydimstyle   As AcadDimStyle
ftype(0) = 0: fdata(0) = "text,mtext,dimension"
ftype2(0) = 0: fdata2(0) = "dimstyle"
Set mydoc = Application.ActiveDocument
Dim textstyle_count As Integer
Dim tempHeight() As String
Dim tempwidth() As String
Dim tempObliqueAngle() As String
Dim tempfontFile() As String
Dim tempname() As String
Dim j As Integer, counter_textstyle As Integer
Set alltextstyle = ThisDrawing.TextStyles
textstyle_count = ThisDrawing.TextStyles.Count
'循环老字体样式，将名称和属性放入数组
For Each oldtextstyle In ThisDrawing.TextStyles
    ReDim Preserve tempHeight(j)
    ReDim Preserve tempwidth(j)
    ReDim Preserve tempObliqueAngle(j)
    ReDim Preserve tempfontFile(j)
    ReDim Preserve tempname(j)
    tempHeight(j) = oldtextstyle.Height
    tempwidth(j) = oldtextstyle.Width
    tempObliqueAngle(j) = oldtextstyle.ObliqueAngle
    tempfontFile(j) = oldtextstyle.fontFile
    tempname(j) = oldtextstyle.Name
'    Set sel = creatsel("mysell")
'   'MsgBox "c:\windows\fonts\" & oldtextstyle.fontFile
'    sel.Select acSelectionSetAll, , , ftype, fdata
'    For i = 0 To sel.Count - 1
'    sel.Item(i).TextStyle = ThisDrawing.TextStyles.Item(2)
'        If InStr(1, sel.Item(i).StyleName, "Standard", vbTextCompare) < 1 Then
'           If sel.Item(i).StyleName = oldtextstyle.Name Then
'
'           MsgBox InStr(1, sel.Item(i).StyleName, "Standard", vbTextCompare)
'             'On Error Resume Next
'             sel.Item(i).StyleName = "新的-" & oldtextstyle.Name
'             On Error GoTo 0
'             End If
'        End If
'    Next i
    'oldtextstyle.Delete
 counter_textstyle = counter_textstyle + 1
 j = j + 1
Next oldtextstyle
'循环，创建新数组
For j = 0 To counter_textstyle - 1
    Set newtextstyle = ThisDrawing.TextStyles.Add("新的" & tempname(j))
    newtextstyle.Height = tempHeight(j)
    newtextstyle.Width = tempwidth(j)
    newtextstyle.ObliqueAngle = tempObliqueAngle(j)
    newtextstyle.fontFile = tempfontFile(j)
Next j
MsgBox "OK    CAD二次开发qq:443440204", , "qq443440204"
End Sub

TextStyle 对象

文字样式(或称字型)，已命名并保存的用于确定文字字符串外观的设置集。

VBA 类名:	AcadTextStyle
创建方法:	TextStyles.Add
访问途径:	TextStyles.Item Document.ActiveTextStyle

要控制文字样式的设置，可以用如下属性或文字样式系统变量。可在AutoCAD 命令参考 的系统变量中查看文字样式系统变量。

当前的文字样式（由 ActiveTextStyle 属性设置）决定了图形中新创建的文字和已存在的没有指定明确文字样式的文字的外观。

如果当前 TextStyle 中的格式有所更改，更改后的 TextStyle 对象必须重置为当前 TextStyle，而且必须调用 Regen 方法来改变显示。要重置当前 TextStyle，只需使用 ActiveTextStyle 属性再调用已更新的 TextStyle 对象。

为对象指定其它文字样式可让其不随当前文字样式的改变而改变，要为对象指定文字样式，可使用 StyleName 属性。

方法 Delete GetExtensionDictionary GetFont GetXData SetFont SetXData

属性 Application BigFontFile Document FontFile Handle HasExtensionDictionary Height LastHeight Name ObjectID ObjectName ObliqueAngle OwnerID TextGenerationFlag Width

事件 Modified