Get the PromptStrings of an existing block

Hy!

I have a dinamic block. The user can select this block with this code:

Dim objEnt As AcadBlockReference

Me.Hide

With ThisDrawing.Utility

.GetEntity objEnt, varPick, vbCr & "Válasszon ki egy blokkot: "

End With

I have to list all of the PromptStrings of the dynamic block onto a listbox with VBA. I looked at many codes already on the net, but not working.

With the list of TagString and TextString is succeed, but I would need PromptString.

Can somebody help? Greet!

You would have to look through the attribute objects in the block definition, I can show you in LISP but not in VBA

Eg:

;;-----------------=={ Get PromptStrings }==------------------;;
;;                                                            ;;
;;  Returns a list of the PromptString for each attribute     ;;
;;  within the specified block                                ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  blockname - the name of the block                         ;;
;;------------------------------------------------------------;;
;;  Returns:  list of (<Tag> . <Prompt>), else nil            ;;
;;------------------------------------------------------------;;

(defun LM:GetPromptStrings ( blockname / def result )
 (vl-load-com)
 ;; © Lee Mac 2010

 (if (setq def
       (LM:Itemp
         (vla-get-Blocks
           (vla-get-ActiveDocument
             (vlax-get-acad-object)
           )
         )
         blockname
       )
     )
   (vlax-for obj def
     (if (eq "AcDbAttributeDefinition" (vla-get-objectname obj))
       (setq result
         (cons
           (cons (vla-get-TagString obj) (vla-get-PromptString obj))
           result
         )
       )
     )
   )
 )
 (reverse result)
)

;;-----------------------=={ Itemp }==------------------------;;
;;                                                            ;;
;;  Retrieves the item with index 'item' if present in the    ;;
;;  specified collection, else nil                            ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  coll - the VLA Collection Object                          ;;
;;  item - the index of the item to be retrieved              ;;
;;------------------------------------------------------------;;
;;  Returns:  the VLA Object at the specified index, else nil ;;
;;------------------------------------------------------------;;

(defun LM:Itemp ( coll item )
 ;; © Lee Mac 2010
 (if
   (not
     (vl-catch-all-error-p
       (setq item
         (vl-catch-all-apply
           (function vla-item) (list coll item)
         )
       )
     )
   )
   item
 )
) 

(LM:GetPromptStrings "BlockName")

==>  ((<Tag1> . <Prompt1>) (<Tag2> . <Prompt2>) ... (<Tagn> . <Promptn>))

Or an alternative approach, using DXF Tables:

(defun LM:GetPromptStrings ( blockname / def result )
 ;; © Lee Mac 2010
 
 (if (setq def (tblobjname "BLOCK" blockname))
   (while (setq def (entnext def))
     (if (eq "ATTDEF" (cdr (assoc 0 (entget def))))
       (setq result
         (cons
           (cons
             (cdr (assoc 2 (entget def)))
             (cdr (assoc 3 (entget def)))
           )
           result
         )
       )
     )
   )
 )

 (reverse result)
)

Thanks for this code, but i dont know the Lisp a little bit unfortunately.

I have to solve the problem in VBA.

Eg:

 

;;-----------------=={ Get PromptStrings }==------------------;;
;;                                                            ;;
;;  Returns a list of the PromptString for each attribute     ;;
;;  within the specified block                                ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  blockname - the name of the block                         ;;
;;------------------------------------------------------------;;
;;  Returns:  list of (<Tag> . <Prompt>), else nil            ;;
;;------------------------------------------------------------;;

(defun LM:GetPromptStrings ( blockname / def result )
 (vl-load-com)
 ;; © Lee Mac 2010

 (if (setq def
       (LM:Itemp
         (vla-get-Blocks
           (vla-get-ActiveDocument
             (vlax-get-acad-object)
           )
         )
         blockname
       )
     )
   (vlax-for obj def
     (if (eq "AcDbAttributeDefinition" (vla-get-objectname obj))
       (setq result
         (cons
           (cons (vla-get-TagString obj) (vla-get-PromptString obj))
           result
         )
       )
     )
   )
 )
 (reverse result)
)

;;-----------------------=={ Itemp }==------------------------;;
;;                                                            ;;
;;  Retrieves the item with index 'item' if present in the    ;;
;;  specified collection, else nil                            ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  coll - the VLA Collection Object                          ;;
;;  item - the index of the item to be retrieved              ;;
;;------------------------------------------------------------;;
;;  Returns:  the VLA Object at the specified index, else nil ;;
;;------------------------------------------------------------;;

