Stripping block attributes

[Tyke]

I have a VBA routine which strips all of the attributes from all of the blocks in a drawing, see following code:

 

   Dim oEnt As AcadEntity
   Dim i As Integer
   
   ' get all blocks in drawing
   Set colBlocks = ThisDrawing.Blocks
   
   ' iterate each block and remove all of the attribute definitions
   For Each objBlock In colBlocks
       For Each oEnt In objBlock
           If oEnt.ObjectName = "AcDbAttributeDefinition" Then
               oEnt.Delete
           End If
       Next oEnt

       ThisDrawing.SendCommand "_ATTSYNC" & vbCr & "NAME" & vbCr & objBlock.Name & vbCr

   Next objBlock
   
   ' iterate each block reference and remove its attribute references
   For Each oEnt In ThisDrawing.ModelSpace
       If TypeOf oEnt Is AcadBlockReference Then
           Set objBlockRef = oEnt
           If objBlockRef.HasAttributes Then
               varAttribs = objBlockRef.GetAttributes
               For i = LBound(varAttribs) To UBound(varAttribs)
                   varAttribs(i).Delete
               Next i
           End If
       End If
       
   Next oEnt
   
   ThisDrawing.Regen acAllViewports
   ThisDrawing.PurgeAll

This part works fine, but when I run a further routine in which I select a single block on screen, I test to see if the block has any attributes and depending on the result I display the appropriate form. At this point none of the blocks have any attribute references or definitions and I have confirmed this by checking the properties panel after selecting a block and by using the block editor. I have used the following code to check for any attributes:

 

       ' check if block already has some attributes
       ' and then show the appropriate form
       [color=red][b]If objBlockRef.HasAttributes = True Then[/b][/color]
           frmAppend.Show
           Me.Hide
       Else
           frmAddAtts.Show
           frmAddAtts.cbxFirstAttName.SetFocus
           Me.Hide
       End If

After executing the line in red it always evaluates to True even though there are no attributes.

 

Even if I quit the macro, do something else and then restart the macro, it still always evaluates to True.

 

What am I doing wrong?

 

If I save the drawing nothing changes, but if I close and reopen the drawing the test for arributes evaluates as False, as it should.

Edited July 25, 2012 by Tyke
Extra information added

[dbroada]

I can't answer this (even if I wasn't at home) but could this have something to do with ATTSYNC? You can manually delete all the attributes in a block but its not until you ATTSYNC the block that the attributes disappear from the existing blocks. As I say, no idea but may be worth exploring until somebody more clued up than me arrives.

 

----------------------------------

 

and of course I have now looked a bit closer and see you already ATTSYNC. Maybe you do it at the wrong time

[Tyke]

I can't answer this (even if I wasn't at home) but could this have something to do with ATTSYNC? You can manually delete all the attributes in a block but its not until you ATTSYNC the block that the attributes disappear from the existing blocks. As I say, no idea but may be worth exploring until somebody more clued up than me arrives.

 

Thanks Dave, I already tried that, programatically and directly in AutoCAD, but it didn't achieve anything

[btraemoore]

are you trying strip the attributes and then repopulate them with a user form? Im a little confused as to the goal your trying to achieve.

Edited July 25, 2012 by btraemoore

[btraemoore]

try this and see if you can get it to do what you want.

 

i like to use selection sets, so attached to the bottom is a sub that deletes all selection sets before running the code. (good for debugging)

 

When I was debugging I did notice that it kept verifying that it DID have attributes, but when you request anything from the attribute it canceled out because there were none. my guess is that because of the type of block it is programmed to say " hey guy, I have attributes" when in all actuality it doesn't because we just deleted them all. I don't know how to fix that problem but by adding 5 lines of code, the problem can be dealt with. Good food for thought on the main problem though, we can learn something from it.

 

 

 

Sub NameOfYourChoice()

   SS_delete 1
   
   Dim gpCode(0) As Integer
   Dim dataValue(0) As Variant
   Dim SS_Example As AcadSelectionSet
   Dim i As Integer
  
   Set SS_Example = ThisDrawing.SelectionSets.Add("SS_Example")
       gpCode(0) = 0: dataValue(0) = "INSERT"
      
   SS_Example.Select acSelectionSetAll, , , gpCode, dataValue
  
   Dim Cur_Blk As AcadEntity
   Dim Blk_Atts() As AcadAttributeReference
   Dim Cur_Att As AcadAttributeReference
   Dim n As Integer

   For i = 0 To SS_Example.Count - 1
       Set Cur_Blk = SS_Example.Item(i)
       Blk_Atts = Cur_Blk.GetAttributes

       For n = 0 To UBound(Blk_Atts)
           Set Cur_Att = Blk_Atts(n)
           
           Cur_Att.Delete
       Next n
   Next i
   
   Dim Att As Variant
   Application.Update
   For Each Item In SS_Example
       If Item.HasAttributes Then
           [color="red"]Blk_Atts = Item.GetAttributes
           For Each Att In Blk_Atts
               If Att.TagString <> Empty Then[/color]
                   frmAppend.Show
                   frmAddAtts.Hide
               Else
                   frmAddAtts.Show
                   frmAddAtts.cbxFirstAttName.SetFocus
                   frmAddAtts.Hide
              [color="red"]End If
           Next[/color]
       End If
   Next
   Application.Update

End Sub
'-----------------------------------------------------------------

Sub SS_delete(x As Byte)
   If ThisDrawing.SelectionSets.Count > 0 Then
   Dim i As Integer
       On Error Resume Next
       For i = 0 To ThisDrawing.SelectionSets.Count - 1
           ThisDrawing.SelectionSets.Item(i).Delete
       Next i
       On Error GoTo 0
   End If
End Sub

Edited July 25, 2012 by btraemoore
updated opinion

[Tyke]

I'm wanting to completely strip the attributes and not repopulate them, and that I can do. When the attributes have been stripped there is an option to add new attribute(s) to a block, but the block is recognised as still having attributes, even though there aren't any there. This is just part of a larger program where amongst other things attributes can be added to blocks without any attributes and appended to blocks that already have attributes. One of the options in this program is to strip all of the attributes from all of the blocks and it was during testing that I found this problem.

[btraemoore]

okay cool, so you got the problem worked out?

 

i realized what you were doing when i was debugging, the code i posted should fix it.

[Tyke]

Sorry I didn't get back sooner but I was out of the office all day yesterday.

 

Thanks for the code Trae, but unfortunately it didn't fix the problem.

 

When debugging I saw that when a block doesn't have any attributes and when .HasAttributes is queried and it says the block does have some attributes, that the upper bound for the attributes returned is -1. I used this value (

 

       ' check if block already has some attributes
       ' and then show the appropriate form
       
       Dim Blk_Atts() As AcadAttributeReference
       Dim Att           As Variant
       Dim Item         As Variant
              
       If objBlockRef.HasAttributes = True Then
           Blk_Atts = objBlockRef.GetAttributes
           Item = UBound(Blk_Atts)
           
           'If Att.TagString <> Empty Then
           If Item < 0 Then
                frmAddAtts.Show
                frmAddAtts.cbxFirstAttName.SetFocus
                Me.Hide
           Else
                frmAppend.Show
                Me.Hide
           End If
              
       Else
           frmAddAtts.Show
           frmAddAtts.cbxFirstAttName.SetFocus
           Me.Hide
       End If

 

I realize its just a work around and doesn't really solve the problem but I would still like to be able to strip the attributes and get a correct response from the .HasAttributes query.

 

Thanks for your time and effort, it is appreciated. If I get to solve the problem I'll get back to you on it.