getting block attributes - VBA

I have a title block with several attributes. I know how to get all the attribute values using VBA but I was hoping to jut determine the value of one of them. It is something I think I should know how to do, but if I did then I've forgotten.

I have something like....

myAttibutes = myBlock.GetAttributes

for i = 0 to ubound(myAttributes)
debug.print myAttributes(i).TagString;myAttributes(i).TextString
next i

Can anybody help me determine the text value of the attibute TagString = "Title1" without stepping through them all?

I dont think you can do it unless you know the index value of the tag in the block. I have code to step through them if you want it.

I use this code to update my attributes, but you can tweak it to read the value of an attribute

    For Each objBlkRef In objSelSet
       If objBlkRef.HasAttributes Then
           varAtts = objBlkRef.GetAttributes
           For intAElems = LBound(varAtts) To UBound(varAtts)
               Set objAttRef = varAtts(intAElems)
               If objAttRef.TagString = strTagName Then
                   strOrigTagValue = objAttRef.TextString
                   If Len(strNewTagValue) > 0 Then
                       objAttRef.TextString = strNewTagValue
                       Exit For
                   End If
               End If
           Next intAElems
       End If
   Next objBlkRef

Thanks,

I am looking for 4 out of 15 so its not a big problem to step through, which is what I have done but I thought I had seen a way to home in on one once you knew the TagString. Oh well, I'll stick with what I've got.

There might be a way to go directly to it, I can look if you want

There might be a way to go directly to it, I can look if you want

I'm not overly fussed now as what I have works well enough - however if do you find out......

Hi guys not sure but have a look at my last post it searches all blocks and only picks out 1 to update I use the attrib value (x) not tagstring in the block the attrib(x) is always unique atributes are attribs(0) attribs(1) etc easier than tag strings

PS missing bit of code is a function that lets the user pick text or block in the drawing as the key to find the one block with attrib(0) = key

here is also a title block update routine may be usefull

Public Sub issued_for_construction()
' This Updates the Issued for construction and sets rev 0
 
Dim SS As AcadSelectionSet
Dim Count As Integer
Dim FilterDXFCode(1) As Integer
Dim FilterDXFVal(1) As Variant
Dim attribs As Variant
Dim BLOCK_NAME As String
On Error Resume Next
FilterDXFCode(0) = 0
FilterDXFVal(0) = "INSERT"
FilterDXFCode(1) = 2
FilterDXFVal(1) = "DA1DRTXT"
BLOCK_NAME = "DA1DRTXT"
Set SS = ThisDrawing.SelectionSets.Add("issued")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal
 
For Cntr = 0 To SS.Count - 1
   attribs = SS.Item(Cntr).GetAttributes
 
 
        attribs(0).TextString = "ISSUED FOR CONSTRUCTION"
        attribs(3).TextString = "0"
 
        attribs(0).Update
        attribs(3).Update
 
Next Cntr
ThisDrawing.SelectionSets.Item("issued").Delete
'DO AGAIN FOR REVTABLE
'DATE
'Dim MyDate
'MyDate = Date
Call DashDate
FilterDXFCode(1) = 2
FilterDXFVal(1) = "REVTABLE"
BLOCK_NAME = "REVTABLE"
Set SS = ThisDrawing.SelectionSets.Add("revs")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal
 
For Cntr = 0 To SS.Count - 1
   attribs = SS.Item(Cntr).GetAttributes
 
 
        attribs(0).TextString = "0"
        attribs(1).TextString = DashDate
        attribs(2).TextString = "ISSUED FOR CONSTRUCTION"
 
 
 
        attribs(0).Update
        attribs(1).Update
        attribs(2).Update
 
Next Cntr
ThisDrawing.SelectionSets.Item("revs").Delete
MsgBox "Drawing now changed to Issued for Construction"
End Sub[code]

I know that Attribute(3) will work but this routine has to work on 15 year's worth of borders of varing sizes and revisions. All have Attribute("Title1") but they won't all have Attribute(3) = "Title1", some will be Attrbute(0), some Attribute(20). I had hoped I could go directly to "Title1" as I thought I had seen it done before but it works stepping through so I'm happy.

For sake of completeness here is my code. Very quick & dirty and could easilly be improved but it works so I expect it will stay.

Option Explicit
Private Sub cmdDown_Click()
Dim myString As String
Select Case Label5.Caption
Case Is = "1"
myString = lblTag1.Caption
lblTag1.Caption = lblTag2.Caption
lblTag2.Caption = myString
Label5.Caption = "2"
lblTag2.SpecialEffect = fmSpecialEffectEtched
lblTag1.SpecialEffect = fmSpecialEffectSunken
Case Is = "2"
myString = lblTag2.Caption
lblTag2.Caption = lblTag3.Caption
lblTag3.Caption = myString
Label5.Caption = "3"
lblTag3.SpecialEffect = fmSpecialEffectEtched
lblTag2.SpecialEffect = fmSpecialEffectSunken
Case Is = "3"
myString = lblTag3.Caption
lblTag3.Caption = lblTag4.Caption
lblTag4.Caption = myString
Label5.Caption = "4"
lblTag4.SpecialEffect = fmSpecialEffectEtched
lblTag3.SpecialEffect = fmSpecialEffectSunken
End Select
End Sub

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cmdPopulate_Click()
Dim myObject As Object
Dim mySelectionSet As AcadSelectionSet
Dim myAttributes As Variant
Set mySelectionSet = ThisDrawing.SelectionSets.Add("Fred")
Dim gpCode(0 To 1) As Integer
Dim dataValue(0 To 1) As Variant
Dim groupCode As Variant
Dim dataCode As Variant
gpCode(0) = 2 'name
gpCode(1) = 0 'item
groupCode = gpCode
dataValue(0) = "STLA*" 'layer name
dataValue(1) = "INSERT" 'item type
dataCode = dataValue
mySelectionSet.Select acSelectionSetAll, , , groupCode, dataCode
Set myObject = mySelectionSet.Item(0)
myAttributes = myObject.GetAttributes
If lblTag1.Caption <> "" Then
   myAttributes(Label1).TextString = lblTag1.Caption
   Else
   myAttributes(Label1).TextString = ""
   End If