(defun LM:Itemp ( coll item )
 ;; © Lee Mac 2010
 (if
   (not
     (vl-catch-all-error-p
       (setq item
         (vl-catch-all-apply
           (function vla-item) (list coll item)
         )
       )
     )
   )
   item
 )
) 

(LM:GetPromptStrings "BlockName")

==>  ((<Tag1> . <Prompt1>) (<Tag2> . <Prompt2>) ... (<Tagn> . <Promptn>))

Or an alternative approach, using DXF Tables:

 

(defun LM:GetPromptStrings ( blockname / def result )
 ;; © Lee Mac 2010
 
 (if (setq def (tblobjname "BLOCK" blockname))
   (while (setq def (entnext def))
     (if (eq "ATTDEF" (cdr (assoc 0 (entget def))))
       (setq result
         (cons
           (cons
             (cdr (assoc 2 (entget def)))
             (cdr (assoc 3 (entget def)))
           )
           result
         )
       )
     )
   )
 )

 (reverse result)
)

The methods used in my first code will apply to VBA.

Sorry, but i don't understand (i am week of english), i can run this Lisp code trought VBA?

It is possibly to write the results into a file with Lisp?

After that I can read it with vba, if clear vba solution does not exist...

The methods used in my first code will apply to VBA.

Hy!

 

I have a dinamic block. The user can select this block with this code:

 

Dim objEnt As AcadBlockReference

Me.Hide

With ThisDrawing.Utility

.GetEntity objEnt, varPick, vbCr & "Válasszon ki egy blokkot: "

End With

 

I have to list all of the PromptStrings of the dynamic block onto a listbox with VBA. I looked at many codes already on the net, but not working.

 

With the list of TagString and TextString is succeed, but I would need PromptString.

 

Can somebody help? Greet!

You can start from this routine

 
Sub GetPromptString()
Dim oEnt As AcadEntity
Dim oBlkRef As AcadBlockReference
Dim oBlock As AcadBlock
Dim oItem As AcadEntity
Dim oAttrib As AcadAttribute
Dim i
Dim strPrompt As String
Dim strTag As String
Dim ftype(0 To 1) As Integer
Dim fdata(0 To 1) As Variant
ftype(0) = 0: ftype(1) = 66
fdata(0) = "INSERT": fdata(1) = 1
Dim oSset As AcadSelectionSet

         With ThisDrawing.SelectionSets

              While .count > 0
                   .Item(0).Delete

              Wend

         Set oSset = .Add("$Temp$")

         End With

         oSset.SelectOnScreen ftype, fdata

         strTag = ThisDrawing.Utility.GetString(False, vbCrLf & "Enter attribute tag: ")

       For Each oEnt In oSset

       Set oBlkRef = oEnt

       Set oBlock = ThisDrawing.Blocks.Item(oBlkRef.EffectiveName)

       For i = 0 To oBlock.count - 1

       Set oItem = oBlock(i)

       If TypeOf oItem Is AcadAttribute Then

       Set oAttrib = oItem

       If StrComp(oAttrib.TagString, strTag, vbTextCompare) = 0 Then

       strPrompt = oAttrib.PromptString

       Exit For

       End If

       End If

       Next i

       Next oEnt

       MsgBox IIf(strPrompt = "", "Block has not this attribute", "Prompt: " & strPrompt)
End Sub

~'J'~

Thank you. I will look at it, I have to go away now only. I look at this code on a Monday and I write what I tried out in.

You can start from this routine

 
Sub GetPromptString()
Dim oEnt As AcadEntity
Dim oBlkRef As AcadBlockReference
Dim oBlock As AcadBlock
Dim oItem As AcadEntity
Dim oAttrib As AcadAttribute
Dim i
Dim strPrompt As String
Dim strTag As String
Dim ftype(0 To 1) As Integer
Dim fdata(0 To 1) As Variant
ftype(0) = 0: ftype(1) = 66
fdata(0) = "INSERT": fdata(1) = 1
Dim oSset As AcadSelectionSet

         With ThisDrawing.SelectionSets

              While .count > 0
                   .Item(0).Delete

              Wend

         Set oSset = .Add("$Temp$")

         End With

         oSset.SelectOnScreen ftype, fdata

         strTag = ThisDrawing.Utility.GetString(False, vbCrLf & "Enter attribute tag: ")

       For Each oEnt In oSset

       Set oBlkRef = oEnt

       Set oBlock = ThisDrawing.Blocks.Item(oBlkRef.EffectiveName)

       For i = 0 To oBlock.count - 1

       Set oItem = oBlock(i)

       If TypeOf oItem Is AcadAttribute Then

       Set oAttrib = oItem

       If StrComp(oAttrib.TagString, strTag, vbTextCompare) = 0 Then

       strPrompt = oAttrib.PromptString

       Exit For

       End If

       End If

       Next i

       Next oEnt

       MsgBox IIf(strPrompt = "", "Block has not this attribute", "Prompt: " & strPrompt)
