Cad vba—改变文字样式

已于 2025-06-04 20:59:15 修改
阅读量90 收藏
点赞数 2
CC 4.0 BY-SA版权
分类专栏： CAD VBA 文章标签： CAD
于 2024-08-15 17:23:01 首次发布
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.youkuaiyun.com/yongshiqq/article/details/141227479

 

Public alltextc As Integer
Public Function 改变块文字样式(ByVal oldstylename As String, Optional ByVal mynewtextstylename As String = "Standard")
'yngqq443440204@2024年8月16日21:21:10
'复制图中所有文字样式并加前缀，生成新的文字样式，
'并将图中所有实体的文字样式改为新的文字样式
'目前块参照中的文字样式尚未改变
'On Error Resume Next
Dim mybaaa As AcadBlock
'Dim sel As AcadSelectionSet
'Dim ftype(0) As Integer
'Dim fdata(0) As Variant
Dim ent As Object
Dim myb() As AcadBlock
'ftype(0) = 0: fdata(0) = "block"
'Set sel = creatsel()
'sel.Select acSelectionSetAll, , , ftype, fdata
For Each mybaaa In ThisDrawing.Blocks
    If Not (mybaaa.IsLayout Or mybaaa.IsXRef) Then
         ReDim Preserve myb(i)
         Set myb(i) = mybaaa
          For Each ent In myb(i)
            If InStr(1, ent.ObjectName, "text", vbTextCompare) > 0 Then

           'MsgBox ent.ObjectName

           If ent.StyleName = oldstylename Then
            ent.StyleName = mynewtextstylename
            alltextc = alltextc + 1
            End If
    '           Stop
            End If
          Next ent
         i = i + 1
    End If
Next mybaaa
End Function
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 改变文字样式()
'yngqq443440204@
'复制图中所有文字样式并加前缀，生成新的文字样式，
'并将图中所有实体的文字样式改为新的文字样式
'目前块参照中的文字样式尚未改变
'On Error Resume Next
Dim oldtextstyle As AcadTextStyle
Dim oldtextstylearr() As String
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) = "*table,text,mtext,dimension,*leader" 'AcDbMleader
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
'循环老字体样式，复制生成新的字体样式
Dim astring As String
For Each oldtextstyle In ThisDrawing.TextStyles()
    ReDim Preserve newtextstyle(i)
    ReDim Preserve oldtextstylearr(i)
    Set newtextstyle(i) = ThisDrawing.TextStyles.Add("新的" & oldtextstyle.Name)
    oldtextstylearr(i) = oldtextstyle.Name
    newtextstyle(i).Height = oldtextstyle.Height
    newtextstyle(i).Width = oldtextstyle.Width
    newtextstyle(i).ObliqueAngle = oldtextstyle.ObliqueAngle
    If oldtextstyle.fontFile <> "" Then
        newtextstyle(i).fontFile = oldtextstyle.fontFile
    End If
    i = i + 1
