Get certain attributes from a block

[AstroNout]

Hi guys, me again...

 

I'm writing a bit of code today, because it's raining outside and I can make myself usefull like this.

 

So, I'm trying to get a certain attribute from a block, but that in a string and plotting the string as a text in the same place as the block. Then I delete the block. Everything works just fine, except for the getting of the attributes. I've been searching on the forum, but haven't found what I was looking for, or at least, didn't understand it.

 

Ah well this is what I have untill now:

 

Sub BB06()
   Dim sText As String
   Dim blk As AcadBlockReference
   Dim ent As AcadEntity
   Dim p0 As Variant
   Dim Angle As Double
   Dim HNR As AcadText
   For Each blk In ThisDrawing.ModelSpace
       If blk.Name = "OCT_HNR" Then
           sText = blk.GetAttributes
           p0 = blk.InsertionPoint
           Angle = blk.Rotation
           
           Set HNR = ThisDrawing.Application.ActiveDocument.ModelSpace.AddText(sText, p0, 1.25)
           HNR.Alignment = acAlignmentMiddleCenter
           Dim Layer As AcadLayer
           Set Layer = ThisDrawing.Application.ActiveDocument.Layers.Add("HNR1")
           HNR.Layer = "HNR1"
           HNR.StyleName = "STANDARD"
           HNR.ScaleFactor = 1#
           HNR.Move HNR.TextAlignmentPoint, p0
           HNR.Rotation = Angle
           
           blk.Delete
       End If
   Next
   
   For Each ent In ThisDrawing.PaperSpace
       If TypeOf ent Is AcadBlockReference Then
           Set blk = ent
           If blk.Name = "OCT_HNR" Then
               blk.Delete
           End If
       End If
   Next
End Sub

 

The use of the getattributes method, obviously, isn't right, but I have no idea how to use the method for extracting specific info.

 

Thanks y'all!

Arnout

[dbroada]

try GetAttributes(0)

[AstroNout]

that doesn't seem to work...

[AstroNout]

Right, i've been doing some tweeking, and now it works. But it still gives an error on the last "next". No idea why, because all of my blocks are deleted and text-shizzle has taken his place. Well, well...

 

Sub BB06()
   Dim sText As String
   Dim blk As AcadBlockReference
   Dim ent As AcadEntity
   Dim p0 As Variant
   Dim Angle As Double
   Dim HNR As AcadText
   
   On Error GoTo Errorhandling
       
   For Each blk In ThisDrawing.ModelSpace
       If blk.Name = "OCT_HNR" Then
           aAttributes = blk.GetAttributes
           For Each attrib In aAttributes
               If attrib.TagString = "ATTRIBUUT" Then
                   p0 = blk.InsertionPoint
                   Angle = blk.Rotation
                   Dim PI As Double
                   PI = 4 * Atn(1)
                   
                   If Angle > PI / 2 And Angle < 3 * PI / 2 Then
                       Angle = Angle + PI
                   End If
                   
                   sText = attrib.TextString
                   Set HNR = ThisDrawing.Application.ActiveDocument.ModelSpace.AddText(sText, p0, 1.25)
                   HNR.Alignment = acAlignmentMiddleCenter
                   Dim Layer As AcadLayer
                   Set Layer = ThisDrawing.Application.ActiveDocument.Layers.Add("HNR1")
                   HNR.Layer = "HNR1"
                   HNR.StyleName = "STANDARD"
                   HNR.ScaleFactor = 1#
                   HNR.Move HNR.TextAlignmentPoint, p0
                   HNR.Rotation = Angle
               End If
           Next attrib
           blk.Delete
       End If
   Next blk

   Exit Sub
Errorhandling:
   Exit Sub
End Sub

 

Edit: I just tried it on an other drawing, and it stops after the second block has gone through the program. Bah!

Edited July 22, 2011 by AstroNout

[Joro--]

It does not go through all of the Block in your drawing because some of them are just BlockReferences and there is not a corresponding block with the same name in ThisDrawing.Blocks. I made a little modification - check for the ObjectName of the entity - now it should be working

 

