Attribute Extraction Lisp Routine_Help

[ml3428]

I came across the attached LISP routine that allows attribute information to be extracted into an excel document. Unfortunately this code searches the entire drawing for attributes, when I need only specific blocks to be selected. I am looking to modify the following code, so that it will prompt me for a selection window when extracting specific block attributes in a drawing. If anyone can help me with this I would appreciate, as I have no experience writing or modifying LISP.

 

Thank You

ATTOUT.LSP

[ReMark]

Global Attribute Extractor and Editor by Lee Mac. Extracts attributes to Excel.

 

http://lee-mac.com/macatt.html

[MSasu]

The code posted already had options for what you were looking for; just adjust the code as below:

 

1. To select the blocks you want to extract

   ;;    variations of the selection
   ;;  All blocks :
[color=red];;;[/color]        (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 66 1))))
   ;;    Selected on screen:
[color=blue](setq ss (ssget '((0 . "INSERT"))))[/color]
   ;; All blocks by name:
;;;    (setq bname (getstring "\n    ***    Block name:\n"))
;;;    (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 66 1) (cons 2 bname))))

2. To indicate blocks to extract by their name:

    ;;    variations of the selection
   ;;  All blocks :
[color=red];;;[/color]        (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 66 1))))
   ;;    Selected on screen:
;;;(setq ss (ssget '((0 . "INSERT"))))
   ;; All blocks by name:
[color=blue]    (setq bname (getstring "\n    ***    Block name:\n"))
   (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 66 1) (cons 2 bname))))[/color]

[ml3428]

MSasu

 

Thanks for the help!!, the first code you posted solved the problem for me.

[MSasu]

Glad to hear that you got this solved!

[ml3428]

In addition to extracting attribute information to an excel table, I am also looking for a similar way to generate a BOM table to insert into AutoCAD. If anyone has used or knows of a LISP to accomplish this I would greatly appreciate it.

 

Thank You

[ml3428]

Mircea,

 

I have one more request in looking to revise this code. Right now a column is being created that lists the "handle" of the bolck attribute. I would like to revise the code so that this column will not display, but keep all other tags assoicated with the routine. Hopefully this is an easy fix. I attached the revised LISP for you to look at.

 