Next oldtextstyle
i = 0
''改变所有字体的字体样式
    Set sel = creatsel("mysell")

    sel.Select acSelectionSetAll, , , ftype, fdata
    For j = LBound(oldtextstylearr) To UBound(oldtextstylearr)
        temp = oldtextstylearr(j)
        '①改变块文字样式
        Call 改变块文字样式(temp, newtextstyle(j).Name)
        For i = 0 To sel.Count - 1

      '②修改表table中的文字样式
      If InStr(1, sel.Item(i).ObjectName, "table", vbTextCompare) > 0 Then
           'MsgBox sel.Item(i).ObjectName
           'MsgBox sel.Item(i).GetTextStyle(acHeaderRow)
           If sel.Item(i).GetTextStyle(acHeaderRow) = temp Then
           'MsgBox sel.Item(i).GetTextStyle(acHeaderRow)
           astring = sel.Item(i).SetTextStyle(acHeaderRow, newtextstyle(j).Name)
           'MsgBox sel.Item(i).GetTextStyle(acHeaderRow)
           End If
      End If
        '③引线中的文字的文字样式：textstylename,引线的样式为stylename
         If InStr(1, sel.Item(i).ObjectName, "leader", vbTextCompare) > 0 Then
           'MsgBox sel.Item(i).ObjectName
            Select Case sel.Item(i).TextStyleName
                Case temp
                    sel.Item(i).TextStyleName = newtextstyle(j).Name
                Case Else
            End Select
          End If
        '④普通文字  和块的文字样式名是ent.stylename，而标注的文字样式名是textstyle,标注名称是stylename
        If InStr(1, sel.Item(i).ObjectName, "text", vbTextCompare) > 0 Then

            Select Case sel.Item(i).StyleName
                Case temp
                    sel.Item(i).StyleName = newtextstyle(j).Name
                Case Else
            End Select
        End If
        '⑤修改标注的文字样式，textstyle
         If InStr(1, sel.Item(i).ObjectName, "dimension", vbTextCompare) > 0 Then
        'MsgBox sel.Item(i).ObjectName
            Select Case sel.Item(i).TextStyle
                Case temp
                    sel.Item(i).TextStyle = newtextstyle(j).Name
                Case Else
            End Select
          End If
        Next i
     Next j
MsgBox "OK    CAD二次开发qq:443440204", , "qq443440204"
Set mysttt = ThisDrawing.TextStyles.Item("standard")
ThisDrawing.ActiveTextStyle = mysttt
Stop
ThisDrawing.PurgeAll
End Sub





Public alltextc As Integer
Public Function 改变块文字样式(ByVal oldstylename As String, Optional ByVal mynewtextstylename As String = "Standard")
'yngqq443440204@2024年8月16日20:10:55
'复制图中所有文字样式并加前缀，生成新的文字样式，
'并将图中所有实体的文字样式改为新的文字样式
'目前块参照中的文字样式尚未改变
'On Error Resume Next
Dim mybaaa As AcadBlock
'Dim sel As AcadSelectionSet
'Dim ftype(0) As Integer
'Dim fdata(0) As Variant
Dim ent As Object
Dim myb() As AcadBlock
'ftype(0) = 0: fdata(0) = "block"
'Set sel = creatsel()
'sel.Select acSelectionSetAll, , , ftype, fdata
For Each mybaaa In ThisDrawing.Blocks
    If Not (mybaaa.IsLayout Or mybaaa.IsXRef) Then
         ReDim Preserve myb(i)
         Set myb(i) = mybaaa
          For Each ent In myb(i)
            If InStr(1, ent.ObjectName, "text", vbTextCompare) > 0 Then

           'MsgBox ent.ObjectName

           If ent.StyleName = oldstylename Then
            ent.StyleName = mynewtextstylename
            alltextc = alltextc + 1
            End If
    '           Stop
            End If
          Next ent
         i = i + 1
    End If
Next mybaaa
End Function
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 改变文字样式()
'yngqq443440204@2024年8月15日17:20:00
'复制图中所有文字样式并加前缀，生成新的文字样式，
'并将图中所有实体的文字样式改为新的文字样式
'目前块参照中的文字样式尚未改变
'On Error Resume Next
Dim oldtextstyle As AcadTextStyle
Dim oldtextstylearr() As String
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) = "*table,text,mtext,dimension,*leader" 'AcDbMleader
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
'循环老字体样式，复制生成新的字体样式
Dim astring As String
For Each oldtextstyle In ThisDrawing.TextStyles()
    ReDim Preserve newtextstyle(i)
    ReDim Preserve oldtextstylearr(i)
    Set newtextstyle(i) = ThisDrawing.TextStyles.Add("新的" & oldtextstyle.Name)
    oldtextstylearr(i) = oldtextstyle.Name
    newtextstyle(i).Height = oldtextstyle.Height
    newtextstyle(i).Width = oldtextstyle.Width
    newtextstyle(i).ObliqueAngle = oldtextstyle.ObliqueAngle
    newtextstyle(i).fontFile = oldtextstyle.fontFile
    i = i + 1
