Jump to content
ml3428

Attribute Extraction Lisp Routine_Help

Recommended Posts

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

Share this post


Link to post
Share on other sites
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]

Share this post


Link to post
Share on other sites
ml3428

MSasu

 

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

Share this post


Link to post
Share on other sites
MSasu

Glad to hear that you got this solved!

Share this post


Link to post
Share on other sites
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

Share this post


Link to post
Share on other sites
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

Share this post


Link to post
Share on other sites
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)))

Share this post


Link to post
Share on other sites
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.

Share this post


Link to post
Share on other sites
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.

Share this post


Link to post
Share on other sites
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

Share this post


Link to post
Share on other sites
MSasu

Can you post please the modified code? Thank you.

Share this post


Link to post
Share on other sites
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

Share this post


Link to post
Share on other sites
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.

Share this post


Link to post
Share on other sites
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!!!

Share this post


Link to post
Share on other sites
MSasu

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

Share this post


Link to post
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
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  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...