Аналог Dataextraction на лисп (экспорт данных из атрибутов динамических блоков в таблицу, подсчет количества и т.п.)

Red Nova · 21.09.2016, 04:32

Доброго,

Ищу аналог Dataextraction на лисп для извлечения, суммирования, сортировки и экспорта в эксель атрибутов из требуемых блоков.
Руки недостаточно прямые чтоб с нуля самому писать )). Но, если найду более менее подходящий код, попробую доработать...
Пока из того с чего можно начать нашел две команду от Lee Mac - CountAttributeValues и SumAttributeValues. Пока правда не ковырял их.
Если у кого есть что-то по теме - прошу поделиться.

Nike · 21.09.2016, 11:06

http://forum.dwg.ru/showthread.php?t=54936

Сергей812 · 21.09.2016, 11:10

А почему не из экселя подключиться и собрать данные? А сортирует, суммирует пускай дальше эксель.

Red Nova · 22.09.2016, 23:21

Nike
В принципе количество определенных атрибутов lstatt считает, правда фильтрует их по порядковомы номеру а не по имени тега. Естественно это не совсем то что я искал, но попробобать скрестить с кодами от Lee Mac мажно.

Сергей812
По сути можно и так. Но из экселя подключаться - это ведь не лиспом уже? ...

Сергей812 · 22.09.2016, 23:26

Цитата:

Сообщение от Red Nova

По сути можно и так. Но из экселя подключаться - это ведь не лиспом уже? ...

да - это уже VBA. Код располагается внутри книги самой, большинство примеров для VBA в акаде без особых изменений переноситься в эксель

Red Nova · 24.09.2016, 06:54

За основу я взял код LSTATT от Patrick_35.
К моему удивлению я прилично преуспел. Правда, в коде сейчас царит анархия. Ведь я выпиливал только то что мне мешало и не углублялся во все нюансы.Так что мусора много.
Сейчас я уже могу собрать всю требуемую информацию для спецификации моих панелей и вставить ее как таблицу в файл. (прикрепляю файл теста с соответствующей таблицей)
Застрял на том что нужно отсортировать список перед тем как записать в таблицу.
Сейчас таблица выглядит так:

Нужно провести двухуровневую сортировку.
Во первых отсортировать по атрибуту Floor (1,2,3,...) затем для каждого значения Floor, нужно провести сортировку по атрибуту Bay (1a,1b,1c,....2a,2b,2c.....)
Хелп плиз

Код:

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

 (defun c:RN_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 InputBox (Titre js / ch dcl fil res tmp txt)
	   (setq ch "Plan Slab")
	   (setq js ch)
  )

  (defun liste_att(att / n lst val)
      (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)
	  )
	)
	(setq lst (reverse lst))

	(setq lst (remove-i 11 lst))
	(setq lst (remove-i 10 lst))
	(setq lst (remove-i 9 lst))
	(setq lst (remove-i 8 lst))
	(setq lst (remove-i 7 lst))
	(setq lst (remove-i 6 lst))
	(setq lst (remove-i 5 lst))
	(setq lst (remove-i 4 lst))
	(setq lst (remove-i 3 lst))
      )
  )

  (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 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))
  )
  (setq nb "14")
  (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
	  (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
			(rearragneslablist (remove-i 1 (cons (itoa (- n (length tbl))) js))) lst
			)
	    )
	  )
	)
      )
    )
  )
  (setq *error* s)
  (princ)

(setq space
            (vlax-get-property
              (setq doc
                (vla-get-ActiveDocument (vlax-get-acad-object))
              )
              (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace)
            )
          )
  
(setq pt (getpoint "\nPick Point for Table: "))

(LM:AddTable space (trans pt 1 0) "Comslab Table" 
        (cons '("Floor" "Bay" "Quantity" "Length" "Rebar" "Gauge") lst)

      )

  
)


