Тема: LISP. Подсчет блоков по значению атрибутов
Замечательная программулина, альтернатива автокадовскому "Извлечению атрибутов", позволяет несколькими кликами подсчитать в чертеже как просто одноименные блоки, так и одноименные блоки с различными значениями атрибутов. Вывод в текстовое окно AutoCAD или в файл txt.
Взято отсюда http://www.cadtutor.net/forum/attach... … 1272375444
Комментарии в программе на хранцузском языке.
Offtop: Знатоки хранцузского! Помогите перевести комменты!
;;;=================================================================
;;;
;;; LSTATT.LSP V4.01
;;;
;;; Dйcompte des blocs
;;;
;;; Copyright (C) Patrick_35
;;;
;;;=================================================================
(defun c:lstatt(/ choix i js ent fic fil lst n nb nm nombl InputBox liste_att rechercher_nom sel tbl trier txt)
(defun nombl(bl)
(if (vlax-property-available-p bl 'effectivename)
(vla-get-effectivename bl)
(vla-get-name bl)
)
)
(defun choix(/ bl js lst nom sel)
(princ "\nSйlectionnez le(s) bloc(s) а dйnombrer : ")
(and (ssget (list (cons 0 "ins ert")))
(progn
(vlax-for bl (setq sel (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
(or (member (setq nom (nombl bl)) lst)
(setq lst (cons nom lst))
)
(redraw (vlax-vla-object->ename bl) 4)
)
(foreach nom lst
(if js
(setq js (strcat js "," nom))
(setq js nom)
)
)
(vla-delete sel)
)
)
js
)
(defun InputBox (Titre js / ch dcl fil res tmp txt)
(setq tmp (vl-filename-mktemp "lstatt" nil ".dcl")
fil (open tmp "w")
fic "0"
)
(foreach txt '( "lstatt : dialog {"
" key = \"titre\";"
" alignment = centered;"
" is_cancel = true;"
" allow_accept = true;"
" width = 30;"
" : boxed_column {"
" label = \"Veuillez donner un nom de bloc ou * pour tous\";"
" : row {"
" : edit_box {key = \"filtre\";width = 45;}"
" : button {key = \"choix\"; label = \">>\";}"
" }"
" spacer;"
" }"
" : boxed_column {"
" label = \"Nombre d'attributs а prendre en compte\"; "
" : edit_box {key= \"att\";}"
" spacer;"
" }"
" spacer;"
" : toggle {key = \"fic\"; label = \"Ecrire les rйsultats dans un fichier\";}"
" spacer;"
" ok_cancel;"
"}"
)
(write-line txt fil)
)
(close fil)
(setq dcl (load_dialog tmp))
(while (not (member res '(0 1)))
(new_dialog "lstatt" dcl "")
(set_tile "titre" titre)
(set_tile "filtre" js)
(set_tile "att" nb)
(set_tile "fic" fic)
(action_tile "filtre" "(setq js $value)")
(action_tile "choix" "(done_dialog 2)")
(action_tile "att" "(setq nb $value)")
(action_tile "fic" "(setq fic $value)")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(setq res (start_dialog))
(and (eq res 2)
(setq ch (choix))
(setq js ch)
)
)
(unload_dialog dcl)
(vl-file-delete tmp)
(if (member res '(1 2))
js
""
)
)
(defun liste_att(att / n lst val)
(if (< (atoi nb) (length att))
(progn
(setq n 0)
(while (and (< n (atoi nb)) (setq val (nth n att)))
(setq lst (cons (vla-get-textstring (nth n att)) lst)
n (1+ n)
)
)
(reverse lst)
)
(mapcar 'vla-get-textstring att)
)
)
(defun rechercher_nom(val / att nom tbl)
(setq nom (nombl val))
(if (eq (vla-get-hasattributes val) :vlax-true)
(if (member (setq att (vlax-invoke val 'getattributes)) '(nil))
(list nom)
(cons nom (liste_att att))
)
(list nom)
)
)
(defun trier(a b / c n s)
(setq c 0)
(while (and (not s) (nth c a))
(if (eq (nth c a) (nth c b))
(setq c (1+ c))
(setq s T)
)
)
(or (nth c a) (setq c 0))
(< (strcase (nth c a)) (strcase (nth c b)))
)
(vl-load-com)
(or (setq nb (getenv "Patrick_35_nb_att"))
(setq nb "1")
)
(if (not (eq (setq nm (InputBox "Dйcompte de blocs V4.01" "*")) ""))
(progn
(setq js (strcat "`**," nm))
(if (ssget (list (cons 0 "INS ERT") (cons 2 js)))
(progn
(setenv "Patrick_35_nb_att" nb)
(vlax-map-collection (setq sel (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
'(lambda (x)
(if (wcmatch (strcase (car (setq js (rechercher_nom x)))) (strcase nm))
(if (eq (vla-get-objectname x) "AcDbMInsertBlock")
(repeat (* (vla-get-columns x) (vla-get-rows x))
(setq tbl (cons js tbl))
)
(setq tbl (cons js tbl))
)
)
)
)
(vla-delete sel)
(while tbl
(setq n (length tbl)
js (car tbl)
tbl (vl-remove js tbl)
lst (cons (cons (itoa (- n (length tbl))) js) lst)
)
)
(if lst
(progn
(and (eq fic "1")
(setq fil (open (setq txt (strcat (getvar "dwgprefix") (vl-filename-base (getvar "dwgname")) ".txt")) "w"))
)
(foreach n (vl-sort lst '(lambda (a b) (trier (cdr a) (cdr b))))
(if (eq fic "1")
(princ (strcat (car n) (chr 9) (cadr n)) fil)
(princ (strcat "\n"
(substr " " 1 (- 5 (strlen (car n))))
(car n)
" "
(cadr n)
)
)
)
(setq i 2)
(while (setq val (nth i n))
(if (eq fic "1")
(princ (strcat (chr 9) val) fil)
(princ (strcat "..." val))
)
(setq i (1+ i))
)
(and (eq fic "1")
(write-line "" fil)
)
)
(and (eq fic "1")
(princ (strcat "\nFichier \"" txt "\" crйй."))
(close fil)
)
)
(princ "\nPas de bloc а dйnombrer.")
)
)
)
)
)
(princ)
)
(se tq nom_lisp "LSTATT")
(if (/= app nil)
(if (= (strcase (substr app (1+ (- (strlen app) (strlen nom_lisp))) (strlen nom_lisp))) nom_lisp)
(princ (strcat "..." nom_lisp " chargй."))
(princ (strcat "\n" nom_lisp ".LSP Chargй.....Tapez " nom_lisp " pour l'йxecuter.")))
(princ (strcat "\n" nom_lisp ".LSP Chargй......Tapez " nom_lisp " pour l'йxecuter.")))
(se tq nom_lisp nil)
(princ)