(setq header_list

'("HANDLE" Not Needed

"BLOCK NAME"

"SECTION NO"

"FAMILY"

"DESCRIPTION"

"PN"

 

 

Thank You

ATTOUT.LSP

[BIGAL]

Msasu a suggestion rather than "getstring block name" use a pick block and return block name nothing worse than 11 finger typing.

 

(setq en1 (car (entsel "\nSelect Block:" )))
       (setq el1 (entget en1))
       (setq BLKname (cdr (assoc 2 el1)))

[MSasu]

Bigal, that code is from OP’s routine; the alternative input methods were already there and commented out. I just showed him/her how to adjust it to work as expected. For sure your solution is much flexible than the one form original code.

[MSasu]

Please find below the adjusted code to get rid of the handle column from the report:

[color=magenta]...[/color]
(setq header_list
      '([color=red];[/color][color=dimgray]"HANDLE"[/color]
        "BLOCK NAME"
        "SECTION NO"
        "FAMILY"
        "DESCRIPTION"
        "PN"
       )
) ;_ end of setq
[color=magenta]...[/color]
(setq row 2
     colm 1
)
(repeat (length exc_data)
 (setq data   [color=red](cdr[/color] (reverse (cdr (reverse (car exc_data))))[color=red])[/color]
       subtot (last (car exc_data))
 )
[color=magenta]...[/color]

Also, there was a very ineffective solution to indicate the destination file - have changed that too.

(setq fn (vl-filename-base (getvar "dwgname")))
(setq fname (strcat (getvar "dwgprefix") fn ".xls"))

(setq [color=red]fx[/color] (open fname "W"))
(close [color=red]fx[/color])
[color=red];;;[/color][color=dimgray](alert (strcat "Select file " "\"" (strcat fn ".xls") "\""))[/color]
[color=red];;;[/color][color=dimgray](setq fname (getfiled "Excel Spreadsheet File" "" "XLS" )[/color]
[color=red];;;[/color][color=dimgray](setq fname (findfile fname))[/color]

There is another pending improvment, regarding the saving of the file; if will have time later will try to fix that too.

[ml3428]

Mircea,

 

Thank You again for the help. However, when I try to run this code it eliminates the handle column, but no longer extracts the attributes for the other columns. I am unsure if it is an error on my part, but I have tried modifying the code several times with the same result.

 

Thanks

[MSasu]

Can you post please the modified code? Thank you.

[ml3428]

Here is the modified code. I am sure it is an error on my part, and truly do appreciate all the help with this!!

 

Thank You

ATTOUT(REVISED).LSP

[MSasu]

Please check if this is what you were looking for:

;;  Groups elements in sublist by criteria
(defun subtrack (test lst)
(apply 'append (mapcar '(lambda (x)
(if (eq (car x) test)(list x))) lst)))
;;  Counts equivalent subs in list
(defun countsub (lst sub)
 (cond ((null lst) 0)
((and (equal (caar lst) (car sub) 0.00001)
      (equal (cadar lst) (cadr sub) 0.00001)
 )
 (1+ (countsub (cdr lst) sub))
)
(T (countsub (cdr lst) sub))
 )
)
;;  Get info from block include from constant attributes in following form:
;; (("TAG1" . "VALUE1") ("TAG2" . "VALUE2") ...("*CONSTANT*: TAGN" . "VALUEN"))
 (defun get-all-atts (obj / atts att_list const_atts const_list ent)
   (and
 (if (and obj 
   (vlax-property-available-p obj 'Hasattributes)
   (eq :vlax-true (vla-get-hasattributes obj))
     )
   (progn
     (setq atts (vlax-invoke obj 'Getattributes))
     (foreach att atts
       (setq att_list
       (cons (cons (vla-get-tagstring att)
     (vla-get-textstring att)
      )
      att_list
       )
       )
     )
   )
 )
   )
   (cond ((vlax-method-applicable-p obj 'Getconstantattributes)
   (setq const_atts (vlax-invoke obj 'Getconstantattributes))
   (foreach att const_atts
     (setq const_list
     (cons (cons (vla-get-tagstring att)
   (vla-get-textstring att)
    )
    const_list
     )
     )
   )
   (setq att_list (reverse (append const_list att_list)))
  )
  (T (reverse att_list))
   )
 )
;;   Main part   ;;
 (defun C:ATOUT (/  acsp   adoc    aexc     awb      axss
 bname  cll   colm    com_data csht     data
 exc_data fname   header_list     info     nwb
 osm  row   sht    ss     str1     str2
 subtot  tmp_data tmp_get  tmp_snip tot      fx
       )
   (vl-load-com)
   (setq adoc (vla-get-activedocument
  (vlax-get-acad-object)
       )
  acsp (vla-get-modelspace adoc)
   )
   (setq osm (getvar "osmode"))
   (setvar "osmode" 0)
   (setvar "cmdecho" 0)
   (vla-endundomark adoc)
   (vla-startundomark adoc)
   (vl-cmdf "zoom" "a")
   (vl-cmdf "zoom" ".85x")
      ;;    variations of the selection
   ;;  All blocks :
;;;        (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 66 1))))
   ;;    Selected on screen:
(setq ss (ssget '((0 . "INSERT"))))
   ;; All blocks by name:
;;;    (setq bname (getstring "\n    ***    Block name:\n"))
;;;    (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 66 1) (cons 2 bname))))
   ;; All blocks by name:
;;;    (setq bname (getstring "\n *** Block name:\n"))
;;;    (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 66 1) (cons 2 bname))))
   (setq axss (vla-get-activeselectionset adoc))
   (setq com_data nil)      ;for debug only
   (vlax-for a axss
     (setq tmp_get (get-all-atts a))
     (setq tmp_data (append (list (vla-get-name a)(vla-get-handle a)) tmp_get))
     (setq com_data (cons tmp_data com_data))
     (setq tmp_data nil)
   )        ;ok
   (setq tot (length com_data))
   (setq exc_data nil)      ;for debug only
   (while com_data
     (setq tmp_snip
     (subtrack (caar com_data) com_data)
     )
     (setq str1 (strcat "Subtotal blocks "
   "\"" (caar com_data) "\""
                        ": "
  )
    str2
  (itoa (length tmp_snip))
     )
     (setq exc_data (append exc_data
       (list (append tmp_snip (list (list str2 str1))))
      )
    com_data (vl-remove-if
        (function not)
        (mapcar (function (lambda (x)
       (if (not (member x tmp_snip))
         x
       )
     )
         )
         com_data
        )
      )
    tmp_snip nil
     )
   )
   (setq exc_data
          (mapcar (function (lambda (x)
              (mapcar (function (lambda (y)                
                  (append (list (cadr y)(car y))(cddr y))))
                      x
                      )
                              )
                            )
                  exc_data)
                  )
   ;;  Eof calc part  ;;
   ;; *** Excel part *** ;;
   (setq fn (vl-filename-base (getvar "dwgname")))
   (setq fname (strcat (getvar "dwgprefix") fn ".xls"))
   
   (setq fx (open fname "W"))
   (close fx)
   ;;; Excel part written by  ALEJANDRO LEGUIZAMON -  [url]http://arquingen.tripod.com.co[/url]  
   (setq aexc (vlax-get-or-create-object "Excel.Application")
  awb  (vlax-get-property aexc "Workbooks")
  nwb  (vlax-invoke-method awb "Open" fname)
  sht  (vlax-get-property nwb "Sheets")
  csht (vlax-get-property sht "Item" 1)
  cll  (vlax-get-property csht "Cells")
   )
   (vlax-put-property csht 'Name "AttOut-AttIn")
   (vla-put-visible aexc :vlax-true)
   (setq row 1
  colm 1
   )
   (setq header_list
          '("BLOCK NAME"
            "SECTION NO"
            "FAMILY"
            "DESCRIPTION"
            "PN"
           
           )
   ) ;_ end of setq
   (repeat (length header_list)
     (vlax-put-property
cll
"Item"
row
colm
(vl-princ-to-string (car header_list))
     )
     (setq colm (1+ colm)
    header_list
     (cdr header_list)
     )
   )
   (setq row 2
  colm 1
   )
   (repeat (length exc_data)
     (setq data   (reverse (cdr (reverse (car exc_data))))
    subtot (last (car exc_data))
     )
     (repeat (length data)
       (setq info (cdr (car data)))
(repeat (length info)
  (vlax-put-property
    cll
    "Item"
    row
    colm
           (if (< colm 2)
     (vl-princ-to-string (car info))
            (vl-princ-to-string (cdar info)))
  )
  (setq colm (1+ colm))
  (setq info (cdr info))
)
       (setq data (cdr data))
(setq row  (1+ row)
      colm 1
)
     )
    
     
     (setq colm (1+ colm))
     (vlax-put-property
cll
"Item"
row
colm

     )
     (setq exc_data (cdr exc_data))
     (setq row  (1+ row)
    colm 1
     )
   )
   (setq row  (1+ row)
  colm 1
   )
   
   (setq colm (1+ colm))
   (vlax-put-property
     cll
     "Item"
     row
     colm
     
   )
  (setq fcol (vlax-get-property csht "Range" "A:Z"))
  (vlax-put-property fcol "NumberFormat" "@")
;;;        Columns("A:A").Select
;;;    Range("A394").Activate
;;;    Selection.NumberFormat = "@"
   (vlax-invoke (vlax-get-property csht "Columns") "AutoFit")
   (vlax-release-object cll)
   (vlax-release-object fcol)
   (vlax-release-object csht)
   (vlax-release-object sht)
   (vlax-release-object nwb)
   (vlax-release-object awb)
   (vlax-release-object aexc)
   (setq aexc nil)
   (setvar "osmode" osm)
   (setvar "cmdecho" 1)
   (vla-clear axss)
   (vlax-release-object axss)
   (vla-regen adoc acactiveviewport)
   (vla-endundomark adoc)
   (gc)
   (gc)
   (alert "Save Excel manually")
   (princ)
   )
(princ "\n\t\t***\tStart command with ATOUT...\t***")
(princ)

If not, then please post here the block you are using to allow a deeper investigation of the code.

[ml3428]

Thank You!!! This is exactly what I was looking for. You have been a great help. I really appreciate all the work you have done!!!

[MSasu]

You are entirely welcome! Glad I was able to help you.

[giacomellino]

Hi, I tried to download the code you made but it doesn't say it's not available.

[BIGAL]

Did you copy the code and then open Notepad and paste, then save.