社区 › Auto Lisp › 更改块属性默认值

TTAA 发表于 2022-7-6 22:34:12

更改块属性默认值

尊敬的Autocad朋友们：，
 
我在区块中的属性有问题。我已经创建了许多具有不同属性的块，其中有默认值/初始化值。现在我想用tht中的值更改这些默认值。TextString，而不是每次在blockeditor中输入。我试图用VBA更改它们，但找不到默认值的成员。我也不是舒尔，它工作如此。。。。
 
代码：
 
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
我很乐意接受所有提示和提示
 
非常感谢
托马斯

fixo 发表于 2022-7-6 22:44:25

只是一个提示
默认属性值存储在AcadBlock对象中（查看其中的AcadAttribute对象）
但是您试图在AcadBlockReference中更改它们，其中
您正在循环访问AcadAttributeReference对象
HTH公司

fixo 发表于 2022-7-6 22:49:03

在工作图纸副本上尝试以下代码：

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

 
~'J'~

TTAA 发表于 2022-7-6 22:55:37

非常感谢您的代码。我希望能够稍微修改一下，使attribute的actaul值成为默认值。您的代码将实际值替换为默认值。
 
抱歉重复发帖：尚未看到您的回复

fixo 发表于 2022-7-6 23:05:19

没问题

TTAA 发表于 2022-7-6 23:11:12

Hy朋友们，
 
首先我必须原谅我的英语：对不起
第二，也很抱歉我的代码混乱。这可能是我在VBA中第一次尝试自己编写的代码
 
正如我所描述的，我正在搜索设置我的。textstring作为属性的默认值，但我无法编写它。
所以我试着写一个，在同一个插入点创建图形中每个块的副本，并在与旧块相同的点创建新属性。
出乎意料的是，它真的有效！！！
但是仍然有一个问题我无法解决：我想删除旧属性，这样只有具有新默认值的新属性
我在论坛和互联网上搜索了很多时间，但我没有找到我可以使用的东西。
如果有人能帮我，我真的会很高兴。
 
这是我的代码：
 
 
 
非常感谢
托马斯

fixo 发表于 2022-7-6 23:16:35

托马斯，我完全糊涂了
请试试这个：
-创建样例图形并在其中插入2个块参照
-具有旧属性和值的第一个块参照
-以及具有新属性和新值的第二个块参考
没有别的了
-然后以格式上传此图纸
 
也许我更容易理解你需要什么
 
奥列格
 
~'J'~

TTAA 发表于 2022-7-6 23:21:24

Hy Oleg，
 
抱歉解释得不好。我真的希望这幅画能有所帮助。
该图中有3个块。我将用中的旧值更改的原始块。属性的文本字符串，并在块编辑器中设置为属性的默认值。中间的一个在中具有正确的（新）值。Textstring，但blockeditor中的假（旧）字符串作为默认值。3个块（由于属性默认值不同而命名为不同的块。应使用相同的名称）中的新值。Textstring和right也在blockeditor中设置为默认值）。
 
我几乎可以用上面的代码解决我的问题。我只是没有删除Blockeditor中的（false/old）属性，以便下次插入块时，它将只是具有用户在中插入的值的新属性。Textstring（块的用户界面/不在Blockeditorwindow中）作为默认值。
 
我希望我能够解释我，如果不只是发短信给我。非常感谢，对所有不方便的事情表示抱歉
 
托马斯
样品dxf

fixo 发表于 2022-7-6 23:30:03

Thomas，试试这个单属性代码
然后让我知道这个代码是如何工作的
为你


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

 
~'J'~

TTAA 发表于 2022-7-6 23:39:42

Hy Oleg，
 
非常感谢你的帮助和花费的时间。我真的很感激
 
昨天的代码几乎完成了。只有一些变化
 
1） defaultVal：应该将其设置为插入框。如果双击图形中的某个块，可以打开窗口/遮罩。在那里，您可以更改属性的值，但不会更改块编辑器中属性的默认值。这是。文本字符串。我希望设置这个。textstring作为默认值
 
2） 代码应该对块的所有属性都执行此操作（我能够在代码trought中编写此例程）
 
 
3） 代码应该为这个图形中的每个块都这样做（我也能够在代码中编写它）
 
今天我的学习时间有点不够，所以我无法尝试更改您的代码，但我非常确信，通过我们的CADE组合，我将能够编写正确的代码。 
谢谢Oleg并致以最良好的问候
托马斯

查看完整版本: 更改块属性默认值