getting block attributes - VBA

dbroada · 发表于 2022-7-6 14:40:08

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....

copy

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?

CmdrDuh · 发表于 2022-7-6 14:48:58

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.

CmdrDuh · 发表于 2022-7-6 15:01:39

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

copy

    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

dbroada · 发表于 2022-7-6 15:10:20

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.

CmdrDuh · 发表于 2022-7-6 15:21:57

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

dbroada · 发表于 2022-7-6 15:23:56

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

BIGAL · 发表于 2022-7-6 15:33:11

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

copy

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]

dbroada · 发表于 2022-7-6 15:46:04

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.

copy

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.

[编程交流] getting block attributes - VBA

发表回复

精选推荐