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.GetAttributesfor i = 0 to ubound(myAttributes)debug.print myAttributes(i).TagString;myAttributes(i).TextStringnext 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 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
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 ExplicitPrivate Sub cmdDown_Click()Dim myString As StringSelect Case Label5.CaptionCase Is = "1"myString = lblTag1.CaptionlblTag1.Caption = lblTag2.CaptionlblTag2.Caption = myStringLabel5.Caption = "2"lblTag2.SpecialEffect = fmSpecialEffectEtchedlblTag1.SpecialEffect = fmSpecialEffectSunkenCase Is = "2"myString = lblTag2.CaptionlblTag2.Caption = lblTag3.CaptionlblTag3.Caption = myStringLabel5.Caption = "3"lblTag3.SpecialEffect = fmSpecialEffectEtchedlblTag2.SpecialEffect = fmSpecialEffectSunkenCase Is = "3"myString = lblTag3.CaptionlblTag3.Caption = lblTag4.CaptionlblTag4.Caption = myStringLabel5.Caption = "4"lblTag4.SpecialEffect = fmSpecialEffectEtchedlblTag3.SpecialEffect = fmSpecialEffectSunkenEnd SelectEnd SubPrivate Sub cmdExit_Click()Unload MeEnd SubPrivate Sub cmdPopulate_Click()Dim myObject As ObjectDim mySelectionSet As AcadSelectionSetDim myAttributes As VariantSet mySelectionSet = ThisDrawing.SelectionSets.Add("Fred")Dim gpCode(0 To 1) As IntegerDim dataValue(0 To 1) As VariantDim groupCode As VariantDim dataCode As VariantgpCode(0) = 2 'namegpCode(1) = 0 'itemgroupCode = gpCodedataValue(0) = "STLA*" 'layer namedataValue(1) = "INSERT" 'item typedataCode = dataValuemySelectionSet.Select acSelectionSetAll, , , groupCode, dataCodeSet myObject = mySelectionSet.Item(0)myAttributes = myObject.GetAttributesIf lblTag1.Caption"" Then myAttributes(Label1).TextString = lblTag1.Caption Else myAttributes(Label1).TextString = "" End IfIf lblTag2.Caption"" Then myAttributes(Label2).TextString = lblTag2.Caption Else myAttributes(Label2).TextString = "" End IfIf lblTag3.Caption"" Then myAttributes(Label3).TextString = lblTag3.Caption Else myAttributes(Label3).TextString = "" End IfIf lblTag4.Caption"" Then myAttributes(Label4).TextString = lblTag4.Caption Else myAttributes(Label4).TextString = "" End IfThisDrawing.SelectionSets.Item("Fred").DeleteUnload MeEnd SubPrivate Sub cmdUp_Click()Dim myString As StringSelect Case Label5.CaptionCase Is = "2"myString = lblTag2.CaptionlblTag2.Caption = lblTag1.CaptionlblTag1.Caption = myStringLabel5.Caption = "1"lblTag1.SpecialEffect = fmSpecialEffectEtchedlblTag2.SpecialEffect = fmSpecialEffectSunkenCase Is = "3"myString = lblTag3.CaptionlblTag3.Caption = lblTag2.CaptionlblTag2.Caption = myStringLabel5.Caption = "2"lblTag2.SpecialEffect = fmSpecialEffectEtchedlblTag3.SpecialEffect = fmSpecialEffectSunkenCase Is = "4"myString = lblTag4.CaptionlblTag4.Caption = lblTag3.CaptionlblTag3.Caption = myStringLabel5.Caption = "3"lblTag3.SpecialEffect = fmSpecialEffectEtchedlblTag4.SpecialEffect = fmSpecialEffectSunkenEnd SelectEnd SubPrivate Sub lblTag1_Click()Label5.Caption = "1"lblTag1.SpecialEffect = fmSpecialEffectEtchedlblTag2.SpecialEffect = fmSpecialEffectSunkenlblTag3.SpecialEffect = fmSpecialEffectSunkenlblTag4.SpecialEffect = fmSpecialEffectSunkenEnd SubPrivate Sub lblTag2_Click()Label5.Caption = "2"lblTag2.SpecialEffect = fmSpecialEffectEtchedlblTag1.SpecialEffect = fmSpecialEffectSunkenlblTag3.SpecialEffect = fmSpecialEffectSunkenlblTag4.SpecialEffect = fmSpecialEffectSunkenEnd SubPrivate Sub lblTag3_Click()Label5.Caption = "3"lblTag3.SpecialEffect = fmSpecialEffectEtchedlblTag1.SpecialEffect = fmSpecialEffectSunkenlblTag2.SpecialEffect = fmSpecialEffectSunkenlblTag4.SpecialEffect = fmSpecialEffectSunkenEnd SubPrivate Sub lblTag4_Click()Label5.Caption = "4"lblTag4.SpecialEffect = fmSpecialEffectEtchedlblTag1.SpecialEffect = fmSpecialEffectSunkenlblTag2.SpecialEffect = fmSpecialEffectSunkenlblTag3.SpecialEffect = fmSpecialEffectSunkenEnd SubPrivate Sub UserForm_Initialize()Dim i As IntegerDim myObject As ObjectDim mySelectionSet As AcadSelectionSetDim myAttributes As VariantSet mySelectionSet = ThisDrawing.SelectionSets.Add("Fred")Dim gpCode(0 To 1) As IntegerDim dataValue(0 To 1) As VariantDim groupCode As VariantDim dataCode As VariantgpCode(0) = 2 'namegpCode(1) = 0 'itemgroupCode = gpCodedataValue(0) = "STLA*" 'layer namedataValue(1) = "INSERT" 'item typedataCode = dataValuemySelectionSet.Select acSelectionSetAll, , , groupCode, dataCodeIf mySelectionSet.Count = 1 Then'a block has been selectedSet myObject = mySelectionSet.Item(0)myAttributes = myObject.GetAttributesFor i = 0 To UBound(myAttributes) - 1If myAttributes(i).TagString = "TITLE1" Then lblTag1 = myAttributes(i).TextString Label1 = i End IfIf myAttributes(i).TagString = "TITLE2" Then lblTag2 = myAttributes(i).TextString Label2 = i End IfIf myAttributes(i).TagString = "TITLE3" Then lblTag3 = myAttributes(i).TextString Label3 = i End IfIf myAttributes(i).TagString = "TITLE4" Then lblTag4 = myAttributes(i).TextString Label4 = i End IfNext iElseMsgBox "This ONLY works with 1 Drawing Border"End IfThisDrawing.SelectionSets.Item("Fred").DeleteEnd 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.
页:
[1]