Jump to content

Block Attributes to Text Error


habakay

Recommended Posts

I try to add Text object at the same point with Block object.

But it gave an error at red line below.

 

Error Code is;

Run-time error '5':

Invalid prosedure call or argument

 

Sub Block_Attributes_to_Text()
Dim obj As AcadBlockReference
Dim oText As AcadText
Dim inspt As Variant
Dim AttList As Variant
Dim metin As String
Dim poz As String
Dim adet As String
Dim cap As String
Dim ara As String
Dim boy As String
Dim MidPoint(0 To 2)
Dim NewColorObject As AcadAcCmColor
Dim acı As Double

ThisDrawing.Utility.GetEntity obj, inspt, "Select Block:"

If obj.ObjectName = "AcDbBlockReference" Then

   If obj.HasAttributes Then

       AttList = obj.GetAttributes

       For i = LBound(AttList) To UBound(AttList)

           Select Case AttList(i).TagString
   
           Case Is = "POZ1"
               poz = AttList(i).TextString
           Case Is = "DAD"
               adet = AttList(i).TextString
           Case Is = "CAP"
               cap = AttList(i).TextString
           Case Is = "ARA"
               ara = AttList(i).TextString
           Case Is = "BOY1"
               boy = AttList(i).TextString
           End Select

       Next i

   End If

Else
   MsgBox "You did not select a block."
End If
       
    
       metin = poz & "+" & adet & "»" & cap & "/" & ara & " L=" & boy

       MidPoint(0) = obj.InsertionPoint(0)
       MidPoint(1) = obj.InsertionPoint(1)
       MidPoint(2) = 0

       [b][color=red]Set oText = ThisDrawing.ModelSpace.AddText(metin, MidPoint, 5)[/color][/b]
       Set NewColorObject = obj.TrueColor
       NewColorObject.ColorMethod = acColorMethodByACI
       NewColorObject.ColorIndex = 2
       oText.TrueColor = NewColorObject
           
       acı = obj.Rotation
       oText.Rotate MidPoint, acı
       oText.Update



acı = Empty
Set NewColorObject = Nothing
Erase MidPoint
boy = vbNullString
ara = vbNullString
cap = vbNullString
adet = vbNullString
poz = vbNullString
metin = vbNullString
AttList = Empty
inspt = Empty
oText = Nothing
obj = Nothing


End Sub

Link to comment
Share on other sites

just declare MidPoint as double

Dim MidPoint(0 To 2) As Double

 

also, though having nothing to do with the problem you encountered, you must also change last two lines at the bottom, adding the "set" keyword at their begininng

Set oText = Nothing
Set obj = Nothing

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...