TheSwamp
Code Red => VB(A) => Topic started by: TR on April 12, 2004, 07:46:35 PM
-
I'm trying to replace all attribute definitions in modelspace with text. The following code replaces all the attributes with text, but for some reason moves some of them to 0,0,0. Anyone have any ideas?
Public Sub remove_attdef()
Dim SelSet As AcadSelectionSet
Dim AT As AcadAttribute
Dim FilterType(0 To 0) As Integer
Dim FilterData(0 To 0) As Variant
Dim TXT As AcadText
Dim YesNo
'select attribute definitions
FilterType(0) = 0
FilterData(0) = "ATTDEF"
On Error GoTo Exit_Error
ThisDrawing.SelectionSets.Add "SelSet"
Set SelSet = ThisDrawing.SelectionSets("SelSet")
SelSet.Clear
SelSet.Select acSelectionSetAll, , , FilterType, FilterData
'if the count is greater than 1 then there are attribute definitions in
modelspace
If SelSet.Count <> 0 Then
YesNo = MsgBox("You Have " & SelSet.Count & " Attribute
Definition(s) in " & ThisDrawing.Name & ". This Program will attempt to
convert them to Text.", _
vbYesNo + vbCritical + vbDefaultButton1)
'if "Ok" is pressed then try to replace all of the attribute
definitions with text that has the same properties.
If YesNo = vbYes Then
For Each AT In SelSet
Set TXT = ThisDrawing.ModelSpace.AddText(AT.TagString,
AT.InsertionPoint, AT.Height)
TXT.Alignment = AT.Alignment
TXT.Layer = AT.Layer
TXT.Color = AT.Color
TXT.Rotation = AT.Rotation
TXT.Update
AT.Delete
Next
End If
End If
'clear the selection set
SelSet.Clear
'rescan the drawing for attribute definitions
SelSet.Select acSelectionSetAll, , , FilterType, FilterData
'if it the count is zero then it worked.
If SelSet.Count = 0 Then
MsgBox "All attributes were converted to text."
Else:
MsgBox "Failed to convert all attributes to text."
End If
Exit_Error:
SelSet.Delete
Set SelSet = Nothing
Set AT = Nothing
Set TXT = Nothing
End Sub
-
have you tried "burst"?
-
what if you add
Dim insertionZero(0 To 2) As Double
insertionZero(0) = 0: insertionZero(1) = 0: insertionZero(2) = 0
TXT.Move insertionZero, AT.InsertionPoint
This should correct your problem.
I'm not sure why, but I've had a similar problem with using VBA to place text into drawings.
-
Ok, the problem is one that many people tend to overlook. Whenever you insert text with VBA and use the alignment point, you should be transferring both of the alignment points.
If a text item is defined as anything other than left justified, Autodesk saw fit to use a different DXF code to implement that point. Problem is, that whenever you initially define a bit of text if the initial alignment point is anything bet left, the point referenced by InsertionPoint is always 0,0,0 and whenever you insert text that is left justified, the point referenced by TextAlignmentPoint is always 0,0,0 So......
For Each AT In SelSet
Set TXT = ThisDrawing.ModelSpace.AddText(AT.TagString,
AT.InsertionPoint, AT.Height)
TXT.Alignment = AT.Alignment
TXT.TextAlignmentPoint = AT.TextAlignmentPoint
TXT.Layer = AT.Layer
TXT.Color = AT.Color
TXT.Rotation = AT.Rotation
TXT.Update
AT.Delete
Next
So this should fix that problem...
Just remember that if you apply the alignment point BEFORE you apply the alignment, the text will sometimes do wierd things...
So apply the alignment first then apply the alignment point.
-
Thanks guys.
I added the TextAlignmentPoint stuff and now it's not moving all the items but it's skipping some of the attribute definitions. I'll have to take a look at a little closer when I get some free time.
-
Turn off the error checking the next time you run it and see if it is a coding error.
-
I was working on a lisp of this once and Stig helped (gave) me with a solution. Let me go see if I can find it.
-
How's this (http://www.theswamp.org/phpBB2/viewtopic.php?p=5104#5104)?
-
Thanks Daron.....but I want to do it in vba. I don't really know visual-lisp and I'm not about to start learning it now. :)
-
That's too bad. That's one fast routine. You're welcome.
-
the code ran fine for me when I substituted Keiths code regarding alignment
-
Hendie, I think that would appear to be the fix
-
It seems I was getting a weird error message. I looked it up online and it doesn't really mean anything. I did a select case to check if it for that error message and resume next if it was. I'll post the code when I get to work tomorrow in case anyone wants it for anything.
Thanks for the help guys.
-
Here's the fixed code if anyone's interested.
Option Explicit
Public Sub remove_attdef()
Dim SelSet As AcadSelectionSet
Dim AT As AcadAttribute
Dim FilterType(0 To 0) As Integer
Dim FilterData(0 To 0) As Variant
Dim TXT As AcadText
Dim YesNo
'select attribute definitions
FilterType(0) = 0
FilterData(0) = "ATTDEF"
On Error GoTo Exit_Error
ThisDrawing.SelectionSets.Add "SelSet"
Set SelSet = ThisDrawing.SelectionSets("SelSet")
SelSet.Clear
SelSet.Select acSelectionSetAll, , , FilterType, FilterData
'if the count is greater than 1 then there are attribute definitions in
modelspace
If SelSet.Count <> 0 Then
YesNo = MsgBox("You Have " & SelSet.Count & " Attribute
Definition(s) in " & ThisDrawing.Name & _
". Would you like this program to attempt to convert them to text?",
_
vbYesNo + vbCritical + vbDefaultButton1)
'if "Ok" is pressed then try to replace all of the attribute
definitions with text that has the same properties.
If YesNo = vbYes Then
For Each AT In SelSet
Set TXT = ThisDrawing.ModelSpace.AddText(AT.TagString,
AT.InsertionPoint, AT.Height)
TXT.Alignment = AT.Alignment
TXT.TextAlignmentPoint = AT.TextAlignmentPoint
TXT.Layer = AT.Layer
TXT.Color = AT.Color
TXT.Rotation = AT.Rotation
TXT.Update
AT.Delete
Next
End If
End If
'clear the selection set
SelSet.Clear
'rescan the drawing for attribute definitions
SelSet.Select acSelectionSetAll, , , FilterType, FilterData
'if it the count is zero then it worked.
If SelSet.Count = 0 Then
MsgBox "All attributes were converted to text."
Else:
MsgBox "Failed to convert all attributes to text."
End If
Exit_Error:
Select Case Err.Number
Case -2145386494 'not applicable
Resume Next
Case Else
SelSet.Delete
Set SelSet = Nothing
Set AT = Nothing
Set TXT = Nothing
End Select
End Sub
-
funny how things work out.
I just found a use for this routine. Thanks guys.
-
:)
-
Well, it is kinda funny how collective efforts sometimes pays off in the end...