LISP. Подсчет блоков по значению атрибутов

Nike · 19.07.2010, 11:29

Замечательная программулина, альтернатива автокадовскому "Извлечению атрибутов", позволяет несколькими кликами подсчитать в чертеже как просто одноименные блоки, так и одноименные блоки с различными значениями атрибутов

Вывод в текстовое окно AutoCAD или в файл txt.
Взято отсюда http://www.cadtutor.net/forum/attach...3&d=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 "insert")))
      (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 "INSERT") (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)
)
 
(setq 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.")))
(setq nom_lisp nil)
(princ)

VVA · 19.07.2010, 12:08

Вся библиотека программ от Patric_35

shmulka · 06.09.2013, 12:26

Господа хорошие, а может кто перевел хоть на английский?

VVA · 09.09.2013, 13:39

Цитата:

Сообщение от shmulka

Господа хорошие, а может кто перевел хоть на английский?

tnaslate.google.com перевел

Код:

[Выделить все]

;;;=================================================================
;;;
;;; LSTATT.LSP V4.01e
;;;
;;; Count blocks
;;; Décompte des blocs
;;;
;;; Copyright (C) Patrick_35
;;;
;;; Posted http://forum.dwg.ru/showthread.php?t=54936
;;;=================================================================
 
(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 "\nSelect(s) block(s) to count : ")
    (and (ssget (list (cons 0 "insert")))
      (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 = \"Please give a block name or * for all\";"
            "    : row {"
            "      : edit_box {key = \"filtre\";width = 45;}"
            "      : button {key = \"choix\"; label = \">>\";}"
            "    }"
            "    spacer;"
            "  }"
            "  : boxed_column {"
            "    label = \"Number of attributes to be considered\"; "
            "    : edit_box {key= \"att\";}"
            "    spacer;"
            "  }"
            "  spacer;"
            "  : toggle {key = \"fic\"; label = \"Write the output to a file\";}"
            "  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 "Count of blocks V4.01e" "*")) ""))
    (progn
      (setq js (strcat "`**," nm))
      (if (ssget (list (cons 0 "INSERT") (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 "\nFile \"" txt "\" created."))
        (close fil)
          )
        )
        (princ "\nNo block count.")
      )
    )
      )
    )
  )
  (princ)
)
 
(setq 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 " responsible."))
    (princ (strcat "\n" nom_lisp ".LSP Loaded ..... Type " nom_lisp " to execute it.")))
  (princ (strcat "\n" nom_lisp ".LSP Loaded ..... Type " nom_lisp " to execute it.")))
(setq nom_lisp nil)
(princ)

Важное замечание!
На запрос "Number of attributes to be considered" необходимо ввести порядковый номер требуемого атрибута в описании блока!

gomer · 28.09.2014, 15:48

Русская версия:

Код:

[Выделить все]

 ;;;
;;; LSTATT.LSP V4.01
;;;
;;; Dйcompte des blocs
;;;
;;; Copyright (C) Patrick_35
;;;
;;; ~*~*~*~*~*~*~*~*~*~*~*~*~*~ TRANSLATED by gomer *~*~*~*~*~*~*~*~*~*~*~*~*~*~

(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 "\nУкажите блоки для перечисления: ")
    (and (ssget (list (cons 0 "insert")))
      (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 = \"Имена блоков или * для подсчета всех блоков\";"
                        "    : row {"
                        "      : edit_box {key = \"filtre\";width = 45;}"
                        "      : button {key = \"choix\"; label = \">>\";}"
                        "    }"
                        "    spacer;"
                        "  }"
                        "  : boxed_column {"
                        "    : edit_box {key = \"att\";"
                        "                label = \"Порядковый номер атрибута\";"
                        "                edit_width = 6;}"
                        "    spacer;"
                        "  }"
                        "  spacer;"
                        "  : toggle {key = \"fic\"; label = \"Запись в файл\";}"
                        "  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 "Подсчет блоков V4.01" "*")) ""))
    (progn
      (setq js (strcat "`**," nm))
      (if (ssget (list (cons 0 "INSERT") (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 txt (strcat (getvar "dwgprefix")
                                     (vl-filename-base (getvar "dwgname"))
                                     ".txt"))
                   (setq fil (open 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 "\nФайл \"" txt "\" создан."))
                (close fil)
              )
            )
            (princ "\nНе найдены блоки для подсчета.")
          )
        )
      )
    )
  )
  (princ)
)

