[编程交流] 编辑属性宽度因子

Private Sub Ch_Att_Width(bName As String, atag As String, dblWid As Double)
    Dim oSset As AcadSelectionSet, _
        blkRef As AcadBlockReference, _
        attObj As AcadAttributeReference, _
        attData() As AcadObject, _
        fType(2) As Integer, _
        fData(2) As Variant, _
        dxfType, _
        dxfData, _
        k As Integer
    fType(0) = 0: fType(1) = 2: fType(2) = 66
    fData(0) = "INSERT": fData(1) = bName: fData(2) = 1
    dxfType = fType: dxfData = fData
    
    For Each oSset In ThisDrawing.SelectionSets
         If oSset.Name = "$Blocks$" Then
              oSset.Delete
              Exit For
         End If
    Next oSset
    Set oSset = ThisDrawing.SelectionSets.Add("$Blocks$")
    
    MsgBox "Select blocks on screen"
    oSset.SelectOnScreen dxfType, dxfData
    For Each blkRef In oSset
         attData = blkRef.GetAttributes
         For k = 0 To UBound(attData)
              Set attObj = attData(k)
              If StrComp(attObj.TagString, atag) = 0 Then
                   attObj.ScaleFactor = dblWid
                   attObj.Update
                   blkRef.Update
                   Exit For
              End If
         Next k
    Next blkRef
    oSset.Delete
    Set oSset = Nothing
    
    MsgBox "Done"
End Sub
Sub demo()
Ch_Block_Att_Width "MLR", "PRESET", 0.45
' where: "MLR" is block name,
' "PRESET" is desired tag,
' 0.45 is width factor
End Sub

SUB rename&changewidth()
Dim  j, k As Integer
Dim ELEMENT, ArrayAttributes
On Error Resume Next
For j = 0 To ThisDrawing.Layouts.Count - 1                 
If ThisDrawing.Layouts(j).Name = "Model" Then GoTo 10  ThisDrawing.SendCommand "layout s " & ThisDrawing.Layouts(j).Name & vbCr
               For Each ELEMENT In ThisDrawing.PaperSpace
                   If ELEMENT.EntityType = 7 Then
                       If Err Then GoTo 5
                       If ELEMENT.HasAttributes = True Then
                           ArrayAttributes = ELEMENT.GetAttributes
                           For k = LBound(ArrayAttributes) To UBound(ArrayAttributes)
                               If ArrayAttributes(k).TagString = "[color=red]TYPEATTRIBUTETAGLABELHERE[/color]" Then ArrayAttributes(k).TextString = "[color=red]TYPE TEXT TO CHANGE ATTRIBUTE TO HERE[/color]"
                               If ArrayAttributes(k).TagString = "[color=red]TYPEATTRIBUTETAGLABELHERE[/color]" Then ArrayAttributes(k).ScaleFactor = [color=red]12[/color] ' this is the width of your attribute
                           Next k
                       End If
5
                   End If
               Next
10
           Next j
End SUB