Sub BB06()
   Dim sText As String
   Dim blk As AcadBlockReference
   Dim ent As AcadEntity
   Dim p0 As Variant
   Dim Angle As Double
   Dim HNR As AcadText
   
   On Error GoTo Errorhandling
       
   For Each ent In ThisDrawing.ModelSpace
       If ent.ObjectName = "AcDbBlockReference" Then
           Set blk = ent
           If blk.Name = "OCT_HNR" Then
               aAttributes = blk.GetAttributes
               For Each attrib In aAttributes
                   If attrib.TagString = "ATTRIBUUT" Then
                       p0 = blk.InsertionPoint
                       Angle = blk.Rotation
                       Dim PI As Double
                       PI = 4 * Atn(1)
                       
                       If Angle > PI / 2 And Angle < 3 * PI / 2 Then
                           Angle = Angle + PI
                       End If
                       
                       sText = attrib.TextString
                       Set HNR = ThisDrawing.Application.ActiveDocument.ModelSpace.AddText(sText, p0, 1.25)
                       HNR.Alignment = acAlignmentMiddleCenter
                       Dim Layer As AcadLayer
                       Set Layer = ThisDrawing.Application.ActiveDocument.Layers.Add("HNR1")
                       HNR.Layer = "HNR1"
                       HNR.StyleName = "STANDARD"
                       HNR.ScaleFactor = 1#
                       HNR.Move HNR.TextAlignmentPoint, p0
                       HNR.Rotation = Angle
                   End If
               Next attrib
               blk.Delete
           End If
       End If
   Next

   Exit Sub
Errorhandling:
   Exit Sub
End Sub

[AstroNout]

now it doesn't seem to go through to the blocks I want to change to text. I had to add:

 

    Dim aAttributes As Variant
   Dim attrib As AcadAttribute

So it would go through the code. Maybe I'll have to dim them differently?

[AstroNout]

Right, it works, but goes through every single entity in my drawing. That's a bit time consuming. Can't I select a layer where the program should look?

 

Thanks for the suggestions!

 

Sub BB06()
   Dim sText As String
   Dim blk As AcadBlockReference
   Dim ent As AcadEntity
   Dim p0 As Variant
   Dim Angle As Double
   Dim HNR As AcadText
   Dim aAttributes As Variant
   Dim attrib As Variant
   
   On Error GoTo Errorhandling
       
   For Each ent In ThisDrawing.ModelSpace
       If ent.ObjectName = "AcDbBlockReference" Then
           Set blk = ent
           If blk.Name = "OCT_HNR" Then
               aAttributes = blk.GetAttributes
               For Each attrib In aAttributes
                   If attrib.TagString = "ATTRIBUUT" Then
                       p0 = blk.InsertionPoint
                       Angle = blk.Rotation
                       Dim PI As Double
                       PI = 4 * Atn(1)
                       
                       If Angle > PI / 2 And Angle < 3 * PI / 2 Then
                           Angle = Angle + PI
                       End If
                       
                       sText = attrib.TextString
                       Set HNR = ThisDrawing.Application.ActiveDocument.ModelSpace.AddText(sText, p0, 1.25)
                       HNR.Alignment = acAlignmentMiddleCenter
                       Dim Layer As AcadLayer
                       Set Layer = ThisDrawing.Application.ActiveDocument.Layers.Add("HNR1")
                       HNR.Layer = "HNR1"
                       HNR.StyleName = "STANDARD"
                       HNR.ScaleFactor = 1#
                       HNR.Move HNR.TextAlignmentPoint, p0
                       HNR.Rotation = Angle
                   End If
               Next attrib
               blk.Delete
           End If
       End If
   Next

   Exit Sub
Errorhandling:
   Exit Sub
End Sub

[dbroada]

you can create a selection set for just blocks or just blocks on a certain layer.

[BIGAL]

sText = blk.GetAttributes

Stext(0) is first attribute sText(1) is netxt and so on

 

You can use filters to search for a block name

Dim FilterDXFCode(0) As Integer
Dim FilterDXFVal(0) As Variant
FilterDXFCode(0) = 0
FilterDXFVal(0) = "INSERT"
'FilterDXFCode(1) = 2
'FilterDXFVal(1) = "SCHEDTEXT"
Set SS = ThisDrawing.SelectionSets.Add("pit1sel")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal

attribs(0).TextString = attrib string value

try filter code 8 for layer

[dbroada]

Thanks BIGAL, I'm not at work this week so could only suggest what to do, its nice to see the code.

[19cruthik68]

follow up question.

 

Where do you usually put that text? I dont know how to use that thing?can u give me an info. thanks