topic Re: ATTOUT help in Visual LISP, AutoLISP and General Customization Forum

ATTOUT help

3arizona — Mon, 15 Jul 2019 21:28:27 GMT

I'v modified this routine to fit my needs and as always i got stuck at filtering a specific block. I want the lisp to filter a specific block name "TEST1". at the moment it's selecting all blocks withing a window. also is there a way to change the path to open the excel file location? at the moment the default is to my document but i want it to default to a folder on my desktop "Desktop\DATA TEST\JUNK".

Thank you

;;  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
	       )

    (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)

    ;;    variations of the selection
    ;;  All blocks :
        (setq ss (ssget (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))))
    (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 fname (open fname "W"))
    (close fname)
    (alert (strcat "Select file " "\"" (strcat fn ".xls") "\""))
    (setq fname (getfiled "Excel Spreadsheet File" "" "XLS" 8))
    (setq fname (findfile fname))
    ;;; Excel part written by  ALEJANDRO LEGUIZAMON -  http://arquingen.tripod.com.co  
    (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
           '("HANDLE"
             "BLOCK NAME"
             "TAG1"
             "TAG2"
             "TAG3"
             "TAG4"
             "TAG5"
             "TAG6"
             "TAG7"
             "TAG8"
             "TAG9"
             "TAG10"
            )
    ) ;_ 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 (car data))
	(repeat	(length info)
	  (vlax-put-property
	    cll
	    "Item"
	    row
	    colm
            (if (< colm 3)
	    (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
	)
      )

      (vlax-put-property
	cll
	"Item"
	row
	colm
	(vl-princ-to-string (car subtot))
      )
      (setq colm (1+ colm))
      (vlax-put-property
	cll
	"Item"
	row
	colm
	(vl-princ-to-string (cadr subtot))
      )

      (setq exc_data (cdr exc_data))
      (setq row	 (1+ row)
	    colm 1
      )
    )

    (setq row  (1+ row)
	  colm 1
    )
    (vlax-put-property
      cll
      "Item"
      row
      colm
      (vl-princ-to-string "TOTAL BLOCKS:")
    )
    (setq colm (1+ colm))
    (vlax-put-property
      cll
      "Item"
      row
      colm
      (vl-princ-to-string tot)
    )
   (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)

Re: ATTOUT help

Anonymous — Tue, 16 Jul 2019 00:15:05 GMT

I do not know if I understand correctly,

but here you change your selection set

(vla-startundomark adoc)

   (setq ss (ssget '((0 . "INSERT")(2 . "TEST1")))) ;;<<-here

    (setq axss (vla-get-activeselectionset adoc))

And here you can choose the directory of your file.

(setq fn (vl-filename-base ;|(getvar "dwgname")|;  "c:\\Desktop\DATA TEST\JUNK" )) ;;<<-here 
    (setq fname (strcat (getvar "dwgprefix") fn ".xls"))

Re: ATTOUT help

dbhunia — Tue, 16 Jul 2019 05:10:20 GMT

@3arizona wrote:
I'v modified this routine to fit my needs and as always i got stuck at filtering a specific block. I want the lisp to filter a specific block name "TEST1". at the moment it's selecting all blocks withing a window. also is there a way to change the path to open the excel file location? at the moment the default is to my document but i want it to default to a folder on my desktop "Desktop\DATA TEST\JUNK".

1. For First part, Specific Block selection go as per @Anonymous .
2. For Second Part I think you can try with this changes.
.......
    ;;	***	Excel part	***	;;
    (setq fn (vl-filename-base (getvar "dwgname")))
    ;(setq fname (strcat (getvar "dwgprefix") fn ".xls"))
    (setq fname (strcat "C:/Users/XXXXXXX/Desktop/DATA/TEST/JUNK/" fn ".xls")); Put the Path of Destination Folder for *.xls File
    (setq fname (open fname "W"))
    (close fname)
    (alert (strcat "Select file " "\"" (strcat fn ".xls") "\""))
    (setq fname (getfiled "Excel Spreadsheet File" "C:/Users/XXXXXXX/Desktop/DATA/TEST/JUNK/" "XLS" 8)); Put the Path of that Folder containing that *.xls File
    ;(setq fname (findfile fname))
    ;;; Excel part written by  ALEJANDRO LEGUIZAMON -  http://arquingen.tripod.com.co  
.......

Re: ATTOUT help

3arizona — Tue, 16 Jul 2019 17:35:28 GMT

dbhunia

is there a way change the path for other USERS (xxxxxx)?

C:/Users/other users/Desktop/DATA TEST/JUNK/"

Re: ATTOUT help

3arizona — Tue, 16 Jul 2019 17:39:26 GMT

Block selection part works perfect!!!

Re: ATTOUT help

dbhunia — Wed, 17 Jul 2019 05:26:05 GMT

@3arizona wrote:
dbhunia
is there a way change the path for other USERS (xxxxxx)?
C:/Users/other users/Desktop/DATA TEST/JUNK/"

Try with this...

............
    ;;	***	Excel part	***	;;
    (setq fn (vl-filename-base (getvar "dwgname")))
    (setq path (strcat "C:/Users/" (getenv "UserName") "/Desktop/DATA TEST/JUNK/"))
    (setq fname (strcat path fn ".xls"))
    (setq fname (open fname "W"))
    (close fname)
    (alert (strcat "Select file " "\"" (strcat fn ".xls") "\""))
    (setq fname (getfiled "Excel Spreadsheet File" path "XLS" 8))
    ;;; Excel part written by  ALEJANDRO LEGUIZAMON -  http://arquingen.tripod.com.co  
............

Re: ATTOUT help

3arizona — Wed, 17 Jul 2019 21:58:48 GMT

Works, thanks!!