Message 1 of 7
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
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)
Solved! Go to Solution.