Next oldtextstyle
i = 0
''改变所有字体的字体样式
    Set sel = creatsel("mysell")

    sel.Select acSelectionSetAll, , , ftype, fdata
    For j = LBound(oldtextstylearr) To UBound(oldtextstylearr)
        temp = oldtextstylearr(j)
        '①改变块文字样式
        Call 改变块文字样式(temp, newtextstyle(j).Name)
        For i = 0 To sel.Count - 1

      '②修改表table中的文字样式
      If InStr(1, sel.Item(i).ObjectName, "table", vbTextCompare) > 0 Then
           'MsgBox sel.Item(i).ObjectName
           'MsgBox sel.Item(i).GetTextStyle(acHeaderRow)
           If sel.Item(i).GetTextStyle(acHeaderRow) = temp Then
           'MsgBox sel.Item(i).GetTextStyle(acHeaderRow)
           astring = sel.Item(i).SetTextStyle(acHeaderRow, newtextstyle(j).Name)
           'MsgBox sel.Item(i).GetTextStyle(acHeaderRow)
           End If
      End If
        '③引线中的文字的文字样式：textstylename,引线的样式为stylename
         If InStr(1, sel.Item(i).ObjectName, "leader", vbTextCompare) > 0 Then
           'MsgBox sel.Item(i).ObjectName
            Select Case sel.Item(i).TextStyleName
                Case temp
                    sel.Item(i).TextStyleName = newtextstyle(j).Name
                Case Else
            End Select
          End If
        '④普通文字  和块的文字样式名是ent.stylename，而标注的文字样式名是textstyle,标注名称是stylename
        If InStr(1, sel.Item(i).ObjectName, "text", vbTextCompare) > 0 Then

            Select Case sel.Item(i).StyleName
                Case temp
                    sel.Item(i).StyleName = newtextstyle(j).Name
                Case Else
            End Select
        End If
        '⑤修改标注的文字样式，textstyle
         If InStr(1, sel.Item(i).ObjectName, "dimension", vbTextCompare) > 0 Then
        'MsgBox sel.Item(i).ObjectName
            Select Case sel.Item(i).TextStyle
                Case temp
                    sel.Item(i).TextStyle = newtextstyle(j).Name
                Case Else
            End Select
          End If
        Next i
     Next j
MsgBox "OK    CAD二次开发qq:443440204", , "qq443440204"
Stop
ThisDrawing.PurgeAll
End Sub

 

Public alltextc As Integer
Public Function 改变块文字样式(ByVal oldstylename As String, Optional ByVal mynewtextstylename As String = "Standard")
'yngqq443440204@2024年8月15日17:20:00
'复制图中所有文字样式并加前缀，生成新的文字样式，
'并将图中所有实体的文字样式改为新的文字样式
'目前块参照中的文字样式尚未改变
'On Error Resume Next
Dim mybaaa As AcadBlock
'Dim sel As AcadSelectionSet
'Dim ftype(0) As Integer
'Dim fdata(0) As Variant
Dim ent As Object
Dim myb() As AcadBlock
'ftype(0) = 0: fdata(0) = "block"
'Set sel = creatsel()
'sel.Select acSelectionSetAll, , , ftype, fdata
For Each mybaaa In ThisDrawing.Blocks
    If Not (mybaaa.IsLayout Or mybaaa.IsXRef) Then
         ReDim Preserve myb(i)
         Set myb(i) = mybaaa
          For Each ent In myb(i)
            If InStr(1, ent.ObjectName, "text", vbTextCompare) > 0 Then
          
           'MsgBox ent.ObjectName
         
           If ent.StyleName = oldstylename Then
            ent.StyleName = mynewtextstylename
            alltextc = alltextc + 1
            End If
    '           Stop
            End If
          Next ent
         i = i + 1
    End If
