Change blockattribute default value whit VBA

[TTAA]

Hy dear Autocad-Friends,

 

I have a Problem with my attributs in blocks. I have already create a lot of Blocks with different attributes with there default/initialise values. Now I want to change there default values with the values in tht .TextString without entering every time in the blockeditor. I have tried to change them with VBA but i can not find the member for the default value. I'm also not shure that it works so....

 

Code:

 

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

I would be happy about all hints and tipps

 

A lot of Thanks

Thomas

[fixo]

Just a hint

Default attribute values are stored in AcadBlock object (look at AcadAttribute object within)

but you have tried to change them in the AcadBlockReference where

you're loop through AcadAttributeReference objects

HTH

[fixo]

Try this code on copy of your working drawing:

 
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]

Thanks a lot for the Code. I hope to be able to change it a little bit so that the actaul value of the attribut becoms there default value. Your code replaces the actual value with the default one.

 

Sorry for the double posting: haven't see your reply

[fixo]

No problem

[TTAA]

Hy friends,

 

Firsth i must excuse me for my english: Sorry

Second also sorry for my confusing code. It's probably peinfull for you, but ist's my firsth own code and firsth attempts in VBA

 

Like i described i was search for a code that sets my .textsrtring as default value of the attributes but i wasn't able to write it.

So i tried to write one witch create a copy of every block in the drawing at the same insertionpoint with new attributes at the same point as the old one.

unexpectaly it realy works!!!

but there is still one problem i can't solve: i want to delete the old Attributes, so that there are only the new ones with the new default values

I have search in forums and internet for a lot of time but i haven't fount something that i can use.

i would realy make my happy if somebody can help me out.

 

this is my code:

 

Public Sub changedefault()

 

Count = ThisDrawing.ActiveLayout.Block.Count 'to get te number of blocks in this drawing

 

For Index = 0 To Count - 1 'for every block

 

Dim blockstring As String 'to control if its realy a block

blockstring = ThisDrawing.ActiveLayout.Block(Index).ObjectName

 

Dim blockname As String 'to get the real blcokname also for dynamic blocks

blockname = ThisDrawing.ActiveLayout.Block(Index).EffectiveName

 

If blockstring = "AcDbBlockReference" Then

 

Dim blockRefObj1 As AcadBlockReference '1)I need it don't ask my why

Set blockRefObj1 = ThisDrawing.ActiveLayout.Block(Index)

 

Dim insblockRefObj1 As Variant 'Insertiopoint of blockRefObj1

insblockRefObj1 = blockRefObj1.insertionPoint

 

Dim e As Integer 'to get the index of the attribute

e = 0 'for each block it restarts by 0

 

battributes = ThisDrawing.ActiveLayout.Block(Index).GetAttributes 'to get the attributes of the block

 

For Each attrib In battributes

 

Dim insertionPnt(0 To 2) As Double '2)I need it don't ask my why

insertionPnt(0) = 0: insertionPnt(1) = 0: insertionPnt(2) = 0

 

Set blockobj = ThisDrawing.Blocks.Add(insertionPnt, blockname) 'to create a copy of the block

 

' Attributdefinition

Dim attributeObj As AcadAttribute

Dim height As Double

Dim mode As Long

Dim prompt As String

Dim insertionPoint(0 To 2) As Double

Dim tt As Variant

Dim tag(0 To 2) As String

Dim value(0 To 2) As String

 

'set height

height = attrib.height

 

'set visibility

If attrib.Invisible = True Then

mode = acAttributeModeInvisible

Else

mode = acAttributeModeVisible

End If

 

'Isertpoint of attribute

Dim Att0, Att1 As Variant

Set Att0 = battributes(e)

tt = Att0.insertionPoint

e = e + 1

'delete the +5: i only set it so that the new attribute didn't cover the old one

insertionPoint(0) = tt(0) - insblockRefObj1(0) + 5: insertionPoint(1) = tt(1) - insblockRefObj1(1): insertionPoint(2) = tt(2) - insblockRefObj1(2)

 

prompt = "" 'I haven't found where i can get the information of the promptvalue

 

'Tag value

tag(0) = attrib.TagString

 

'nee default value

value(0) = attrib.TextString

 

' Create the attribute definition

Set attributeObj = blockobj.AddAttribute(height, mode, prompt, insertionPoint, tag(0), value(0))

 

'-------------HELP

'!!!!!

 

'attrib.delete

'battributes(e).delete

 

'don't work: it only delete it in the mask and not in the blockeditor

'when i insert the block it have the double number of attributes:

'1) the old one with the false default wich i hope that somebody can explain me how i can delete

'2) the new one with the new default values whitch i want to keep

'----------------------------

 

Next attrib

 

'set the attribute to the block

'delete 50 i only set it so that the new block didn't cover the old one

Dim blockRefObj As AcadBlockReference

insertionPnt(0) = insblockRefObj1(0) + 50: insertionPnt(1) = insblockRefObj1(1): insertionPnt(2) = insblockRefObj1(2)

Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, blockname, 1, 1, 1, 0)

ZoomAll

 

End If

 

Next Index

 

End Sub

 

 

a lot of thanks

thomas

[fixo]

Thomas, I completely confused

So try this, please:

- create sample drawing and insert in there just 2 block references

- first block reference with old attributes and values

- and second block reference with new attributes and new values

nothing else

- then upload this drawing in format

 

Maybe it will be easier for me to understand what you need

 

Oleg

 

~'J'~

[TTAA]

Hy Oleg,

 

Sorry for bad explaining. I realy hope that the drawing helpes.

In this Drawing there are 3 block. the original block which i will change with the old values in the .Textstring of the attribut and also set as default value of the Attribute in the Blockeditor. The middle-one has the right (new) values in the .Textstring but the false (old) ones in the blockeditor as default values. and the 3 block (Block named different because of the different Attribut default values. should be samenamed) whit the new vallues in .Textstring and right ones also set as default values in the blockeditor).

 

I nearly was able to solve my problem with my code above. I only wasn't to delete the (false/old) Attributes in the Blockeditor so that the next time I insert the Block that would be only the new attributes with the values insertet by the User in the .Textstring (User interface of the Block / not in the Blockeditorwindow) as default values.

 

I hope that I was able to explain me if not only text me. Thanks a lot and sorry for all the inconveniecs

 

Thomas

Sample.dxf

[fixo]

Thomas, try this code for single attribute

then let me know how this code is working

for you

 

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]

Hy Oleg,

 

lot of thanks for your help and expendet time. i realy appreciate it

 

The code of yesrterday is almost perfekt. only some changes

 

1) the defaultVal: It shouldn be set trought a Insertbox. If there is a block in the drawing with double click on it you can open a Window/mask. there you can change the value of the attribute but it doesn't change in the default value of the attribute in the blockeditor. this is the .Textstring. I desire to set this .textstring as the defaultVal

 

2) the code should do it for all the attributes of the block (I was able to write this routine in my code trought)

 

battributes = ThisDrawing.ActiveLayout.Block(Index).GetAttribute s 'to get the attributes of the block

 

For Each attrib In battributes

....

next attrib

 

3) the code should do it for every block in this drawing (I also was able to write it in the code)

 

Count = ThisDrawing.ActiveLayout.Block.Count For Index = 0 To Count - 1

....

next index

Today i am a little bit out of time with my studing so i can't tried to change your code but I am quite sure that out of a combination of our cades i would be able to wirte the right code.

 

thanks Oleg and best regards

Thomas