Attribute to x,y location from Text

Hi group,
I need some help with insertion of attributes. I have a attribute block
named "litetag" that is already in the drawing and I am trying to insert the
attribute
block at the text insertion point of text that is in the drawing and
populate the attribute text with the value from the text.
The routine does all those functions but I have to use insert at 0,0 for the
attributes block to display in the drawing. also the attributes come in as
one WHOLE block and not separate blocks.

what I was attempting to do was insert the attribute block as a single block
at each text location from the x,y location of text in a drawing with the
text value.

I created the attribute block at 0,0
It sound simple but I'm stuck. help!

any help or comments are appreciated.

Have a great day
John Coon

Option Explicit
Public Sub TextToATTS()
Dim obj As AcadEntity
Dim objText As AcadText
Dim Textrot As String
Dim Textvalue As String
Dim dWidth As Double
Dim dHeight As Double
Dim dPt1(0 To 2) As Double
Dim aBlk As AcadBlock
Dim aAtt As AcadAttribute
Dim sBlkName As String
Dim tag As String
Dim value As String
dWidth = 10
dHeight = 6


sBlkName = "LiteTag"
Set aBlk = ThisDrawing.Blocks.Add(dPt1, sBlkName)

For Each obj In ThisDrawing.ModelSpace
If TypeOf obj Is AcadText Then
Set objText = obj
Textrot = objText.Rotation
Textvalue = objText.TextString

' Create the attribute definition object in model space
' Set aAtt = aBlk.AddAttribute(Height, Mode, Prompt, InsertionPoint, tag,
value)
Set aAtt = aBlk.AddAttribute(6#, acAttributeModeNormal, "Textvalue", dPt1,
"LiteTag", Textvalue)
aAtt.Alignment = acAlignmentTopLeft
aAtt.TextAlignmentPoint = dPt1
aAtt.Update

End If
Next obj


End Sub

 

Hi John,
You want to INSERT a block at each Text location.....you were recreating the
Block Definition each time......
Try this:

Public Sub TextToATTS()
Dim obj As AcadEntity
Dim objText As AcadText
Dim Textrot As String
Dim Textvalue As String
Dim dWidth As Double
Dim dHeight As Double
Dim dPt1 As Variant
Dim vPt(0 To 2) As Double
Dim aBlk As AcadBlock
Dim oBlock As AcadBlockReference
Dim aAtt As AcadAttribute
Dim vAtts
Dim oAttribute As AcadAttributeReference
Dim sBlkName As String
Dim tag As String
Dim value As String
dWidth = 10
dHeight = 6

dPt1 = vPt
sBlkName = "LiteTag"
On Error Resume Next
Set aBlk = ThisDrawing.Blocks.Item(sBlkName)
If Err.Number <> 0 Then
Set aBlk = ThisDrawing.Blocks.Add(dPt1, sBlkName)
Set aAtt = aBlk.AddAttribute(6#, acAttributeModeNormal, "Textvalue",
dPt1, "LiteTag", "-")
Err.Clear
End If
On Error GoTo 0
For Each obj In ThisDrawing.ModelSpace
If TypeOf obj Is AcadText Then
Set objText = obj
Textrot = objText.Rotation
Textvalue = objText.TextString
dPt1 = objText.InsertionPoint
Set oBlock = ThisDrawing.ModelSpace.InsertBlock(dPt1, sBlkName,
1#, 1#, 1#, 0#)
vAtts = oBlock.GetAttributes
Set oAttribute = vAtts(0) 'Can do this since we used only 1 att.
in the block def.
oAttribute.TextString = Textvalue
oAttribute.Rotation = Textrot
oAttribute.Alignment = objText.Alignment
If Not objText.Alignment = acAlignmentLeft Then
oAttribute.TextAlignmentPoint = objText.TextAlignmentPoint
End If
oAttribute.Layer = objText.Layer
oAttribute.Height = objText.Height
oAttribute.StyleName = objText.StyleName
oAttribute.Update
objText.Delete
End If
Next obj

End Sub

 

Jeff,

As always thank you for your help.
I'll step thru your edited version to see were I went wrong.

dPt1, "LiteTag", "-")
the "-" set the default and the LiteTag is the tag name & Textvalue is the
prompt field.


So I was setting the block in the loop. I see now, Move it outside/ahead of
the loop.

It's always informative when I post here. Thanks


Thanks and have a great day.
John Coon