;;---------------------=={ Add Table }==----------------------;;
;;                                                            ;;
;;  Creates a VLA Table Object at the specified point,        ;;
;;  populated with title and data                             ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  space - VLA Block Object                                  ;;
;;  pt    - Insertion Point for Table                         ;;
;;  title - Table title                                       ;;
;;  data  - List of data to populate the table                ;;
;;------------------------------------------------------------;;
;;  Returns:  VLA Table Object                                ;;
;;------------------------------------------------------------;;

(defun LM:AddTable ( space pt title data / _itemp ) (vl-load-com)

  (defun _itemp ( collection item )
    (if
      (not
        (vl-catch-all-error-p
          (setq item
            (vl-catch-all-apply 'vla-item (list collection item))
          )
        )
      )
      item
    )
  )

  (
    (lambda ( table ) (vla-put-StyleName table (getvar 'CTABLESTYLE)) (vla-SetText table 0 0 title)
      (
        (lambda ( row )
          (mapcar
            (function
              (lambda ( rowitem ) (setq row (1+ row))
                (
                  (lambda ( column )
                    (mapcar
                      (function
                        (lambda ( item )
                          (vla-SetText table row
                            (setq column (1+ column)) item
                          )
                        )
                      )
                      rowitem
                    )
                  )
                  -1
                )
              )
            )
            data
          )
        )
        0
      )
      table
    )
    (
      (lambda ( textheight )
        (vla-AddTable space (vlax-3D-point pt) (1+ (length data)) (length (car data)) (* 1.8 textheight)
          (* textheight
            (apply 'max
              (cons (/ (strlen title) (length (car data)))
                (mapcar 'strlen (apply 'append data))
              )
            )
          )
        )
      )
      (vla-getTextHeight
        (_itemp
          (_itemp
            (vla-get-Dictionaries
              (vla-get-ActiveDocument (vlax-get-acad-object))
            )
            "ACAD_TABLESTYLE"
          )
          (getvar 'CTABLESTYLE)
        )
        acDataRow
      )
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun remove-i (i lst)
;;; i - index (fom 0)
;;;lst- list of elemets

      (setq i (1+ i))
      (vl-remove-if '(lambda (x) (zerop (setq i (1- i)))) lst)
) ;_ end of defun


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun rearragneslablist (lst / first thelast lst2 lst3)
      (setq
          first (nth 0 lst)
          thelast (nth 5 lst)	
          lst2 (remove-i 0 lst)
          lst2 (remove-i 2 lst2)
	  lst2 (remove-i 2 lst2)	
	  lst2 (remove-i 2 lst2)
	  lst (remove-i 0 lst)
	  lst (remove-i 0 lst)
	  lst (remove-i 0 lst)
          lst (cons first lst)
          lst (append lst2 lst)
	
          lst (remove-i 5 lst)
	  lst3 (remove-i 3 lst)
	  lst3 (remove-i 3 lst3)
          lst (remove-i 0 lst)
          lst (remove-i 0 lst)
          lst (remove-i 0 lst)
          lst (cons thelast lst)
          lst (append lst3 lst)	
      )
)

----- добавлено через ~28 мин. -----
Не беспокойтесь. Нашел. 2 раза vl-sort и все ок

Код:

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

 (defun c:RN_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 InputBox (Titre js / ch dcl fil res tmp txt)
	   (setq ch "Plan Slab")
	   (setq js ch)
  )

  (defun liste_att(att / n lst val)
      (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)
	  )
	)
	(setq lst (reverse lst))

	(setq lst (remove-i 11 lst))
	(setq lst (remove-i 10 lst))
	(setq lst (remove-i 9 lst))
	(setq lst (remove-i 8 lst))
	(setq lst (remove-i 7 lst))
	(setq lst (remove-i 6 lst))
	(setq lst (remove-i 5 lst))
	(setq lst (remove-i 4 lst))
	(setq lst (remove-i 3 lst))
      )
  )

  (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 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))
  )
  (setq nb "14")
  (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
	  (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
			(rearragneslablist (remove-i 1 (cons (itoa (- n (length tbl))) js))) lst
			)
	    )
	  )
	)
      )
    )
  )
  (setq *error* s)
  (princ)