If lblTag2.Caption <> "" Then
   myAttributes(Label2).TextString = lblTag2.Caption
   Else
   myAttributes(Label2).TextString = ""
   End If
If lblTag3.Caption <> "" Then
   myAttributes(Label3).TextString = lblTag3.Caption
   Else
   myAttributes(Label3).TextString = ""
   End If
If lblTag4.Caption <> "" Then
   myAttributes(Label4).TextString = lblTag4.Caption
   Else
   myAttributes(Label4).TextString = ""
   End If

ThisDrawing.SelectionSets.Item("Fred").Delete
Unload Me
End Sub

Private Sub cmdUp_Click()
Dim myString As String
Select Case Label5.Caption
Case Is = "2"
myString = lblTag2.Caption
lblTag2.Caption = lblTag1.Caption
lblTag1.Caption = myString
Label5.Caption = "1"
lblTag1.SpecialEffect = fmSpecialEffectEtched
lblTag2.SpecialEffect = fmSpecialEffectSunken
Case Is = "3"
myString = lblTag3.Caption
lblTag3.Caption = lblTag2.Caption
lblTag2.Caption = myString
Label5.Caption = "2"
lblTag2.SpecialEffect = fmSpecialEffectEtched
lblTag3.SpecialEffect = fmSpecialEffectSunken
Case Is = "4"
myString = lblTag4.Caption
lblTag4.Caption = lblTag3.Caption
lblTag3.Caption = myString
Label5.Caption = "3"
lblTag3.SpecialEffect = fmSpecialEffectEtched
lblTag4.SpecialEffect = fmSpecialEffectSunken
End Select

End Sub

Private Sub lblTag1_Click()
Label5.Caption = "1"
lblTag1.SpecialEffect = fmSpecialEffectEtched
lblTag2.SpecialEffect = fmSpecialEffectSunken
lblTag3.SpecialEffect = fmSpecialEffectSunken
lblTag4.SpecialEffect = fmSpecialEffectSunken
End Sub

Private Sub lblTag2_Click()
Label5.Caption = "2"
lblTag2.SpecialEffect = fmSpecialEffectEtched
lblTag1.SpecialEffect = fmSpecialEffectSunken
lblTag3.SpecialEffect = fmSpecialEffectSunken
lblTag4.SpecialEffect = fmSpecialEffectSunken
End Sub

Private Sub lblTag3_Click()
Label5.Caption = "3"
lblTag3.SpecialEffect = fmSpecialEffectEtched
lblTag1.SpecialEffect = fmSpecialEffectSunken
lblTag2.SpecialEffect = fmSpecialEffectSunken
lblTag4.SpecialEffect = fmSpecialEffectSunken
End Sub

Private Sub lblTag4_Click()
Label5.Caption = "4"
lblTag4.SpecialEffect = fmSpecialEffectEtched
lblTag1.SpecialEffect = fmSpecialEffectSunken
lblTag2.SpecialEffect = fmSpecialEffectSunken
lblTag3.SpecialEffect = fmSpecialEffectSunken
End Sub

Private Sub UserForm_Initialize()
Dim i As Integer
Dim myObject As Object
Dim mySelectionSet As AcadSelectionSet
Dim myAttributes As Variant
Set mySelectionSet = ThisDrawing.SelectionSets.Add("Fred")
Dim gpCode(0 To 1) As Integer
Dim dataValue(0 To 1) As Variant
Dim groupCode As Variant
Dim dataCode As Variant
gpCode(0) = 2 'name
gpCode(1) = 0 'item
groupCode = gpCode
dataValue(0) = "STLA*" 'layer name
dataValue(1) = "INSERT" 'item type
dataCode = dataValue
mySelectionSet.Select acSelectionSetAll, , , groupCode, dataCode
If mySelectionSet.Count = 1 Then
'a block has been selected
Set myObject = mySelectionSet.Item(0)
myAttributes = myObject.GetAttributes
For i = 0 To UBound(myAttributes) - 1
If myAttributes(i).TagString = "TITLE1" Then
   lblTag1 = myAttributes(i).TextString
   Label1 = i
   End If
If myAttributes(i).TagString = "TITLE2" Then
   lblTag2 = myAttributes(i).TextString
   Label2 = i
   End If
If myAttributes(i).TagString = "TITLE3" Then
   lblTag3 = myAttributes(i).TextString
   Label3 = i
   End If
If myAttributes(i).TagString = "TITLE4" Then
   lblTag4 = myAttributes(i).TextString
   Label4 = i
   End If
Next i
Else
MsgBox "This ONLY works with 1 Drawing Border"
End If
ThisDrawing.SelectionSets.Item("Fred").Delete
End Sub

It basically gets the 4 "title" attributes from one of our borders and displays them on a form. You can then shuffle the order of the attributes and write them back to the title block.