Next mybaaa
End Function



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 改变文字样式()
'yngqq443440204@2024年8月15日17:20:00
'复制图中所有文字样式并加前缀，生成新的文字样式，
'并将图中所有实体的文字样式改为新的文字样式
'目前块参照中的文字样式尚未改变
On Error Resume Next
Dim oldtextstyle As AcadTextStyle
Dim oldtextstylearr() As String
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 newtextstyle(i)
    ReDim Preserve oldtextstylearr(i)
    Set newtextstyle(i) = ThisDrawing.TextStyles.Add("新的" & oldtextstyle.Name)
    oldtextstylearr(i) = oldtextstyle.Name
    newtextstyle(i).Height = oldtextstyle.Height
    newtextstyle(i).Width = oldtextstyle.Width
    newtextstyle(i).ObliqueAngle = oldtextstyle.ObliqueAngle
    newtextstyle(i).fontFile = oldtextstyle.fontFile
    i = i + 1
Next oldtextstyle
i = 0
''改变每个字体的字体样式
    Set sel = creatsel("mysell")

    sel.Select acSelectionSetAll, , , ftype, fdata
    For j = LBound(oldtextstylearr) To UBound(oldtextstylearr)
        temp = oldtextstylearr(j)
        Call 改变块文字样式(temp, newtextstyle(j).Name)
        For i = 0 To sel.Count - 1
        '普通文字和块的文字样式名是ent.stylename，而标注的文字样式名是textstyle,标注名称是stylename
            
            Select Case sel.Item(i).StyleName
                Case temp
                    sel.Item(i).StyleName = newtextstyle(j).Name
                Case Else
            End Select
            Select Case sel.Item(i).TextStyle
                Case temp
                    sel.Item(i).TextStyle = newtextstyle(j).Name
                Case Else
            End Select
        Next i
     Next j
MsgBox "OK    CAD二次开发qq:443440204", , "qq443440204"
Stop
ThisDrawing.PurgeAll
End Sub

 



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 改变文字样式()
'yngqq443440204@2024年8月15日17:20:00
'复制图中所有文字样式并加前缀，生成新的文字样式，
'并将图中所有实体的文字样式改为新的文字样式
'目前块参照中的文字样式尚未改变
On Error Resume Next
Dim oldtextstyle As AcadTextStyle
Dim oldtextstylearr() As String
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 newtextstyle(i)
    ReDim Preserve oldtextstylearr(i)
    Set newtextstyle(i) = ThisDrawing.TextStyles.Add("新的" & oldtextstyle.Name)
    oldtextstylearr(i) = oldtextstyle.Name
    newtextstyle(i).Height = oldtextstyle.Height
    newtextstyle(i).Width = oldtextstyle.Width
    newtextstyle(i).ObliqueAngle = oldtextstyle.ObliqueAngle
    newtextstyle(i).fontFile = oldtextstyle.fontFile
    i = i + 1
Next oldtextstyle
i = 0
''改变每个字体的字体样式
    Set sel = creatsel("mysell")

    sel.Select acSelectionSetAll, , , ftype, fdata
    For j = LBound(oldtextstylearr) To UBound(oldtextstylearr)
        temp = oldtextstylearr(j)
        For i = 0 To sel.Count - 1
        '普通文字的文字样式名是ent.stylename，而标注的文字样式名是textstyle,标注名称是stylename
            Select Case sel.Item(i).StyleName
                Case temp
                    sel.Item(i).StyleName = newtextstyle(j).Name
                Case Else
            End Select
            Select Case sel.Item(i).TextStyle
                Case temp
                    sel.Item(i).TextStyle = newtextstyle(j).Name
                Case Else
            End Select
        Next i
     Next j
MsgBox "OK    CAD二次开发qq:443440204", , "qq443440204"
Stop
ThisDrawing.PurgeAll
End Sub

 

 

评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包

打赏作者

山水CAD插件定制

你的鼓励是我创作最大的动力！

¥1 ¥2 ¥4 ¥6 ¥10 ¥20
扫码支付：¥1
获取中
扫码支付

您的余额不足，请更换扫码支付或充值

打赏作者

实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值