Lisp to create bom with blocks

[H_Feather]

I am trying to figure out a LISP to make a BOM table with blocks with attributes. My company currently uses the "BOM Extractor" App which is ok the only thing I wish it had is creating styles with different text heights to save in the app than all I would have to do is select which style I need with the saved text height to insert into the drawing. I came across a thread from 2010 (http://www.cadtutor.net/forum/showthread.php?54412-making-a-bom-list-from-blocks-with-attributes) which is kind of what I am looking for except when I start the lisp command and insert the table it brings in other parts of the attributes I do not need in the BOM. Can someone PLEASE Help me "tweek" the lisp to how I need it? The header and columns need to be like picture 2.

the first picture is when I tried to tweek the lisp myself this is how it came out .

[BIGAL]

You need to post your lisp code and a sample dwg. All posters blocks are different so its hard to do a one code does all.

 

Without going to deeply into it there is a way of reading block attributes without knowing their Tag name and put in correct column of a table.

[H_Feather]

Sorry, really new at this thread posting. After doing more research I came across this code from lee mac which is spectacular:

(defun c:bnum ( / *error* mutter ss doc )
 ;; © Lee Mac  ~  05.06.10

 (defun *error* ( msg )
   (and mutter (setvar 'nomutt mutter))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )

 (or *title (setq *title "Block Data"))
 (or *prev  (setq *prev  "ON"))

 (setq mutter (getvar 'nomutt))
 (setvar 'nomutt 1)

 (princ "\nSelect Blocks to Count <All> : ")

 (cond (  (not (progn (setq ss (cond (  (ssget      '((0 . "INSERT"))))
                                     (  (ssget "_X" '((0 . "INSERT"))))))

                      (setvar 'nomutt mutter) ss))                  

          (princ "\n** No Blocks Found **")
       )
       (
         (_DisplayResult
           (mapcar
             (function
               (lambda ( x ) (list (car x) (itoa (cadr x))))
             )
             (
               (lambda ( / l n )
                 (vlax-for obj
                   (setq ss
                     (vla-get-ActiveSelectionSet
                       (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
                     )
                   )
                   (if (zerop (logand 45 (cdr (assoc 70 (tblsearch "BLOCK" (setq n (BlockName obj)))))))
                     (setq l (assoc++ n l))
                   )
                 )
                 l
               )
             )
           )
         )
       )
       (  (princ "\n** No Blocks Found **")  )
 )
 (princ)
)

(defun _DisplayResult ( lst / rLen )
 (if lst
   (progn
     (setq rLen
       (+ 3
         (apply (function max)
           (cons 5
             (mapcar (function strlen)
               (mapcar (function cadr) lst)
             )
           )
         )
       )
     )
     (mapcar
       (function
         (lambda ( item )
           (princ
             (strcat "\n"
               (PadRight (TidyString (car  item) 40) "."   40) "|"
               (PadLeft  (cadr item) "." rLen)
             )
           )
         )
       )
       (append
         (list '("MANUFACTURER_NUMBER" "QUANTITY")
           (list (PadRight "" "-" 40) (PadLeft  "" "-" rLen))
         )
         (setq lst
           (vl-sort lst
             (function
               (lambda ( a b ) (< (car a) (car b)))
             )
           )
         )
         (list
           (list (PadRight "" "-" 40) (PadLeft "" "-" rLen))
         )
       )
     )

     (terpri)

     (if (> (atof (getvar 'ACADVER)) 16.)
       (progn
         (while
           (progn
             (initget "Yes No Settings")
             (setq choix (getkword "\nTable? [Yes/No/Settings] <Yes> : "))

             (cond (  (or (not choix) (eq "Yes" choix))
                    
                      (GrMove
                        (AddTable
                          (GetActiveSpace
                            (vla-get-ActiveDocument
                              (vlax-get-acad-object)
                            )
                          )
                          (getvar 'VIEWCTR) *title
                          (cons '("Block Name" "Count") lst)
                          (eq "ON" *prev)
                        )
                        'InsertionPoint "\nPlace Table... " 0
                      )
                    nil
                   )
                   (  (eq "Settings" choix)

                      (while
                        (progn
                          (initget "Title Preview Exit")
                          (princ (strcat "\n<< Title: " (if (eq "" *title) "-None-" *title) ", Block Preview: " *prev " >>"))
                          (setq subchoix (getkword "\nEdit Settings [Title/Preview/Exit] <Exit> : "))

                          (cond (  (or (not subchoix) (eq "Exit" subchoix)) nil  )

                                (  (eq "Title" subchoix)

                                   (setq *title (getstring t "\nSpecify Table Title or <Enter> for None: "))
                                )
                                (t (initget "ON OFF")

                                   (setq *prev (cond ((getkword "\nBlock Preview Setting [ON/OFF] <ON> : ")) ("ON")))
                                )                         
                          )
                        )
                      )
                     t
                   )
                   (  (textscr)  )
             )
           )
         )
         t
       )
       (not (textscr))
     )          
   )
 )      
)

(defun assoc++ ( key lst )
 (
   (lambda ( pair )
     (cond
       ( pair
         (subst (list (car pair) (1+ (cadr pair))) pair lst)
       )
       ( (cons (list key 1) lst) )
     )
   )
   (assoc key lst)
 )
)

(defun Is64Bit nil
 (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
)

(defun BlockName ( obj )
 (vlax-get-property obj
   (if (vlax-property-available-p obj 'EffectiveName)
     'EffectiveName 'Name
   )
 )
)

(defun GetActiveSpace ( doc )
 (vlax-get-property doc
   (if (or (eq acModelSpace (vla-get-ActiveSpace doc))
           (eq :vlax-true   (vla-get-MSpace doc)))
     'ModelSpace 'PaperSpace
   )
 )
)

(defun GetObjectID ( obj doc )
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false)
   (itoa (vla-get-Objectid obj))
 )
)

(defun Itemp ( coll item )
 (if
   (not
     (vl-catch-all-error-p
       (setq item
         (vl-catch-all-apply
           (function vla-item) (list coll item)
         )
       )
     )
   )
   item
 )
)

(defun AddTable ( block pt title data preview / blks doc tObj tStyle )
 
 (setq tStyle (GetTableStyle (getvar 'CTABLESTYLE)))
 
 (vlax-put-property
   (setq tObj
     (vla-AddTable block
       (vlax-3D-point pt) (1+ (length data))
       (+ (if preview 1 0) (length (car data)))
       (* 1.8 (vla-getTextHeight tStyle acDataRow))
       (* 0.8
         (apply (function max)
           (mapcar (function strlen)
             (apply (function append) data)
           )
         )
         (vla-getTextHeight tStyle acDataRow)
       )
     )
   )
   'StyleName (getvar 'CTABLESTYLE)
 )  
 (vla-put-RegenerateTableSuppressed tObj :vlax-true)
 
 (setq blks
   (vla-get-blocks
     (setq doc
       (vla-get-ActiveDocument
         (vlax-get-acad-object)
       )
     )
   )
 )

 (if preview
   (progn
     (vla-SetText tObj 1 0 "Preview")
     (
       (lambda ( row )
         (mapcar
           (function
             (lambda ( block ) (setq row (1+ row))
               (vla-SetCellType tObj row 0 acBlockCell)
               (vla-SetBlockTableRecordId tObj row 0
                 (GetObjectID (Itemp blks block) doc) t
               )
             )
           )
           (mapcar (function car) (cdr data))
         )
       )
       1
     )
   )
 )

 (
   (lambda ( row )
     (mapcar
       (function
         (lambda ( rowitem ) (setq row (1+ row))
           (
             (lambda ( column )
               (mapcar
                 (function
                   (lambda ( item )
                     (vla-SetText tObj row
                       (setq column (1+ column)) item
                     )
                   )
                 )
                 rowitem
               )
             )
             (if preview 0 -1)
           )
         )
       )
       data
     )
   )
   0
 )
 
 (if (eq "" title)
   (vla-deleterows tObj 0 1)
   (vla-SetText tObj 0 0 title)
 )  
 (vla-put-RegenerateTableSuppressed tObj :vlax-false)
 
 tObj
)

(defun GetTableStyle ( Name )
 (if (setq Dict
       (Itemp
         (vla-get-Dictionaries
           (vla-get-ActiveDocument
             (vlax-get-acad-object)
           )
         )
         "ACAD_TABLESTYLE"
       )
     )
   (Itemp Dict Name)
 )
)

(defun GrMove ( obj prop msg cur / *error* gr data )

 (defun *error* ( msg )
   (and obj (not (vlax-erased-p obj)) (vla-delete obj))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )
 
 (if (vlax-property-available-p obj prop)
   (progn
     (princ msg)
     (while
       (and (= 5 (car (setq gr (grread t 13 cur))))
            (listp (setq data (cadr gr))))

       (vlax-put-property obj prop (vlax-3D-point data))
     )
     data
   )
 )
)

(defun TidyString ( str len )
 (if (> (strlen str) len)
   (strcat (substr str 1 (- len 3)) "...") str
 )
)

(defun PadRight ( str char len )
 (while (< (strlen str) len)
   (setq str (strcat str char))
 )
 str
)

(defun PadLeft ( str char len )
 (while (< (strlen str) len)
   (setq str (strcat char str))
 )
 str
)


(princ "\nø¤º°`°º¤ø  Count.lsp ~ Copyright © by Lee McDonnell  ø¤º°`°º¤ø")
(princ "\n   ~¤~          ...Type \"Count\" to Invoke...            ~¤~   ")
(princ)


;;;¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,;;;
;;                                                                               ;;
;;                             End of Program Code                               ;;
;;                                                                               ;;
;;;ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,¤º°`°º¤;;;

I figured out how to create more columns of what I need and name them what I want. Now the only problem is I need to edit the code to read attributes from dynamic blocks and put the info into the correct column. I know its simply doing the dataextraction command but that takes too long. I have attached a simple dwg TEST BOM.dwg if someone can help me (much appreciated) with a few dynamic blocks. Also, here is the code of my changes to add the columns in order (if that helps any?)

(defun c:BC ( / *error* mutter ss doc )
 ;; © Lee Mac  ~  05.06.10

 (defun *error* ( msg )
   (and mutter (setvar 'nomutt mutter))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )

 (or *title (setq *title "Block Data"))
 (or *prev  (setq *prev  "ON"))

 (setq mutter (getvar 'nomutt))
 (setvar 'nomutt 1)

 (princ "\nSelect Blocks to Count <All> : ")

 (cond (  (not (progn (setq ss (cond (  (ssget      '((0 . "INSERT"))))
                                     (  (ssget "_X" '((0 . "INSERT"))))))

                      (setvar 'nomutt mutter) ss))                  

          (princ "\n** No Blocks Found **")
       )
       (
         (_DisplayResult
           (mapcar
             (function
               (lambda ( x ) (list (car x) (itoa (cadr x))))
             )
             (
               (lambda ( / l n )
                 (vlax-for obj
                   (setq ss
                     (vla-get-ActiveSelectionSet
                       (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
                     )
                   )
                   (if (zerop (logand 45 (cdr (assoc 70 (tblsearch "BLOCK" (setq n (BlockName obj)))))))
                     (setq l (assoc++ n l))
                   )
                 )
                 l
               )
             )
           )
         )
       )
       (  (princ "\n** No Blocks Found **")  )
 )
 (princ)
)

(defun _DisplayResult ( lst / rLen )
 (if lst
   (progn
     (setq rLen
       (+ 3
         (apply (function max)
           (cons 5
             (mapcar (function strlen)
               (mapcar (function cadr) lst)
             )
           )
         )
       )
     )
     (mapcar
       (function
         (lambda ( item )
           (princ
             (strcat "\n"
               (PadRight (TidyString (car  item) 40) "."   40) "|"
               (PadLeft  (cadr item) "." rLen)
             )
           )
         )
       )
       (append
         (list '("ID" "MANUFACTURER" "PART NUMBER" "DESCRIPTION" "QUANTITY")
           (list (PadRight "" "-" 40) (PadLeft  "" "-" rLen))
         )
         (setq lst
           (vl-sort lst
             (function
               (lambda ( a b ) (< (car a) (car b)))
             )
           )
         )
         (list
           (list (PadRight "" "-" 40) (PadLeft "" "-" rLen))
         )
       )
     )

     (terpri)

     (if (> (atof (getvar 'ACADVER)) 16.)
       (progn
         (while
           (progn
             (initget "Yes No Settings")
             (setq choix (getkword "\nTable? [Yes/No/Settings] <Yes> : "))

             (cond (  (or (not choix) (eq "Yes" choix))
                    
                      (GrMove
                        (AddTable
                          (GetActiveSpace
                            (vla-get-ActiveDocument
                              (vlax-get-acad-object)
                            )
                          )
                          (getvar 'VIEWCTR) *title
                          (cons '("ID" "MANUFACTURER" "PART NUMBER" "DESCRIPTION" "QUANTITY") lst)
                          (eq "ON" *prev)
                        )
                        'InsertionPoint "\nPlace Table... " 0
                      )
                    nil
                   )
                   (  (eq "Settings" choix)

                      (while
                        (progn
                          (initget "Title Preview Exit")
                          (princ (strcat "\n<< Title: " (if (eq "" *title) "-None-" *title) ", Block Preview: " *prev " >>"))
                          (setq subchoix (getkword "\nEdit Settings [Title/Preview/Exit] <Exit> : "))

                          (cond (  (or (not subchoix) (eq "Exit" subchoix)) nil  )

                                (  (eq "Title" subchoix)

                                   (setq *title (getstring t "\nSpecify Table Title or <Enter> for None: "))
                                )
                                (t (initget "ON OFF")

                                   (setq *prev (cond ((getkword "\nBlock Preview Setting [ON/OFF] <ON> : ")) ("ON")))
                                )                         
                          )
                        )
                      )
                     t
                   )
                   (  (textscr)  )
             )
           )
         )
         t
       )
       (not (textscr))
     )          
   )
 )      
)

(defun assoc++ ( key lst )
 (
   (lambda ( pair )
     (cond
       ( pair
         (subst (list (car pair) (1+ (cadr pair))) pair lst)
       )
       ( (cons (list key 1) lst) )
     )
   )
   (assoc key lst)
 )
)

(defun Is64Bit nil
 (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
)

(defun BlockName ( obj )
 (vlax-get-property obj
   (if (vlax-property-available-p obj 'EffectiveName)
     'EffectiveName 'Name
   )
 )
)

(defun GetActiveSpace ( doc )
 (vlax-get-property doc
   (if (or (eq acModelSpace (vla-get-ActiveSpace doc))
           (eq :vlax-true   (vla-get-MSpace doc)))
     'ModelSpace 'PaperSpace
   )
 )
)

(defun GetObjectID ( obj doc )
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false)
   (itoa (vla-get-Objectid obj))
 )
)

(defun Itemp ( coll item )
 (if
   (not
     (vl-catch-all-error-p
       (setq item
         (vl-catch-all-apply
           (function vla-item) (list coll item)
         )
       )
     )
   )
   item
 )
)

(defun AddTable ( block pt title data preview / blks doc tObj tStyle )
 
 (setq tStyle (GetTableStyle (getvar 'CTABLESTYLE)))
 
 (vlax-put-property
   (setq tObj
     (vla-AddTable block
       (vlax-3D-point pt) (1+ (length data))
       (+ (if preview 1 0) (length (car data)))
       (* 1.8 (vla-getTextHeight tStyle acDataRow))
       (* 0.8
         (apply (function max)
           (mapcar (function strlen)
             (apply (function append) data)
           )
         )
         (vla-getTextHeight tStyle acDataRow)
       )
     )
   )
   'StyleName (getvar 'CTABLESTYLE)
 )  
 (vla-put-RegenerateTableSuppressed tObj :vlax-true)
 
 (setq blks
   (vla-get-blocks
     (setq doc
       (vla-get-ActiveDocument
         (vlax-get-acad-object)
       )
     )
   )
 )

 (if preview
   (progn
     (vla-SetText tObj 1 0 "Preview")
     (
       (lambda ( row )
         (mapcar
           (function
             (lambda ( block ) (setq row (1+ row))
               (vla-SetCellType tObj row 0 acBlockCell)
               (vla-SetBlockTableRecordId tObj row 0
                 (GetObjectID (Itemp blks block) doc) t
               )
             )
           )
           (mapcar (function car) (cdr data))
         )
       )
       1
     )
   )
 )

 (
   (lambda ( row )
     (mapcar
       (function
         (lambda ( rowitem ) (setq row (1+ row))
           (
             (lambda ( column )
               (mapcar
                 (function
                   (lambda ( item )
                     (vla-SetText tObj row
                       (setq column (1+ column)) item
                     )
                   )
                 )
                 rowitem
               )
             )
             (if preview 0 -1)
           )
         )
       )
       data
     )
   )
   0
 )
 
 (if (eq "" title)
   (vla-deleterows tObj 0 1)
   (vla-SetText tObj 0 0 title)
 )  
 (vla-put-RegenerateTableSuppressed tObj :vlax-false)
 
 tObj
)

(defun GetTableStyle ( Name )
 (if (setq Dict
       (Itemp
         (vla-get-Dictionaries
           (vla-get-ActiveDocument
             (vlax-get-acad-object)
           )
         )
         "ACAD_TABLESTYLE"
       )
     )
   (Itemp Dict Name)
 )
)

(defun GrMove ( obj prop msg cur / *error* gr data )

 (defun *error* ( msg )
   (and obj (not (vlax-erased-p obj)) (vla-delete obj))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )
 
 (if (vlax-property-available-p obj prop)
   (progn
     (princ msg)
     (while
       (and (= 5 (car (setq gr (grread t 13 cur))))
            (listp (setq data (cadr gr))))

       (vlax-put-property obj prop (vlax-3D-point data))
     )
     data
   )
 )
)

(defun TidyString ( str len )
 (if (> (strlen str) len)
   (strcat (substr str 1 (- len 3)) "...") str
 )
)

(defun PadRight ( str char len )
 (while (< (strlen str) len)
   (setq str (strcat str char))
 )
 str
)

(defun PadLeft ( str char len )
 (while (< (strlen str) len)
   (setq str (strcat char str))
 )
 str
)


(princ "\nø¤º°`°º¤ø  Count.lsp ~ Copyright © by Lee McDonnell  ø¤º°`°º¤ø")
(princ "\n   ~¤~          ...Type \"Count\" to Invoke...            ~¤~   ")
(princ)


;;;¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,;;;
;;                                                                               ;;
;;                             End of Program Code                               ;;
;;                                                                               ;;
;;;ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,¤º°`°º¤;;;

[Lee Mac]

That code looks to be a precursor to my Block Counter application.

[Grrr]

OMG Lee, I think doing such code in 2010 is far more than impressive!

You almost left no trace of your learning curve on the forums - I was able to find only like 2 threads from 2008-9's where you ask questions about something.

[H_Feather]

Lee,

is there a way to add more columns of what i need through the count settings?

[tzframpton]

The Data Extraction command only takes long to set up and get tuned precisely as you need. Once set up, create a Template with everything in place. Then, a simple Refresh is all that's necessary. Data Extraction can actually be very powerful if diligently set up, with well thought-out Blocks and Attributes.

 

-TZ

[Tharwat]

Hi H_Feather,

 

PM me if you want me to write a complete program for your request as described in this thread.

[Lee Mac]

Lee,

is there a way to add more columns of what i need through the count settings?

 

Not with the current version - please refer to my response to the email you posted through my site.

[H_Feather]

Tharwat,

I can not send a PM just yet because I don't have access yet? Something about a required amount of posts?

[Tharwat]

Tharwat,

I can not send a PM just yet because I don't have access yet? Something about a required amount of posts?

 

I already faced that issue before.

Just hit the link in my signature to contact me if you wish for.

[H_Feather]

Lee,

I haven't received anything yet in my email, checked both inbox and spam just in case.

[Lee Mac]

Lee,

I haven't received anything yet in my email, checked both inbox and spam just in case.

 

I have forwarded my earlier response to the email you provided; hopefully it will not be rejected by over-zealous spam filtering.

[BIGAL]

Just a thought on a 1 size fits all BOM table from block attributes. the block stores the attributes in a predefined order so you can step through all the attributes in a block 1 by 1. My idea is to ask the order that you want the attributes to appear in the table, eg 9 attributes want only 5 attributes in table so ask user and make a list of attribute order eg 1 2 7 8 3, as you know how many attributes you therefore know how many columns to create.

 

If you have a table already existing again make the order and add to the table.

 

I would use a dcl with a list of the block tag names to pick the order.

[Grrr]

Just hit the link in my signature to contact me if you wish for.

 

Nice website, I think you should start populating it with more programs / or more demos of your work.

[Tharwat]

Nice website, I think you should start populating it with more programs / or more demos of your work.

 

Thank you, it is too kind of you to say that.

 

Yeah, this is what I am planning to do from now on, although the demo part is the most difficult job to me since my MEP programs are somehow connected with each other and every demonstration video must explain every program in details.

 

Sorry OP for this OFF TOPIC reply.

[H_Feather]

Just a thought on a 1 size fits all BOM table from block attributes. the block stores the attributes in a predefined order so you can step through all the attributes in a block 1 by 1. My idea is to ask the order that you want the attributes to appear in the table, eg 9 attributes want only 5 attributes in table so ask user and make a list of attribute order eg 1 2 7 8 3, as you know how many attributes you therefore know how many columns to create.

 

If you have a table already existing again make the order and add to the table.

 

I would use a dcl with a list of the block tag names to pick the order.

 

That makes sense in my head now! Only problem is I do not know how to write lisp commands. I suppose after this I will have to research on writing and creating lisp for in the future.

[H_Feather]

I have forwarded my earlier response to the email you provided; hopefully it will not be rejected by over-zealous spam filtering.

 

I think the spam is zealous. I have looked in every email I have obtained just to make sure I didn't put in anther email address, still nothing.

[Lee Mac]

I think the spam is zealous. I have looked in every email I have obtained just to make sure I didn't put in anther email address, still nothing.

 

OK I'll PM you an email address when you hit 10 posts (silly forum limit).

[BIGAL]

A bit more of an idea on one size fits all, you may want to add blocks with different attributes but the attribute values need to go in different columns so pick att order and column order, also may have differing number of attributes but common attribute description.

 

1 1

3 4

5 3

etc