Plant Codigos Bondi

;;; PLANT-LIST.LSP - Extracts plant quantities ;;; from the current drawing. The plant blocks ;;; are named "key-plant", and the attributes are ;;; "planttype" and "quantity". Code by Tony Hotchkiss ;;; ******************************************************* ;;; * Version 5/10/2006 * ;;; ******************************************************* (defun err (s) (if (= s "Function cancelled") (princ (strcat "\nPLANT-LIST cancelled - " "thank you for using PLANT-LIST" ) ;_ end of strcat ) ;_ end of princ (progn (princ "\nPLANT-LIST Error: ") (princ s) (terpri) ) ;_ end of progn ) ;_ end of if (resetting) (princ) ) ;_ end of err (defun setv (systvar newval / x) (setq x (read (strcat systvar "1"))) (set x (getvar systvar)) (setvar systvar newval) ) ;_ end of setv (defun setting () (setq oerr *error*) (setq *error* err) (setv "CMDECHO" 0) (setv "OSMODE" 0) ) ;_ end of setting (defun rsetv (systvar / x) (setq x (read (strcat systvar "1"))) (setvar systvar (eval x)) ) ;_ end of defun (defun resetting () (rsetv "CMDECHO") (rsetv "OSMODE") (setq *error* oerr) ) ;_ end of resetting (defun plant-list (/ fname f1 ssets ssetcount ssobj j KeyPlantList TypeQuantityList item i attribs sarr num attrefobj tag val ptype quan ) ;_ end of / (vl-load-com) (setq *thisdrawing* (vla-get-activedocument

(vlax-get-acad-object) ) ;_ end of vla-get-activedocument *modelspace* (vla-get-ModelSpace *thisdrawing*) ) ;_ end of setq (setq fname (getfiled "Results file" "" "txt" 1)) (setq f1 (open fname "w")) (write-line "PLANT-TYPE QUANTITY" f1) (setq ssets (vla-get-selectionsets *thisdrawing*) ssetcount (vla-get-count ssets) ) ;_ end of setq (if (> ssetcount 0) (repeat ssetcount (vla-delete (vla-item ssets 0)) ) ;_ end of repeat ) ;_ end of if (setq ssobj (vla-add ssets "selection1")) (vla-select ssobj acSelectionSetAll) (setq j (- 1)) (setq KeyPlantList nil) (setq TypeQuantityList nil) (repeat (vla-get-count ssobj) (setq item (vla-item ssobj (setq j (1+ j)))) (if (and (= (vla-get-ObjectName item) "AcDbBlockReference" ) ;_ end of = (= (vla-get-HasAttributes item) :vlax-true) (= (vla-get-Name item) "KEY-PLANT") ) ;_ end of and (progn (setq i (- 1)) (setq attribs (vla-getAttributes item)) (setq sarr (vlax-variant-value attribs)) (setq num (vlax-safearray-get-u-bound sarr 1)) (repeat (1+ num) (setq attrefobj (vlax-safearray-get-element sarr (setq i (1+ i))) ) ;_ end of setq (setq tag (vla-get-TagString attrefobj)) (setq val (vla-get-TextString attrefobj)) (if (= tag "PLANTTYPE") (setq ptype val) ) ;_ end of if (if (= tag "QUANTITY") (setq quan val) ) ;_ end of if (if (and ptype quan (= i 1)) (setq TypeQuantityList

(append TypeQuantityList (list (cons ptype (list quan)))) ) ;_ end of setq ) ;_ end of if ) ;_ end of repeat ) ;_ end of progn ) ;_ end of if ) ;_ end of repeat (setq KeyPlantList (do-totals TypeQuantityList)) (print-out KeyPlantList f1) (setq f1 (close f1)) ) ;_ end of plant-list (defun do-totals (TypeQuantityList / SortedList number keylist keyplist element1 ptype1 number1 element2 ptype2 number2 check ) ;_ end of TypeQuantityList (setq SortedList (vl-sort TypeQuantityList (function (lambda (e1 e2) (< (car e1) (car e2)) ) ;_ end of lambda ) ;_ end of function ) ;_ end of vl-sort ) ;_ end of setq (setq number 0 keylist nil keyplist nil ) ;_ end of setq (setq element1 (nth 0 SortedList) ptype1 (car element1) number1 (atoi (cadr element1)) ) ;_ end of setq (repeat (- (length SortedList) 1) (setq element2 (nth 1 SortedList) ptype2 (car element2) number2 (atoi (cadr element2)) ) ;_ end of setq (if (= ptype2 ptype1) (progn (setq number (+ number1 number2)) (setq number1 number) (setq check 0) ) ;_ end of progn (progn (setq number number1) (setq ptype ptype1) (setq keylist (list (cons ptype (list number)))) (setq element1 element2 ptype1 (car element1)

number1 (atoi (cadr element1)) ) ;_ end of setq (setq keyplist (append keyplist keylist)); asigna a keyplist tomar cualquier número de listas de keyplist (setq check nil); asigna el valor de nil a la variable check ) ;_ end of prong; fin de a función prong ) ;_ end of if; fin de la función if (setq SortedList (cdr SortedList)); asigna a SortedList el primer elemento de SortedList ) ;_ end of repeat; fin de la function repeat (if (= check 0); evalua con la condicion de que check sea igual a cero (prong; Evalúa cada expresión secuencialmente y devuelve el valor de la última expresión (setq keylist (list (cons ptype2 (list number1))); almacena en keylist una lista que se forma a partir de la lista number1 agregándole ptype2 como primer elemento keyplist (append keyplist keylist); )); asigna a keyplist tomar cualquier número de listas de keyplist ) ;_ end of setq; fin de la función setq ) ;_ end of prong; fin de la función prong (prong; Evalúa cada expresión secuencialmente y devuelve el valor de la última expresión (setq keylist (list (cons (caar SortedList); asigna a keylist una lista formada a partir de otra lista y la anexion del primer elemento de SortedList, como su primer elemento (list (atoi (cadar SortedList))); forma una lista de valores reales ) ;_ end of cons; fin de la función cons ) ;_ end of list; fin de la función list ) ;_ end of setq; fin de la función setq (setq keyplist (append keyplist keylist)); asigna a keyplist tomar cualquier número de listas de keyplist ) ;_ end of prong; fin de la función prong ) ;_ end of if; fin de la función if keyplist ) ;_ end of do-totals; fin de la función do-totals (defun print-out (KList f1 / str); define una nueva función con dos variablesglobales y una local (repeat (length KList); (setq; asigna a una variable un valor dado. str (strcat " "; asigna a la variable str la concatenación de un espacio.. (caar KList); …las cadenas de caar Klist… " "; ..espacio.. (itoa (cadar KList));… y la cadena formada por el primer elemento de Klist ) ;_ end of strcat; fin de la función strcat ) ;_ end of setq; fin de la función setq (write-line str f1); escribe la cadena str en la pantalla (setq KList (cdr KList)); asigna a Klist los elemntos de Klist pero omitiendo el primer elemento

) ;_ end of repeat; fin de la función repeat ) ;_ end of print-out; fin de la función print-out (defun c:pl (); define un nuevo comando sin ninguna variable (setting); llama a la función setting (plant-list); llama a la función plant-list (resetting); llama a la función resetting (princ); Imprime una expresión de la línea de comandos ) ;_ end of c:at2; fin del commando at2 (prompt (strcat "\nPlant-list Copyright (c) "; Muestra en la pantalla como una sola expresion el mensaje descrito "2006 Dr. A Hotchkiss."; parte del mensaje descrito ) ;_ end of strcat; fin de la función strcat ) ;_ end of prompt; fin de la función promt (prompt "\nEnter PL to start."); muestra en la pantalla el mensaje descrito (princ); Imprime una expresión de la línea de comandos