(setq lst  (vl-sort lst   
             (function (lambda (A B)
                         (< (cadr A) (cadr B)))))
      lst  (vl-sort lst
             (function (lambda (A B)
                         (< (car A) (car B)))))
)
  
(setq space
            (vlax-get-property
              (setq doc
                (vla-get-ActiveDocument (vlax-get-acad-object))
              )
              (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace)
            )
          )
  
(setq pt (getpoint "\nPick Point for Table: "))

(LM:AddTable space (trans pt 1 0) "Comslab Table" 
        (cons '("Floor" "Bay" "Quantity" "Length" "Rebar" "Gauge") lst)

      )

  
)


;;---------------------=={ Add Table }==----------------------;;
;;                                                            ;;
;;  Creates a VLA Table Object at the specified point,        ;;
;;  populated with title and data                             ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  space - VLA Block Object                                  ;;
;;  pt    - Insertion Point for Table                         ;;
;;  title - Table title                                       ;;
;;  data  - List of data to populate the table                ;;
;;------------------------------------------------------------;;
;;  Returns:  VLA Table Object                                ;;
;;------------------------------------------------------------;;

(defun LM:AddTable ( space pt title data / _itemp ) (vl-load-com)

  (defun _itemp ( collection item )
    (if
      (not
        (vl-catch-all-error-p
          (setq item
            (vl-catch-all-apply 'vla-item (list collection item))
          )
        )
      )
      item
    )
  )

  (
    (lambda ( table ) (vla-put-StyleName table (getvar 'CTABLESTYLE)) (vla-SetText table 0 0 title)
      (
        (lambda ( row )
          (mapcar
            (function
              (lambda ( rowitem ) (setq row (1+ row))
                (
                  (lambda ( column )
                    (mapcar
                      (function
                        (lambda ( item )
                          (vla-SetText table row
                            (setq column (1+ column)) item
                          )
                        )
                      )
                      rowitem
                    )
                  )
                  -1
                )
              )
            )
            data
          )
        )
        0
      )
      table
    )
    (
      (lambda ( textheight )
        (vla-AddTable space (vlax-3D-point pt) (1+ (length data)) (length (car data)) (* 1.8 textheight)
          (* textheight
            (apply 'max
              (cons (/ (strlen title) (length (car data)))
                (mapcar 'strlen (apply 'append data))
              )
            )
          )
        )
      )
      (vla-getTextHeight
        (_itemp
          (_itemp
            (vla-get-Dictionaries
              (vla-get-ActiveDocument (vlax-get-acad-object))
            )
            "ACAD_TABLESTYLE"
          )
          (getvar 'CTABLESTYLE)
        )
        acDataRow
      )
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun remove-i (i lst)
;;; i - index (fom 0)
;;;lst- list of elemets

      (setq i (1+ i))
      (vl-remove-if '(lambda (x) (zerop (setq i (1- i)))) lst)
) ;_ end of defun


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun rearragneslablist (lst / first thelast lst2 lst3)
      (setq
          first (nth 0 lst)
          thelast (nth 5 lst)	
          lst2 (remove-i 0 lst)
          lst2 (remove-i 2 lst2)
	  lst2 (remove-i 2 lst2)	
	  lst2 (remove-i 2 lst2)
	  lst (remove-i 0 lst)
	  lst (remove-i 0 lst)
	  lst (remove-i 0 lst)
          lst (cons first lst)
          lst (append lst2 lst)
	
          lst (remove-i 5 lst)
	  lst3 (remove-i 3 lst)
	  lst3 (remove-i 3 lst3)
          lst (remove-i 0 lst)
          lst (remove-i 0 lst)
          lst (remove-i 0 lst)
          lst (cons thelast lst)
          lst (append lst3 lst)	
      )
)

Red Nova · 24.09.2016, 16:25

На данный момент команды для вставки таблицы панелей как для всех этажей так и с выбором этажа готовы. В примере имеются обе таблицы. При создании таблицы добавил зависимость ее размера от аннотативного масштаба. Так что если вставляем таблицу в модель где масштаб 1:50, то она будет в 50 раз больше чем если вставить ее на листе где масштаб 1:1.
RN_SlabtableByFloor - вставляет спецификацию панелей для выбранного этажа
RN_Slabtable - вставляет спецификацию панелей для всех этажей

Код:

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

 
(defun c:RN_SlabtableByFloor (/ 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 currentfloor *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 InputBox (Titre js / ch dcl fil res tmp txt)
	   (setq ch "Plan Slab")
	   (setq js ch)
  )

  (defun liste_att(att / n lst val)
      (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)
	  )
	)
	(setq lst (reverse lst))

	(setq lst (remove-i 11 lst))
	(setq lst (remove-i 10 lst))
	(setq lst (remove-i 9 lst))
	(setq lst (remove-i 8 lst))
	(setq lst (remove-i 7 lst))
	(setq lst (remove-i 6 lst))
	(setq lst (remove-i 5 lst))
	(setq lst (remove-i 4 lst))
	(setq lst (remove-i 3 lst))
      )
  )

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

  (vla-startundomark
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  ) ;_ end of vla-startundomark
  
  (setq s *error*
	*error* *errlst*
	doc (vla-get-activedocument (vlax-get-acad-object))
  )
  (setq nb "14")
  (setq lab "0")
  (setq fic "0")
  (if (not (eq (setq nm (InputBox "Dйcompte de blocs V4.21" "*")) ""))
    (progn
      (setq currentfloor (getstring "Enter FLOOR number: "))
      (setq js (strcat "`**," nm))
;      (if (ssget (list (cons 0 "INSERT") (cons 2 js)))		; requesting to select objects
       (if (ssget "x" (list (cons 0 "INSERT") (cons 2 js))) 	; selecting entire drawing     
	(progn
	  (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 (vl-remove-if-not (function (lambda(x) (= (car x) currentfloor)))
			(cons
			(rearragneslablist (remove-i 1 (cons (itoa (- n (length tbl))) js))) lst
			))
	    )
	  )
	)
      )
    )
  )
  (setq *error* s)
  (princ)

(setq lst  (vl-sort lst   
             (function (lambda (A B)
                         (< (cadr A) (cadr B)))))
      lst  (vl-sort lst
             (function (lambda (A B)
                         (< (car A) (car B)))))
)
  
(setq space
            (vlax-get-property
              (setq doc
                (vla-get-ActiveDocument (vlax-get-acad-object))
              )
              (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace)
            )
          )
  
  
(setq pt (getpoint "\nPick Point for Table: "))

(AddSlabTable space (trans pt 1 0) "Comslab Table" 
        (cons '("Floor" "Bay" "Quantity" "Length" "Rebar" "Gauge") lst)

      )
  
(vla-endundomark adoc) ;;; undomark bottom mark
  
);defun

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:RN_Slabtable (/ 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 InputBox (Titre js / ch dcl fil res tmp txt)
	   (setq ch "Plan Slab")
	   (setq js ch)
  )

  (defun liste_att(att / n lst val)
      (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)
	  )
	)
	(setq lst (reverse lst))

	(setq lst (remove-i 11 lst))
	(setq lst (remove-i 10 lst))
	(setq lst (remove-i 9 lst))
	(setq lst (remove-i 8 lst))
	(setq lst (remove-i 7 lst))
	(setq lst (remove-i 6 lst))
	(setq lst (remove-i 5 lst))
	(setq lst (remove-i 4 lst))
	(setq lst (remove-i 3 lst))
      )
  )

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

  (vla-startundomark
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  ) ;_ end of vla-startundomark
  
  (setq s *error*
	*error* *errlst*
	doc (vla-get-activedocument (vlax-get-acad-object))
  )
  (setq nb "14")
  (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)))		; requesting to select objects
       (if (ssget "x" (list (cons 0 "INSERT") (cons 2 js))) 	; selecting entire drawing     
	(progn
	  (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
			(rearragneslablist (remove-i 1 (cons (itoa (- n (length tbl))) js))) lst
			)
	    )
	  )
	)
      )
    )
  )
  (setq *error* s)
  (princ)