Nike · 21.09.2016, 11:11

Версия 4.21

Код:

[Выделить все]

 ;;;=================================================================
;;;
;;; LSTATT.LSP V4.21
;;;
;;; Dйcompte des blocs
;;;
;;; Copyright (C) Patrick_35
;;;
;;;=================================================================

(defun c:lstatt(/ choix doc i js ent fic fil lab lst mrc trc n nb nm nombl InputBox liste_att mrech rechercher_nom s sel tbl trier txt *errlst*)

  (defun *errlst* (msg)
    (or (member (strcase msg) '("FUNCTION CANCELLED" ""QUIT / EXIT ABORT"" "FONCTION ANNULEE" "QUITTER / SORTIR ABANDON"))
      (princ (strcat "\nErreur : " msg))
    )
    (setq *error* s)
    (princ)
  )

  (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 "insert")))
      (progn
	(vlax-for bl (setq sel (vla-get-activeselectionset doc))
	  (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")
    )
    (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\";}"
			"  : toggle {key = \"lab\"; label = \"Ajouter le nom des йtiquettes dans les rйsultats\";}"
			"  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)
      (set_tile "lab" lab)
      (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 "lab"    "(setq lab $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 (if (eq lab "0")
			    (vla-get-textstring (nth n att))
			    (strcat (vla-get-tagstring (nth n att)) ":" (vla-get-textstring (nth n att)))
			  )
			  lst
		    )
		n (1+ n)
	  )
	)
	(reverse lst)
      )
      (if (eq lab "0")
        (mapcar 'vla-get-textstring att)
	(mapcar '(lambda(x)(strcat (vla-get-tagstring x) ":" (vla-get-textstring x))) 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)))
  )

  (defun mrech(bl / ent lst recu)
    (defun recu(bl)
      (vlax-for ent (vla-item (vla-get-blocks doc) (nombl bl))
	(and (eq (vla-get-objectname ent) "AcDbBlockReference")
	  (if (eq (substr (nombl ent) 1 1) "*")
	    (recu ent)
	    (setq lst (cons ent lst))
	  )
	)
      )
    )
    (and (eq (substr (nombl bl) 1 1) "*")
      (recu bl)
    )
    lst
  )

  (vl-load-com)
  (setq s *error*
	*error* *errlst*
	doc (vla-get-activedocument (vlax-get-acad-object))
  )
  (or (setq nb (getenv "Patrick_35_nb_att"))
    (setq nb "1")
  )
  (or (setq lab (getenv "Patrick_35_nb_lab"))
    (setq lab "0")
  )
  (setq fic "0")
  (if (not (eq (setq nm (InputBox "Dйcompte de blocs V4.21" "*")) ""))
    (progn
      (setq js (strcat "`**," nm))
      (if (ssget (list (cons 0 "INSERT") (cons 2 js)))
	(progn
	  (setenv "Patrick_35_nb_att" nb)
	  (setenv "Patrick_35_nb_lab" lab)
	  (vlax-map-collection	(setq sel (vla-get-activeselectionset doc))
				'(lambda (x)
				  (if (setq trc (mrech x))
				    (foreach mrc trc
				      (if (wcmatch (strcase (car (setq js (rechercher_nom mrc)))) (strcase nm))
					(setq tbl (cons js tbl))
				      )
				    )
				    (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.")
	  )
	)
      )
    )
  )
  (setq *error* s)
  (princ)
)

(setq 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.")))
(setq nom_lisp nil)
(princ)

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Массовое редактирование свойств атрибутов блоков	kgb	Программирование	10	11.10.2019 15:57
Выбор блоков по значению атрибутов.	Sleekka	Программирование	69	21.09.2019 15:30
LISP. Очистка рисунка от "пустых" блоков	Makswell	Готовые программы	12	10.09.2015 14:31
Подсчет и сортировка блоков на текущем слое. Помогите отредактировать.	Kortes	Программирование	17	26.03.2010 18:46
LISP. Разбивка атрибутов блока в блоке	Apelsinov	LISP	2	23.09.2009 20:47

Опции темы	Поиск в этой теме
	Поиск в этой теме: Расширенный поиск