[编程交流] 更改块属性默认值

Public Sub changedefault()
Count = ThisDrawing.ActiveLayout.Block.Count
For Index = 0 To Count - 1
Blockstring = ThisDrawing.ActiveLayout.Block(Index).ObjectName
If Blockstring = "AcDbBlockReference" Then
BAttributes = ThisDrawing.ActiveLayout.Block(Index).GetAttributes
For Each attrib In BAttributes
attrib.???? = attrib.TextString
Next attrib
End If
Next Index
End Sub

 
Option Explicit
Function IsBlockExist(bName As String) As Boolean
' credits to Frank Oquendo
Dim oBlock As AcadBlock
IsBlockExist = False
On Error Resume Next
For Each oBlock In ThisDrawing.Blocks
If StrComp(oBlock.Name, bName, vbTextCompare) = 0 Then
IsBlockExist = True
End If
Next
End Function
Sub TryIt()
Dim blkName As String
blkName = InputBox(vbCrLf & "Enter block name:", "Default Attribute Values Example")
If Not IsBlockExist(blkName) Then
MsgBox "Block " & Chr(34) & blkName & Chr(34) & " dos not exists"
Exit Sub
End If
On Error GoTo Err_Control
'----------------------------------------------'
' selection test:
Dim ftype(0 To 2) As Integer
Dim fdata(0 To 2) As Variant
Dim dxfCode, dxfValue
ftype(0) = 0: fdata(0) = "INSERT"
ftype(1) = 66: fdata(1) = 1
ftype(2) = 2: fdata(2) = "`U*," & blkName '<-- filter to select anonimous block as well
dxfCode = ftype: dxfValue = fdata
Dim oSset As AcadSelectionSet
With ThisDrawing.SelectionSets
While .Count > 0
.item(0).Delete
Wend
Set oSset = .Add("MySset")
End With
Application.Eval ("msgbox(" & Chr(34) & "Select block instances" & Chr(34) & ")")
oSset.SelectOnScreen dxfCode, dxfValue
If oSset.Count = 0 Then
MsgBox "Nothing selected"
Exit Sub
End If
Dim aTag As String
aTag = InputBox(vbCrLf & "Enter Attribute Tag:", "Default Attribute Values Example", "ID")
Dim defaultVal As String
Dim oEnt As AcadEntity
Dim oBlkRef As AcadBlockReference
Dim oBlock As AcadBlock
Dim bName As String
For Each oEnt In oSset
Set oBlkRef = oEnt
If oBlkRef.IsDynamicBlock Then
bName = oBlkRef.EffectiveName
Else
bName = oBlkRef.Name
End If
If StrComp(blkName, bName, vbTextCompare) = 0 Then
Set oBlock = ThisDrawing.Blocks.item(blkName)
Dim oObj As AcadObject
Dim oAttrib As AcadAttribute
For Each oObj In oBlock
If TypeOf oObj Is AcadAttribute Then
Set oAttrib = oObj
If StrComp(oAttrib.TagString, aTag, vbTextCompare) = 0 Then
defaultVal = oAttrib.TextString
Exit For
End If
End If
Next oObj
Dim i As Integer
Dim attArr As Variant
Dim oAttRef As AcadAttributeReference
attArr = oBlkRef.GetAttributes
For i = LBound(attArr) To UBound(attArr)
Set oAttRef = attArr(i)
If StrComp(oAttRef.TagString, aTag, vbTextCompare) = 0 Then
oAttRef.TextString = defaultVal
Exit For
End If
Next i
End If
Next oEnt
ThisDrawing.Regen acActiveViewport
Err_Control:
End Sub

 
Option Explicit
Function IsBlockExist(bName As String) As Boolean
Dim oBlock As AcadBlock
IsBlockExist = False
On Error Resume Next
For Each oBlock In ThisDrawing.Blocks
If StrComp(oBlock.Name, bName, vbTextCompare) = 0 Then
IsBlockExist = True
End If
Next
End Function
Sub TestForThomas()
Dim blkName As String
blkName = InputBox(vbCrLf & "Enter block name:", "Default Attribute Values Example", "block2circles")
If Not IsBlockExist(blkName) Then
MsgBox "Block " & Chr(34) & blkName & Chr(34) & " doesn't exists"
Exit Sub
End If
On Error GoTo Err_Control
'----------------------------------------------'
' selection test:
Dim ftype(0 To 2) As Integer
Dim fdata(0 To 2) As Variant
Dim dxfCode, dxfValue
ftype(0) = 0: fdata(0) = "INSERT"
ftype(1) = 66: fdata(1) = 1
ftype(2) = 2: fdata(2) = "`U*," & blkName '<-- filter to select anonimous block as well
dxfCode = ftype: dxfValue = fdata
Dim oSset As AcadSelectionSet
With ThisDrawing.SelectionSets
While .Count > 0
.item(0).Delete
Wend
Set oSset = .Add("MySset")
End With
oSset.Select acSelectionSetAll, , , dxfCode, dxfValue
If oSset.Count = 0 Then
MsgBox "Nothing selected"
Exit Sub
End If
Dim aTag As String
aTag = InputBox(vbCrLf & "Enter Attribute Tag:", "Default Attribute Values Example", "ATTRIBUTE1")
Dim defaultVal As String
defaultVal = InputBox(vbCrLf & "Enter the Default Attribute Value:", "Default Attribute Values Example", "- Blah -")
Dim oEnt As AcadEntity
Dim oBlkRef As AcadBlockReference
Dim oBlock As AcadBlock
Dim bName As String
For Each oEnt In oSset
Set oBlkRef = oEnt
'' get the block reference owner
Dim ltObj As AcadObject
Set ltObj = ThisDrawing.ObjectIdToObject(oBlkRef.OwnerID)
'' check if this block reference is belongs to the current space
If ltObj.Handle = ThisDrawing.ActiveLayout.Block.Handle Then
If oBlkRef.IsDynamicBlock Then
bName = oBlkRef.EffectiveName
Else
bName = oBlkRef.Name
End If
If StrComp(blkName, bName, vbTextCompare) = 0 Then
Set oBlock = ThisDrawing.Blocks.item(blkName)
Dim oObj As AcadObject
Dim oAttrib As AcadAttribute
'' iterate through block definition subobjects
For Each oObj In oBlock
'' check if object is type of Attribute object
If TypeOf oObj Is AcadAttribute Then
Set oAttrib = oObj
'' check if attribute tags is ineteresting for us
If StrComp(oAttrib.TagString, aTag, vbTextCompare) = 0 Then
'' check if attribute value is not equal to the newly defined value
If oAttrib.TextString <> defaultVal Then
'' if not equal so change it on default
oAttrib.TextString = defaultVal
'' the desired attribute was changed, we can go out from iteration
Exit For
End If
End If
End If
Next oObj
'' then turn back to our block reference
'' and change known attribute value on default value
Dim oAttribs As Variant
oAttribs = oBlkRef.GetAttributes
Dim i
For i = LBound(oAttribs) To UBound(oAttribs)
Dim oAttRef As AcadAttributeReference
Set oAttRef = oAttribs(i)
If StrComp(oAttRef.TagString, aTag, vbTextCompare) = 0 Then
oAttRef.TextString = defaultVal
Exit For
End If
Next
End If
End If
Next oEnt
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub