AutoCAD 2004 - How to get the TextStyle of an attribute

[malik641]

Hey Guys,

I can't get this to give me the text style (like "Standard" or "Architectural")...what am I doing wrong?

[vba]
Sub Block_Attrib_TextStyle()
On Error Resume Next
Dim objBRef As AcadBlockReference
Dim varAttribs As Variant
Dim intI As Integer
For Each objBRef In ThisDrawing.ActiveSelectionSet
If objBRef.HasAttributes And Not objBRef Is Nothing Then
varAttribs = objBRef.GetAttributes
For intI = LBound(varAttribs) To UBound(varAttribs)
Debug.Print varAttribs(intI).Layer
Debug.Print varAttribs(intI).TextStyle
Next intI
End If
Next objBRef
End Sub
[/vba]

Also, I only select the blocks with attributes BEFORE I run the code...I'm not sure how to get it to work if I select a bunch of stuff (blocks, lines, circles, etc) then run the code... If I do with this code above, it won't even find the blocks with attributes.

TIA

[lucas]

Hi Joseph,
This is an example using selectionset. It actually selects all dimensions on the drawing and highlights the ones with text override. Might give you a clue on the text attributes too.

Do you use attributes to extract your bom to excel?

[VBA]
Sub ad_VerifyDims()
'This routine highlights dimensions with overrides.
'Demand load: -vbarun;ad_Utility.dvb!ad_VerifyDims;
Dim adDimension As AcadDimension
Dim adSS As AcadSelectionSet
Dim fType(0 To 1) As Integer, fData(0 To 1)
Dim adOverRideCount As Integer
adOverRideCount = 0

Set adSS = ThisDrawing.SelectionSets.Add("adSS")
If Err Then Set adSS = ThisDrawing.SelectionSets.Add("adSS")
adSS.Clear
fType(0) = 0: fData(0) = "DIMENSION": fType(1) = 100: fData(1) = "*"
adSS.Select acSelectionSetAll, , , fType, fData

For Each adDimension In adSS
If adDimension.TextOverride <> "" Then
adDimension.TextColor = acYellow
adOverRideCount = adOverRideCount + 1
End If
Next adDimension
ThisDrawing.Application.Update
MsgBox adOverRideCount & " dimension override(s) found..."
adSS.Delete
End Sub
[/VBA]

[lucas]

Here is the code to reset the dims to original:
[VBA]
Sub ad_VerifyDimsResetColor()
'This routine restores dimension colors highlighted by 'ad_VerifyDims'.
'Demand load: -vbarun;ad_Utility.dvb!ad_VerifyDimsResetColor;
Dim adDimension As AcadDimension
Dim adSS As AcadSelectionSet
Dim fType(0 To 1) As Integer, fData(0 To 1)
Dim adOverRideCount As Integer
Set adSS = ThisDrawing.SelectionSets.Add("adSS")
If Err Then Set adSS = ThisDrawing.SelectionSets.Add("adSS")
adSS.Clear
fType(0) = 0: fData(0) = "DIMENSION": fType(1) = 100: fData(1) = "*"
adSS.Select acSelectionSetAll, , , fType, fData

For Each adDimension In adSS
If adDimension.TextColor = acYellow Then
adDimension.TextColor = ThisDrawing.GetVariable("DimClrT")
End If
Next adDimension
ThisDrawing.Application.Update
adSS.Delete
End Sub
[/VBA]

[malik641]

Steve,

Thanks for the code, I'll test it out after work

Also, no I'm not sending it to excel. I'm working on a KB entry You'll see what I'm going for when I have it finished!

Yeah! More KB's!!! There's like NONE in AutoCAD!!! I've got so many ideas!!!

[lucas]

I think that attributes are different than text.....
go to draw-block-define attributes.
create several of them then group and block them...are you familiar with this process?

[malik641]

Not entirely...I'm going to have to try it out when I get home.

Thanks Steve

[Tommy]

Hey Joseph,
Don't know where you are on this but umm here I used you code
[VBA]Sub Block_Attrib_TextStyle()
On Error Resume Next
Dim objBRef As AcadBlockReference
Dim varAttribs As Variant
Dim intI As Integer
For Each objBRef In ThisDrawing.ActiveSelectionSet
If objBRef.HasAttributes And Not objBRef Is Nothing Then
varAttribs = objBRef.GetAttributes
For intI = LBound(varAttribs) To UBound(varAttribs)
Debug.Print varAttribs(intI).Layer
Debug.Print varAttribs(intI).StyleName '<--
Next intI
End If
Next objBRef
End Sub [/VBA]

[fixo]

Try this instead:
[vba]
Sub Attrib_TextStyle()
Dim Blocks As AcadBlocks
Dim oBlock As AcadBlock
Dim objEnt As AcadEntity
Dim oAttDef As AcadAttribute
Dim bName As String

On Error GoTo what_a
Set Blocks = ThisDrawing.Blocks
For Each oBlock In Blocks
With oBlock
bName = .Name
If bName = "" Then Exit For
If oBlock.IsLayout = False And _
oBlock.IsXRef = False Then

Debug.Print "Block Name: " & bName
For Each objEnt In oBlock
If TypeOf objEnt Is AcadAttribute Then
Set oAttDef = objEnt
Debug.Print "Tag: " & oAttDef.TagString & vbNewLine & _
"Prompt: " & oAttDef.PromptString & vbNewLine & _
"Layer: " & oAttDef.Layer & vbNewLine & _
"TextStyle: " & oAttDef.StyleName
End If
Next
Debug.Print String(15, "_")
End If
End With
Next
what_a:
MsgBox Err.Description
End Sub
[/vba]

Fatty

~'J'~