End Sub

~'J'~

Thank you. I will look at it, I have to go away now only. I look at this code on a Monday and I write what I tried out in.

Here is what you want exactly

 
Option Explicit
Private Sub CommandButton1_Click()
Dim varPick
Dim objEnt As AcadEntity
Dim objItem As AcadEntity
Dim objBlkRef As AcadBlockReference
Dim objBlkDef As AcadBlock
Dim objAttrib As AcadAttribute
Me.Hide
With ThisDrawing
.Utility.GetEntity objEnt, varPick, vbCrLf & "Valasszon ki egy blokkot: "
If TypeOf objEnt Is AcadBlockReference Then
Set objBlkRef = objEnt
Set objBlkDef = .Blocks.Item(objBlkRef.EffectiveName)
For Each objItem In objBlkDef
If TypeOf objItem Is AcadAttribute Then
Set objAttrib = objItem
ListBox1.AddItem objAttrib.PromptString
End If
Next objItem
Else
MsgBox "Nem blokk, ismetelt kivalasztasa"
Exit Sub
End If
End With
ListBox1.ListIndex = -1
Me.Show
End Sub

~'J'~

Sorry, but i don't understand (i am week of english), i can run this Lisp code trought VBA?

 

It is possibly to write the results into a file with Lisp?

After that I can read it with vba, if clear vba solution does not exist...

No, I am saying that where I use vla-item for example, there is an identical method in VBA:

Blocks.Item(...)

That works perfect, thankyou!!!

I try with this code, I see it so I was unfair too far from the solution. :

Dim Attribútumok() As Variant
Dim Elem(0 To 3) As String

Public Sub GetAttribútumok(ByRef dinblock As AcadBlockReference)
   Dim varPick As Variant
   Dim objBRef As AcadBlockReference
   Dim varAttribs As Variant
   Dim strAttribs As String
   Dim ElemP As Variant

   Dim intI As Integer

   With ThisDrawing.Utility
   Set objBRef = dinblock
   If objBRef Is Nothing Then
   .prompt vbCr & "Not block selected."
   Exit Sub
   End If

   If Not objBRef.HasAttributes Then
   .prompt vbCr & "That block doesn't have attributes."
   Exit Sub
   End If

   Dim att As AcadAttribute
   For Each att In objBRef.GetAttributes '<- ERROR: Object Required
       MsgBox att.PromptString
   Next att

   '' get the attributerefs
   'there are all working except PromptString:
   varAttribs = objBRef.GetAttributes
   strAttribs = "Block Name: " & objBRef.name & vbCrLf
   ReDim Attribútumok(UBound(varAttribs))

   For intI = LBound(varAttribs) To UBound(varAttribs)
   strAttribs = strAttribs & " Tag(" & intI & "): " & _
   varAttribs(intI).TagString & vbTab & " Value(" & intI & "): " & _
   varAttribs(intI).TextString & vbCrLf

   Elem(0) = intI
   Elem(1) = varAttribs(intI).TagString
   Elem(2) = varAttribs(intI).PromptString '<- ERROR: Run-time error: 438 Object doesn't support this property or method.
   Elem(3) = varAttribs(intI).TextString

   Attribútumok(intI) = Elem
   Next
   End With
End Sub

Here is what you want exactly

 

 
Option Explicit
Private Sub CommandButton1_Click()
Dim varPick
Dim objEnt As AcadEntity
Dim objItem As AcadEntity
Dim objBlkRef As AcadBlockReference
Dim objBlkDef As AcadBlock
Dim objAttrib As AcadAttribute
Me.Hide
With ThisDrawing
.Utility.GetEntity objEnt, varPick, vbCrLf & "Valasszon ki egy blokkot: "
If TypeOf objEnt Is AcadBlockReference Then
Set objBlkRef = objEnt
Set objBlkDef = .Blocks.Item(objBlkRef.EffectiveName)
For Each objItem In objBlkDef
If TypeOf objItem Is AcadAttribute Then
Set objAttrib = objItem
ListBox1.AddItem objAttrib.PromptString
End If
Next objItem
Else
MsgBox "Nem blokk, ismetelt kivalasztasa"
Exit Sub
End If
End With
ListBox1.ListIndex = -1
Me.Show
End Sub

~'J'~

Glad to help

Happy coding

~'J'~