(setq lst  (vl-sort lst   
             (function (lambda (A B)
                         (< (cadr A) (cadr B)))))
      lst  (vl-sort lst
             (function (lambda (A B)
                         (< (car A) (car B)))))
)
  
(setq space
            (vlax-get-property
              (setq doc
                (vla-get-ActiveDocument (vlax-get-acad-object))
              )
              (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace)
            )
          )
  
  
(setq pt (getpoint "\nPick Point for Table: "))

(AddSlabTable space (trans pt 1 0) "Comslab Table" 
        (cons '("Floor" "Bay" "Quantity" "Length" "Rebar" "Gauge") lst)

      )

(vla-endundomark adoc) ;;; undomark bottom mark
  
);defun



;;---------------------=={ Add Table }==----------------------;;
;;                                                            ;;
;;  Creates a VLA Table Object at the specified point,        ;;
;;  populated with title and data                             ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  space - VLA Block Object                                  ;;
;;  pt    - Insertion Point for Table                         ;;
;;  title - Table title                                       ;;
;;  data  - List of data to populate the table                ;;
;;------------------------------------------------------------;;
;;  Returns:  VLA Table Object                                ;;
;;------------------------------------------------------------;;

(defun AddSlabTable ( space pt title data / _itemp tablescale oldlayer) (vl-load-com)

  (defun _itemp ( collection item )
    (if
      (not
        (vl-catch-all-error-p
          (setq item
            (vl-catch-all-apply 'vla-item (list collection item))
          )
        )
      )
      item
    )
  )
  
(setq oldlayer (getvar "CLAYER"))		; checking current layer
(command "Layer" "M" "BMP-Annotation" "")	; changing to layer BMP-Annotation
  
  (
    (lambda ( table ) (vla-put-StyleName table (getvar 'CTABLESTYLE)) (vla-SetText table 0 0 title)
      (
        (lambda ( row )
          (mapcar
            (function
              (lambda ( rowitem ) (setq row (1+ row))
                (
                  (lambda ( column )
                    (mapcar
                      (function
                        (lambda ( item )
                          (vla-SetText table row
                            (setq column (1+ column)) item
                          )
                        )
                      )
                      rowitem
                    )
                  )
                  -1
                )
              )
            )
            data
          )
        )
        0
      )
      table
    )
    (
      (lambda ( textheight )
        (vla-AddTable space (vlax-3D-point pt) (1+ (length data)) (length (car data)) (* 1.8 textheight)
          (* textheight
            (apply 'max
              (cons (/ (strlen title) (length (car data)))
                (mapcar 'strlen (apply 'append data))
              )
            )
          )
        )
      )
      (vla-getTextHeight
        (_itemp
          (_itemp
            (vla-get-Dictionaries
              (vla-get-ActiveDocument (vlax-get-acad-object))
            )
            "ACAD_TABLESTYLE"
          )
          (getvar 'CTABLESTYLE)
        )
        acDataRow
      )
    )
  )
  (setvar "CLAYER" oldlayer)                        ; bringing back old layer
  (setq tablescale (/ 1 (getvar 'CANNOSCALEVALUE))) ; adding ability to scale the inserted object based on annotative scale
  (command "_scale" "L" "" pt tablescale)           ; scaling
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun remove-i (i lst)
;;; i - index (fom 0)
;;;lst- list of elemets

      (setq i (1+ i))
      (vl-remove-if '(lambda (x) (zerop (setq i (1- i)))) lst)
) ;_ end of defun


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun rearragneslablist (lst / first thelast lst2 lst3)
      (setq
          first (nth 0 lst)
          thelast (nth 5 lst)	
          lst2 (remove-i 0 lst)
          lst2 (remove-i 2 lst2)
	  lst2 (remove-i 2 lst2)	
	  lst2 (remove-i 2 lst2)
	  lst (remove-i 0 lst)
	  lst (remove-i 0 lst)
	  lst (remove-i 0 lst)
          lst (cons first lst)
          lst (append lst2 lst)
	
          lst (remove-i 5 lst)
	  lst3 (remove-i 3 lst)
	  lst3 (remove-i 3 lst3)
          lst (remove-i 0 lst)
          lst (remove-i 0 lst)
          lst (remove-i 0 lst)
          lst (cons thelast lst)
          lst (append lst3 lst)	
      )
)


(defun testit (/)
    (vl-load-com)
    (vl-remove-if-not (function (lambda(x) (= (car x) "2"))) '(("1" "1a" "4" "18'-2 3/4"" "#5" "19") ("1" "1b" "3" "32'-4 1/4"" "#5" "19") ("2" "1a" "11" "20'-10 1/4"" "#5" "19") ("2" "1b" "4" "14'-2 1/4"" "#5" "19") ("2" "1c" "2" "9'-1 1/4"" "#5" "19") ("3" "1c" "2" "9'-1 1/4"" "#5" "19") ("3" "1d" "4" "9'-4 1/2"" "#5" "19") ("3" "1d" "1" "9'-4 3/4"" "#5" "19")) )
)

Теперь пытаюсь сделать таблицу с суммарным метражом панелей по каждому этажу. Пока застрял на этом.

Red Nova · 08.10.2016, 18:03

Я таки написал все команды которые мне были нужны и полностью заменил датаэкстракшен. После получения списка с атрибутами необходимых блоков работа сводится к группировке, сортировке и прочим преобразованиям списка. Некоторые функции сам написал, другие подкинули коллеги по форуму. После этого записываю список в таблицу с помощью кода от LeeMac. Кстати, нашел его более продвинутую версию (по сравнению с постом #7). Позволяет делать ширину колонок таблицы как одинаковой для всех (по самой широкой колонке) так и индивидуальной. У LeeMac-а правда что-то было криво с поддержкой аннотативных масштабов, таблица масштаб поддерживала а текст всегда оставался маленький. Сделал свою версию, с простым масштабированием размера таблицы в зависимости от CANNOSCALEVALUE.

Вот последний вариант кода для самой простой из моих команд для сбора данных из атрибутов блоков, это пойдет за общий случай. Выкладывать остальное не имеет смысла так как команды весьма специфичны. А для тех кому потребуется что-то аналогичное это может послужить точкой старта.

Код:

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

 (defun c:RN_CSTableD (/ InputBox doc i js ent fic fil lab lst mrc trc n nb nm liste_att s sel tbl 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 InputBox (Titre js / ch dcl fil res tmp txt)
	   (setq ch "BMP Plan ComSlab"); Set the block name
	   (setq js ch)
  )
  
  (defun liste_att(att / n lst val)
      (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)
	  )
	)
	(setq lst (reverse lst))
	(setq lst (remove-i 13 lst))
	(setq lst (remove-i 11 lst))
	(setq lst (remove-i 10 lst))
	(setq lst (remove-i 8 lst))
	(setq lst (remove-i 7 lst))
	(setq lst (remove-i 6 lst))
	(setq lst (remove-i 5 lst))
	(setq lst (remove-i 4 lst))
	(setq lst (remove-i 3 lst))
      )
  )

;;;;;;;;;;;;;;;
  
  (vl-load-com)

  (vla-startundomark
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  ) ;_ end of vla-startundomark
  
  (setq s *error*
	*error* *errlst*
	doc (vla-get-activedocument (vlax-get-acad-object))
  )
  (setq nb "14"); set quantity of attributes to be read
  (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)))		; requesting to select objects
       (if (ssget "x" (list (cons 0 "INSERT") (cons 2 js))) 	; selecting entire drawing     
	(progn
	  (vlax-map-collection	(setq sel (vla-get-activeselectionset doc))
				(function (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)
	    )
	  )
	)
      )
    )
  )
  (setq *error* s)
  (princ)
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Here starts list transformation
  
(setq lst
	(mapcar (function (lambda (n) (rearragneslablistdec (remove-i 1 n))))
         lst))
  
(setq lst  (vl-sort lst   
             (function (lambda (A B)
                         (< (cadr A) (cadr B)))))
      lst  (vl-sort lst
             (function (lambda (A B)
                         (< (car A) (car B)))))
)
  
(setq space
            (vlax-get-property
              (setq doc
                (vla-get-ActiveDocument (vlax-get-acad-object))
              )
              (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace)
            )
          )
  
  
(setq pt (getpoint "\nPick Point for Table: "))

(RN:LM:addtable space (trans pt 1 0) "Comslab Table" 
        (cons '("Floor" "Bay" "Quantity" "Length \"" "Rebar" "Gauge") lst) nil)

(vla-endundomark adoc) ;;; undomark bottom mark
  
);defun


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (defun nombl(bl)
    (if (vlax-property-available-p bl 'effectivename)
      (vla-get-effectivename bl)
      (vla-get-name bl)
    )
  )

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

;;---------------------=={ Add Table }==----------------------;;                          
;; Add Table  -  Lee Mac                                                                  
;; Taken from - PolyInfoV1-3                                                              
;; Generates a table at the given point, populated with the given data and optional title.
;; spc - [vla] VLA Block object                                                           
;; ins - [lst] WCS insertion point for table                                              
;; ttl - [str] [Optional] Table title                                                     
;; lst - [lst] Matrix list of table cell data                                             
;; eqc - [bol] If T, columns are of equal width                                           
;; Returns: [vla] VLA Table Object                                                        
;;--------------------MODIFIED BY RED NOVA--------------------;;                          
;; Added Changing Insertion Layer                                                         
;; Corrected Annotative support                                                           

(defun RN:LM:addtable ( spc ins ttl lst eqc / dif hgt i j obj stn sty wid tablescale oldlayer)

  (setq oldlayer (getvar "CLAYER"))		; checking current layer
  (command "Layer" "M" "BMP-Annotation" "")	; changing to layer BMP-Annotation
  
    (setq sty
        (vlax-ename->vla-object
            (cdr
                (assoc -1
                    (dictsearch (cdr (assoc -1 (dictsearch (namedobjdict) "acad_tablestyle")))
                        (getvar 'ctablestyle)
                    )
                )
            )
        )
    )
    (setq hgt (vla-gettextheight sty acdatarow))
    (setq stn (vla-gettextstyle sty acdatarow));Modification compared to LEE MAC version. To eliminate annotative scale effect at this point
 ;   (if (LM:annotative-p (setq stn (vla-gettextstyle sty acdatarow))
 ;       (setq hgt (/ hgt (cond ((getvar 'cannoscalevalue)) (1.0))))
 ;   )
    (setq wid
        (mapcar
           '(lambda ( col )
                (apply 'max
                    (mapcar
                       '(lambda ( str )
                            (   (lambda ( box ) (if box (+ (* 2.5 hgt) (- (caadr box) (caar box))) 0.0))
                                (textbox
                                    (list
                                        (cons 01 str)
                                        (cons 40 hgt)
                                        (cons 07 stn)
                                    )
                                )
                            )
                        )
                        col
                    )
                )
            )
            (apply 'mapcar (cons 'list lst))
        )
    )
    (if 
        (and ttl
            (< 0.0
                (setq dif
                    (/
                        (-
                            (   (lambda ( box ) (if box (+ (* 2.5 hgt) (- (caadr box) (caar box))) 0.0))
                                (textbox
                                    (list
                                        (cons 01 ttl)
                                        (cons 40 hgt)
                                        (cons 07 stn)
                                    )
                                )
                            )
                            (apply '+ wid)
                        )
                        (length wid)
                    )
                )
            )
        )
        (setq wid (mapcar '(lambda ( x ) (+ x dif)) wid))
    )
    (setq obj
        (vla-addtable spc
            (vlax-3D-point ins)
            (1+ (length lst))
            (length (car lst))
            (* 2.0 hgt)
            (if eqc
                (apply 'max wid)
                (/ (apply '+ wid) (float (length (car lst))))
            )
        )
    )
    (vla-put-regeneratetablesuppressed obj :vlax-true)
    (vla-put-stylename obj (getvar 'ctablestyle))
    (setq i -1)
    (if (null eqc)
        (foreach col wid
            (vla-setcolumnwidth obj (setq i (1+ i)) col)
        )
    )
    (if ttl
        (progn
            (vla-settext obj 0 0 ttl)
            (setq i 1)
        )
        (progn
            (vla-deleterows obj 0 1)
            (setq i 0)
        )
    )
    (foreach row lst
        (setq j 0)
        (foreach val row
            (vla-settext obj i j val)
            (setq j (1+ j))
        )
        (setq i (1+ i))
    )
    (vla-put-regeneratetablesuppressed obj :vlax-false)
    obj
  
  (setvar "CLAYER" oldlayer)                        ; bringing back old layer
  (setq tablescale (/ 1 (getvar 'CANNOSCALEVALUE))) ; adding ability to scale the inserted object based on annotative scale
  (command "_scale" "L" "" pt tablescale)           ; scaling
  
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun remove-i (i lst)
;;; i - index (fom 0)
;;;lst- list of elemets

      (setq i (1+ i))
      (vl-remove-if (function (lambda (x) (zerop (setq i (1- i))))) lst)
) ;_ end of defun


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun rearragneslablistdec (lst / quan lengthdec lst2 lst3)
      (setq
          quan (nth 0 lst)
	  lengthdec (rtos (read (nth 4 lst)) 2 2)
          lst2 (remove-i 0 lst)		
          lst2 (remove-i 2 lst2)
          lst2 (remove-i 2 lst2)
          lst2 (remove-i 2 lst2)

	  lst3 (remove-i 4 lst)
	  lst3 (remove-i 0 lst3)			      
	  lst3 (remove-i 0 lst3)
	  lst3 (remove-i 0 lst3)
			      
          lst3 (cons lengthdec lst3)
          lst3 (cons quan lst3)
			      
          lst (append lst2 lst3) 
      )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

valerik88 · 10.10.2016, 13:27

Я вот такую штуку себе делал http://forum.dwg.ru/showthread.php?t=132979

21.09.2016, 04:32		#1
Аналог Dataextraction на лисп (экспорт данных из атрибутов динамических блоков в таблицу, подсчет количества и т.п.) Red Nova ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ. Торонто Регистрация: 23.10.2007 Сообщений: 1,980 Доброго, Ищу аналог Dataextraction на лисп для извлечения, суммирования, сортировки и экспорта в эксель атрибутов из требуемых блоков. Руки недостаточно прямые чтоб с нуля самому писать )). Но, если найду более менее подходящий код, попробую доработать... Пока из того с чего можно начать нашел две команду от Lee Mac - CountAttributeValues и SumAttributeValues. Пока правда не ковырял их. Если у кого есть что-то по теме - прошу поделиться. Последний раз редактировалось Red Nova, 08.10.2016 в 18:58.
Просмотров: 2604

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Где можно применить "Извлечение данных"(_.dataextraction)?	wetr	AutoCAD	120	07.05.2020 13:39
Dataextraction. Изменение ссылки на dwg файл.	Red Nova	Программирование	20	05.09.2016 08:03
Аналог DataExtraction на vb.net	DEM	.NET	40	24.02.2014 23:06
Как можно из LISP запросить у юзера выделить произвольные элементы и затем вызвать аналог WMFOUT для сохранения их в изображении?	lexluther	LISP	4	12.08.2009 11:44
Лисп для копирования данных нескольких мтекстов по принципу расположения.	Red Nova	LISP	14	18.06.2008 22:08

	Реклама i