| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)

Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)

Ответ
Поиск в этой теме
Непрочитано 20.07.2008, 20:12
Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)
Red Nova
 
ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Торонто
Регистрация: 23.10.2007
Сообщений: 1,980

Со школы не ладится у меня с программированием. Все предметы щелкал, а на экзамене по информатике (Visual foxpro) программку типа суммирования столбцов списал у соседа (это уже в университете).
Не смотря на эте намерен научится писать программы для Автокада на лиспе, скачал книгу Хювенена, несколько примеров создания программ, но после получасового “смотрения” таких книг мое мышление явно притормаживает.
Решил пойти другим путем.
Нашел самый короткий лисп из моей коллекции, и прошу программистов с этого форума пошагово объяснить какой символ что означает. Надеюсь на вашу помощь.


Код:
[Выделить все]
(defun c:make-blocks-explodeable (/ adoc)
  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-startundomark
  (vlax-for blk_def (vla-get-blocks adoc)
    (if (and (equal (vla-get-isxref blk_def) :vlax-false)
             (equal (vla-get-islayout blk_def) :vlax-false)
             ) ;_ end of and
      (vl-catch-all-apply '(lambda () (vla-put-explodable blk_def :vlax-true)))
      ) ;_ end of if
    ) ;_ end of vlax-for
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun
_____________________________________________________________________________________________________________

Прошло много лет и топик теперь представляет из себя площадку для обучения азов программирования для многих начинающих.
Так что начинающие лиспогрызы приветствуются .
__________________
Блог

Последний раз редактировалось Red Nova, 12.07.2017 в 05:43.
Просмотров: 1965800
 
Непрочитано 03.03.2017, 15:20
#3281
Enik

ГИП
 
Регистрация: 07.06.2015
Сообщений: 1,254


Виноват. Начнём по порядку. Чтобы без всяких яких и с понятными обозначениями функций.

Вот весь код:

Код:
[Выделить все]
 ;;;;
;;;;Реставрация очертания взорванной полилинии из её отрезков
;;;;

;;;;Рисование полилинии
(defun c:PL_RES (/ dots_set)

 	(setq dots_set (kpblc_list))
  	(setq dots_set (sort (dots_set)))

	(disable_enable_osmode)
	
	(apply 'vl-cmdf (append (list "_.PLINE" (car dots_set) "_W" 0 0) (cdr dots_set) '("")))

	(disable_enable_osmode)

) ;_ end of defun  


;;;;Получение списка координат начала и конца отрезков by Kpblc
(defun kpblc_list (/ selset)
  (if (setq selset (ssget '((0 . "LINE"))))
    (apply (function append)
           (mapcar (function (lambda (ent) (setq ent (entget ent)) (list (cdr (assoc 11 ent)) (cdr (assoc 10 ent)))))
                   ((lambda (/ tab item)
                      (repeat (setq tab  nil
                                    item (sslength selset)
                                    ) ;_ end setq
                        (setq tab (cons (ssname selset (setq item (1- item))) tab))
                        ) ;_ end of repeat
                      ) ;_ end of lambda
                    )
                   ) ;_ end of mapcar
           ) ;_ end of apply
    ) ;_ end of if
  ) ;_ end of defun

;;;;Отключение привязки
(defun disable_enable_osmode ()
    (if (< (getvar "osmode") 16384) 
      (setvar "osmode" (+ (getvar "osmode") 16384)) 
      (setvar "osmode" (- (getvar "osmode") 16384))
    )
)

;;;;Сортировка списка координат точек по расстоянию by Lee Mac
 (defun sort ( lst / _sort a b d e l p )
  (defun _sort ( a b )
    (if a (cons a (_sort (car (setq b (vl-sort b '(lambda ( c d ) (< (distance a c) (distance a d)))))) (cdr b))))
  )
  (setq l (cdr lst)
        d (distance (setq p (car lst)) (car l))
  )
  (while (setq a (car l))
    (foreach b (setq l (cdr l))
      (if (< d (setq e (distance a b))) (setq p a d e))
    )
  )
  (_sort p (vl-remove p lst))
)
Если кратко:
Выделяем отрезки (полученный из взорванной полилинии или нескольких, наложенных друг на друга), получаем координаты их начала и конца, загоняем координаты в список вида ((1.002 2.01 0) (4.04 2.07 0) ... ), дальше сортируем координаты точек внутри списка таким образом, чтобы по ним можно было нарисовать полилинию, не пересекающую саму себя. То есть, берётся первая точка - элемент из списка, и среди оставшихся точек-элементов выбирается ближайшая к ней. и т.д. Потом рисуем по этим точкам полилинию.

Но сейчас оно не работает. Функция для сортировки списка координат точек стопорится, когда встречает вещественное число с плавающей точкой.

Материалы взяты отсюда
Формирование списка - http://forum.dwg.ru/showpost.php?p=1...postcount=3269
Сортировка списка - http://www.cadtutor.net/forum/showth...l=1#post417660
Enik вне форума  
 
Непрочитано 03.03.2017, 15:39
#3282
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


(setq dots_set (sort (dots_set)))

и

(setq dots_set (sort dots_set))

Разные вещи.

----- добавлено через ~2 мин. -----
И чем тебе так не угодил _.pedit?
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 03.03.2017, 15:46
#3283
Enik

ГИП
 
Регистрация: 07.06.2015
Сообщений: 1,254


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
И чем тебе так не угодил _.pedit?
Просто не разобрался. С этой командой я часто работаю в самом автокаде. И даже не представляю, как на данном примере можно использовать её функционал.
Enik вне форума  
 
Непрочитано 03.03.2017, 15:52
#3284
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Вариант без командных методов:
Код:
[Выделить все]
 (defun test (/ selset pt_lst)
  (if (= (type (setq selset (vl-catch-all-apply (function (lambda () (ssget '((0 . "LINE"))))))))
         'pickset
         ) ;_ end of =
    (progn (foreach pt (apply (function append)
                              (mapcar (function (lambda (x) (setq x (entget x)) (list (cdr (assoc 10 x)) (cdr (assoc 11 x)))))
                                      ((lambda (/ tab item)
                                         (repeat (setq tab  nil
                                                       item (sslength selset)
                                                       ) ;_ end setq
                                           (setq tab (cons (ssname selset (setq item (1- item))) tab))
                                           ) ;_ end of repeat
                                         ) ;_ end of lambda
                                       )
                                      ) ;_ end of mapcar
                              ) ;_ end of apply
             (if (not (member pt pt_lst))
               (setq pt_lst (cons pt pt_lst))
               ) ;_ end of if
             ) ;_ end of foreach
           (entmakex (append (list '(0 . "LWPOLYLINE")
                                   '(100 . "AcDbEntity")
                                   '(100 . "AcDbPolyline")
                                   (cons 90 (length pt_lst))
                                   '(70 . 0)
                                   '(43 . 0.0)
                                   '(38 . 0.0)
                                   '(39 . 0.0)
                                   ) ;_ end of list
                             (mapcar (function (lambda (x) (cons 10 x))) (sort pt_lst))
                             ) ;_ end of append
                     ) ;_ end of entmakex
           ) ;_ end of progn
    ) ;_ end of if
 ;_ end of entmakex
  ) ;_ end of defun
----- добавлено через ~3 мин. -----
Цитата:
Сообщение от Enik Посмотреть сообщение
Просто не разобрался. С этой командой я часто работаю в самом автокаде. И даже не представляю, как на данном примере можно использовать её функционал.
https://dwg.ru/dnl/607 , команда pl-join. Бери код, смотри.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 03.03.2017, 15:58
#3285
Enik

ГИП
 
Регистрация: 07.06.2015
Сообщений: 1,254


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
С.-Петербург
Сообщений: 34,062

(setq dots_set (sort (dots_set)))

и

(setq dots_set (sort dots_set))

Разные вещи.
Спасибо! Глупая ошибка Да, теперь всё работает корректно (если обратно поменять местами 10 и 11 dxf коды). Не так уж и много времени занимает программа. У меня 1700 отрезков обработала меньше, чем за минуту.

Теперь попробую добавить указание крайней точки полилинии + прикручу прополку.

----- добавлено через ~1 ч. -----
Ну, в общем, рабочий код получен. Алексею большое спасибо!

Код:
[Выделить все]
 ;;;;
;;;;Реставрация очертания взорванной полилинии из её отрезков
;;;;

;;;;Рисование полилинии
(defun c:PL_RES (/ dots_set)

	(disable_enable_osmode)
  
	(setq dot_start (getpoint "\nУкажите базовую точку : "))
 	(setq dots_set (kpblc_list))
  	(setq dots_set (cons dot_start dots_set))
  	(setq dots_set (sort dots_set))
	(apply 'vl-cmdf (append (list "_.PLINE" (car dots_set) "_W" 0 0) (cdr dots_set) '("")))

	(disable_enable_osmode)

) ;_ end of defun  


;;;;Получение списка координат начала и конца отрезков by Kpblc
(defun kpblc_list (/ selset)
  (if (setq selset (ssget '((0 . "LINE"))))
    (apply (function append)
           (mapcar (function (lambda (ent) (setq ent (entget ent)) (list (cdr (assoc 10 ent)) (cdr (assoc 11 ent)))))
                   ((lambda (/ tab item)
                      (repeat (setq tab  nil
                                    item (sslength selset)
                                    ) ;_ end setq
                        (setq tab (cons (ssname selset (setq item (1- item))) tab))
                        ) ;_ end of repeat
                      ) ;_ end of lambda
                    )
                   ) ;_ end of mapcar
           ) ;_ end of apply
    ) ;_ end of if
  ) ;_ end of defun

;;;;Отключение привязки
(defun disable_enable_osmode ()
    (if (< (getvar "osmode") 16384) 
      (setvar "osmode" (+ (getvar "osmode") 16384)) 
      (setvar "osmode" (- (getvar "osmode") 16384))
    )
)

;;;;Сортировка списка координат точек по расстоянию by Lee Mac
 (defun sort ( lst / _sort a b d e l p )
  (defun _sort ( a b )
    (if a (cons a (_sort (car (setq b (vl-sort b '(lambda ( c d ) (< (distance a c) (distance a d)))))) (cdr b))))
  )
  (setq l (cdr lst)
        d (distance (setq p (car lst)) (car l))
  )
  (while (setq a (car l))
    (foreach b (setq l (cdr l))
      (if (< d (setq e (distance a b))) (setq p a d e))
    )
  )
  (_sort p (vl-remove p lst))
)


Для прополки полилинии проще всего использовать встроенную команду в автокаде или PL-VxRdc из https://dwg.ru/dnl/607 . Не стал эту красоту своими ручонками кромсать. Да и зачем, когда есть корпоративные стандарты двжру?

Дальше буду пробовать использовать различные варианты кода и сравнивать их по быстродействию (в некомпилированном виде).

Ещё буду разбирать по существу отдельные строчки кода. А то порой кажется, что шмель летать не должен так оно в принципе невозможно. А оно работает и плюёт на Enik'а. Наверное, это особенности AutoLisp. Интересный язык, однако.

Последний раз редактировалось Enik, 03.03.2017 в 17:08.
Enik вне форума  
 
Непрочитано 17.03.2017, 22:26 Помогите доработать LISP-код для автоматизированной выгрузки атрибутов и свойств в таблицу внутри автокад без участия _DataExtraction
#3286
Sergey91@06


 
Регистрация: 15.06.2014
Сообщений: 10


Есть необходимость доработать автоматическое заполнение таблицы автокад в виде спецификации. На просторах Рунета нашел отличный код, который позволяет делать спецификацию для выбранных элементов, теперь необходимо, чтобы вместо имени блока в строку наименование, он прописывал название видимости, а в столбцы "наименование" и "гайки" прописывал соответвующие атрибуты, в столбец "длина" прописывал длину если таковая есть. Догадываюсь что сделать это весьма несложно, но в LISP-программировании я нуб. Буду благодарен за любую помощь.
Еще интересует возможность доработки данного LIPS для создания аналогичной таблицы во внешний EXEL-файл.
Вложения
Тип файла: lsp hspec.lsp (16.6 Кб, 43 просмотров)
Sergey91@06 вне форума  
 
Непрочитано 18.03.2017, 00:30
#3287
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 11,004


Вы выбрали неплохой пример, чтобы начать изучать LISP. Насколько вижу, в данном лиспе есть все необходимые для озвученной задачи примеры - получение атрибутов, состояния видимости, вставка и заполнения таблицы и т.д. Как выгрузить данные в эксель - примеров тоже более чем достаточно - например. И напоминаю про ветку для новичков в лиспе.
Сергей812 вне форума  
 
Непрочитано 18.03.2017, 09:07
#3288
Sergey91@06


 
Регистрация: 15.06.2014
Сообщений: 10


Добрый день, отписался в новой теме, но меня перенаправили сюда:
Есть необходимость доработать автоматическое заполнение таблицы автокад в виде спецификации. На просторах Рунета нашел отличный код, который позволяет делать спецификацию для выбранных элементов, теперь необходимо, чтобы вместо имени блока в строку наименование, он прописывал название видимости, а в столбцы "наименование" и "гайки" прописывал соответствующие атрибуты, в столбец "длина" прописывал длину если таковая есть. Догадываюсь что сделать это весьма несложно, но в LISP-программировании я нуб. Буду благодарен за любую помощь.

P.S. Еще интересует возможность доработки данного LIPS для создания аналогичной таблицы во внешний EXEL-файл. В данный момент LISP код читает только блоки первого уровня, любопытно рассмотреть вариант выгрузки в таблицу блоков вложенных в другие блоки.

Код:
[Выделить все]
(Defun C:specification (/ sel len i spec_list name vla sp title code ed
			id spec_row tmp_row cnt new_row p1 p2 mas rows cols
			spec_table row col x1 y1 x2 y2 spec_number)
  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)
  
(defun get-all-atts (obj)
    ;;;Use (get-all-atts (car(entsel "\nSelect block:")))
    ;;;Returs list  (("TAG1" . "Value1")("TAG2" . "Value2") ...)
(vl-load-com)
    (if (= (type obj) 'ENAME)
		(setq obj (vlax-ename->vla-object obj)))
  (if (and obj
           (vlax-property-available-p obj 'Hasattributes)
	   (eq :vlax-true (vla-get-HasAttributes obj))
      )
    (vl-catch-all-apply
      (function
	(lambda	()
	  (mapcar (function (lambda (x)
			      (cons (vla-get-TagString x)
				    (vla-get-TextString x)
			      )
			    )
		  )
		  (append (vlax-invoke obj 'Getattributes)
			  (vlax-invoke obj 'Getconstantattributes)
		  )
	  )
	)
      )
    )
  )
)


 ;Âûáèðàåì áëîêè
  (setq sel (ssget '((0 . "INSERT"))))

 ;Êîëè÷åñòâî âûáðàííûõ ýëåìåíòîâ
  (setq len (SSLENGTH sel))
  (setq i 0)

  (setq spec_list nil)
 ;Öèêë îáðàáîòêè âûáðàííûõ îáúåêòîâ
  (while (< i len)
 ;Èìÿ âûáðàííîãî îáúåêòà
    (setq name (ssname sel i))

 ;Ïðåîáðàçóåì â vla-Îáúåêò
    (setq vla (vlax-ename->vla-object name))

    (setq spec_number 0)
    (while (<= spec_number 10)
    
 ;×èòàåì ñâîéñòâî è çàïèñûâàåì â ïåðåìåííûå íàçâàíèå è êîä
    (setq title "")
    (setq code "")
    (setq ed "")
    (setq cnt "1")

    ;Ïîëó÷àåì ñïåöèôèêàöèþ èç áëîêà
    (setq sp (BlockLdata name (strcat "spec" (itoa spec_number))))
(if sp (progn
	 
    (setq tmp (cdr (assoc "code" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq code (strcat code (eval n)))))
      (setq code tmp)
    )

    (setq tmp (cdr (assoc "ed" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST) 
    (foreach n read_tmp (progn (setq ed (strcat ed (eval n)))))
       (setq ed tmp)
    )

    (setq cnt "")
    (setq tmp (cdr (assoc "cnt" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq cnt (strcat cnt (eval n)))))
       (setq cnt tmp)
    )

    (setq tmp (cdr (assoc "title" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq title (strcat title (eval n)))))
	(setq title tmp)
    )
))
      (if (or sp (= spec_number 0))
	(progn
    ;Åñëè íàçâàíèå ïóñòîå, ïðèñâàèâàåì èìÿ áëîêà
	  (if (not sp)(progn
    (if (or (not title)(= title "")) (setq title (vla-get-effectivename vla)))
    (if (not code) (setq code ""))
    (if (or (not ed)(= ed "")) (setq ed "øò"))
    (if (or (not cnt)(= cnt "")) (setq cnt "1"))
    		       );end progn
	    );end if

	  (if (/= title "")(progn
    (setq id (strcat title "_" code "_" ed))

 	;spec_row ("id áëîêà" ("title" . "Íàçâàíèå") ("code" . "Êîä")("ed" . "øò") 1)
    (setq
      spec_row (cons id
		     (list (cons "title" title) (cons "code" code)(cons "ed" ed) (atof cnt))
	       )
    )

 ;Ñîáèðàåì ñïåöèôèêàöèþ
 ;Ñ÷èòàåì ýëåìåíò óíèêàëüíûì, åñëè ó íåãî óíèêàëåí id, ïîëó÷àåì ñïåöèôèêàöèþ
    (if	(setq tmp_row (assoc id spec_list))
      (progn
	(setq cnt (+ (last tmp_row) (atof cnt)))
	(setq new_row (cons id (list (cons "title" title) (cons "code" code)(cons "ed" ed) cnt)))
	(setq spec_list (subst new_row tmp_row spec_list))
      );end progn
      (setq spec_list (cons spec_row spec_list))
    );end if

    	);end progn
	);endif
    
	);end progn
	);endif
      (setq spec_number (1+ spec_number))
      );end while

    (setq i (1+ i))
  ) ;end while

  (setq spec_list (reverse spec_list))
  (setq spec_len (length spec_list))

  ;Çàïðàøèâàåì òî÷êó äëÿ âñòàâêè òàáëèöû
  (setq p1 (getpoint "Òî÷êà âñòàâêè òàáëèöû\n"))
  (setq p2 (GETCORNER p1 "Øèðèíà òàáëèöû\n"))
  (setq mas (/ (abs (- (car p1)(car p2))) 185))
  (setq x1 (car p1))
  (setq y1 (cadr p1))
  (setq x2 (car p2))
  (setq y2 (cadr p2))

  (setq p1 (list (min x1 x2)(max y1 y2) 0))

  

  ;Ñîçäà¸ì òàáëèöó
  (setq rows 2)
  (setq cols 7)
  (setq spec_table (vla-AddTable 
                    model_space 
                    (vlax-3d-point p1)
                    rows
                    cols 
                    10
                    10))

  ;Íàñòðàèâàåì ðàçìåðû ÿ÷ååê
  (vla-SetColumnWidth spec_table 0 15)
  (vla-SetColumnWidth spec_table 1 60)
  (vla-SetColumnWidth spec_table 2 65)
  (vla-SetColumnWidth spec_table 3 10)
  (vla-SetColumnWidth spec_table 4 15)
  (vla-SetColumnWidth spec_table 5 20)
  (vla-SetColumnWidth spec_table 6 20)
  
  (vla-setText spec_table 0 0 "Ñïåöèôèêàöèÿ ýëåìåíòîâ óçëà")
  (vla-setText spec_table 1 0 "Ïîç.")
  (vla-setText spec_table 1 1 "Îáîçíà÷åíèå")
  (vla-setText spec_table 1 2 "Íàèìåíîâàíèå")
  (vla-setText spec_table 1 3 "Åä.èçì")
  (vla-setText spec_table 1 4 "Êîë-âî.")
  (vla-setText spec_table 1 5 "Äëèíà")
  (vla-setText spec_table 1 6 "ãàéêà")
 

  ;Çàïîëíÿåì òàáëèöó
  (vla-insertrows spec_table 2 10 spec_len)
  (setq row 1)
  (repeat spec_len
    (progn
      (setq tmp (cdr (nth (1- row) spec_list)))
      (setq title (cdr (assoc "title" tmp)))
      (setq code (cdr (assoc "code" tmp)))
      (setq ed (cdr (assoc "ed" tmp)))
      (setq cnt (last tmp))
      
      (vla-setText spec_table (+ row 1) 0 (itoa row))
      (vla-setText spec_table (+ row 1) 1 title)
      (vla-setText spec_table (+ row 1) 2 code)
      (vla-setText spec_table (+ row 1) 3 ed)
      (vla-setText spec_table (+ row 1) 4 (ntos cnt))
      
      (setq row (1+ row))
    )
   )

  ;Øðèôò â ÿ÷åéêàõ
  (setq text_height 3)
  (vla-SetCellTextHeight spec_table 0 0 text_height)
  
  (setq row 1)
  (repeat (1+ spec_len)
    (progn
        (setq col 0)
  	(repeat cols
	  (progn
	    	;Âûñîòà òåêñòà
		(vla-SetCellTextHeight spec_table row col text_height)
		;Âûðàâíèâàíèå òåêñòà
		(cond
		  ((or (= col 0)(= col 2)(= col 3)(= col 4)(= row 1)) (vla-setcellalignment spec_table row col acmiddlecenter))
		  ((or (= col 1)) (vla-setcellalignment spec_table row col acMiddleLeft))
		  (t nil)
		)
	 	(setq col (1+ col))
	  )
	)
      (setq row (1+ row))
     )
   )

  ;Ìàñøòàáèðóåì òàáëèöó
  (vla-ScaleEntity spec_table (vlax-3d-point (car p1) (cadr p1) 0) mas)
  
(vla-endundomark active_document)
);end Defun

(Defun C:setspecification (/ sel)

 ;Âûáèðàåì áëîê
  (setq spec_number "0")
  (setq sel (ssget "_:S" '((0 . "INSERT"))))
  (setSpecificationDialog sel)

);end Defun

(Defun setSpecificationDialog (sel / file handle item name vla tmp
			   sp title code ed cnt dcl_id ddi)

  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)

  (setq	file   (strcat (vl-string-right-trim
			 "\\"
			 (vla-get-tempfilepath
			   (vla-get-files
			     (vla-get-preferences (vlax-get-acad-object))
			   )
			 )
		       )
		       "\\dlg.dcl"
	       ) ;_ end of strcat
	handle (open file "w")
  ) ;_ end of setq
  (foreach item
	   '("
set_spec : dialog {label = \"Óñòàíîâêà äàííûõ äëÿ ñïåöèôèêàöèè\";

:row{
:column {
:text {label = \"Èìÿ áëîêà: \";
	key = \"block_name\";
	width = \"40\";
	}
}
:column {
:popup_list{label=\"Íîìåð çàïèñè (0-10):\";
            key=\"spec_number\";
            edit_width=5;
            list = \"0\\n1\\n2\\n3\\n4\\n5\\n6\\n7\\n8\\n9\\n10\";
            is_default = true;
	    is_cancel = true;
           }
}
:column {
:button {
	key = \"clear\";
	label = \"Î÷èñòèòü\";
	is_default = true;
	is_cancel = true;
	}
}
}
:edit_box {label = \"Íàçâàíèå\";
           key = \"title\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Êîä\";
           key = \"code\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Åä.èçì\";
           key = \"ed\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Êîë.\";
           key = \"cnt\";
           edit_width=60;
           edit_limit = 1000;
          }   
ok_cancel;
}"	    )
    (write-line item handle)
  ) ;_ end of foreach
  (close handle)

   (setq name (ssname sel 0))

 ;Ïðåîáðàçóåì â vla-Îáúåêò
    (setq vla (vlax-ename->vla-object name))

  ;Íîìåð çàïèñè ïî óìîë÷àíèþ 0
  (if (or (not spec_number)(= spec_number "")) (setq spec_number "0"))
  
  ;×èòàåì ñâîéñòâî è çàïèñûâàåì â ïåðåìåííûå íàçâàíèå è êîä
    (setq sp (BlockLdata name (strcat "spec" spec_number)))

    (setq title (cdr (assoc "title" sp)))
    (setq code (cdr (assoc "code" sp)))
    (setq ed (cdr (assoc "ed" sp)))
    (setq cnt (cdr (assoc "cnt" sp)))
    

  (if (not sp) (setq sp ""))
  (if (not title) (setq title ""))
  (if (not code) (setq code ""))
  (if (not ed) (setq ed ""))
  (if (not cnt) (setq cnt ""))

 

;Çàãðóæàåì äèàëîã
  (setq dcl_id (load_dialog file))
  (if (< dcl_id 0)
    (progn
      (alert "Íå óäàëîñü çàãðóçèòü ôîðìó ïðèëîæåíèÿ")
      (exit)
    )
  )

  (if (not (new_dialog "set_spec" dcl_id))
    (progn
      (alert "Äèàëîãîâîå îêíî íå ìîæåò áûòü çàãðóæåíî!")
      (exit)
    )
  )

  (set_tile "title" title)
  (set_tile "code" code)
  (set_tile "ed" ed)
  (set_tile "cnt" cnt)
  (set_tile "spec_number" spec_number)

  (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object name)))
  (set_tile "block_name" (strcat "Èìÿ áëîêà: " strBlockName))
  

  (action_tile "cancel" "(done_dialog 0)")
  (action_tile "accept" "(setspec name)(done_dialog 1)")
  (action_tile "spec_number" "(setq spec_number (get_tile \"spec_number\"))(done_dialog 2)")
  (action_tile "clear" "(done_dialog 3)")

  
  (setq ddi (start_dialog))
  (unload_dialog dcl_id)
  
  (if (= ddi 0)(princ "\n Îòìåíåíî!\n"))
  (if (= ddi 1)(princ "\n Ñîõðàíåíî!\n"))
  (if (= ddi 2)(setSpecificationDialog sel))
  (if (= ddi 3)(clear name (atoi spec_number)))
(vla-endundomark active_document)
) ;end Defun


(Defun setspec(name / title code ed cnt spec_str)
    (setq title (get_tile "title"))
    (setq code (get_tile "code"))
    (setq ed (get_tile "ed"))
    (setq cnt (get_tile "cnt"))

    (setq spec
   (list
	(cons "title" title)
	(cons "code" code)
	(cons "ed"  ed)
	(cons "cnt" cnt)
    )
   )
  
  (BlockLdataPut name (strcat "spec" spec_number) spec)
  
);end Defun

(Defun ntos (n / typ sl ns is_point i isloop)
(setq typ (type n))
  (cond
	((= typ 'INT) (itoa n))
	((= typ 'STR) (ntos (atof n)))
	((= typ 'REAL) (progn
			(setq ns (rtos n 2 3))
			(setq sl (strlen ns))

			(setq i 1)
			(while (<= i sl)
			  (if (= (substr ns i 1) ".")(setq is_point T));end if
			  (setq i (1+ i))
			  );end while

			
			;Ïîêà ïîñëåäíèé ñèìâîë 0 èëè ".", îáðåçàåì åãî
			(setq isloop T)
			(if is_point
				(while (and isloop (or (= "0" (substr ns sl))(= "." (substr ns sl))))
				    (if (= "." (substr ns sl))(setq isloop nil))
				    (setq ns (substr ns 1 (1- sl))) 
				    (setq sl (strlen ns))
				);end while
			);end if
			
			ns
		        );end progn
	 )
  );end cond
);end Defun

(Defun C:clearSpecification()
  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)

	;Âûáèðàåì áëîê
  (setq sel (ssget "_:S" '((0 . "INSERT"))))
  (setq name (ssname sel 0))

  (BlockLdataPut name "spec" nil)
  (setq i 0)
  (while (<= i 10)
    (clear name i)
    (setq i (1+ i))
    )
   (princ "\nÑïåöèôèêàöèÿ áëîêà î÷èùåíà!\n")
  (princ)
(vla-endundomark active_document)
);end Defun

(Defun clear(name spec_number)
(BlockLdataPut name (strcat "spec" (itoa spec_number)) nil)
   (princ (strcat "\nÑïåöèôèêàöèÿ ¹" (itoa spec_number) " áëîêà î÷èùåíà!\n"))
  
  (princ)
);end Defun


; Syntax (BlockLdataPut "MyBlockName" "key" "value")
(defun BlockLdataPut (blk_ent key lstLdata / entBlockDefinition objBlockDefinition)
 (and
  (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object blk_ent)))
  (setq entBlockDefinition (tblobjname "block" strBlockName))
  (setq objBlockDefinition (vlax-ename->vla-object entBlockDefinition))
  (vlax-ldata-put objBlockDefinition key lstLdata)
 )
)

; Syntax (BlockLdata "MyBlockName" "key")
(defun BlockLdata (blk_ent key / entBlockDefinition objBlockDefinition)
 (if
  (and
   (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object blk_ent)))
   (setq entBlockDefinition (tblobjname "block" strBlockName))
   (setq objBlockDefinition (vlax-ename->vla-object entBlockDefinition))
  )
  (vlax-ldata-get objBlockDefinition key)
 )
)

 ;; Get Dynamic Block Property Value  -  Lee Mac
;; Returns the value of a Dynamic Block property (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)

(defun LM:getdynpropvalue ( blk prp )
    (setq prp (strcase prp))
    (vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'value)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Get Dynamic Block Properties  -  Lee Mac
;; Returns an association list of Dynamic Block properties & values.
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [lst] Association list of ((<prop> . <value>) ... )

(defun LM:getdynprops ( blk )
    (mapcar '(lambda ( x ) (cons (vla-get-propertyname x) (vlax-get x 'value)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Get Dynamic Block Property Allowed Values  -  Lee Mac
;; Returns the allowed values for a specific Dynamic Block property.
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)
;; Returns: [lst] List of allowed values for property, else nil if no restrictions

(defun LM:getdynpropallowedvalues ( blk prp )
    (setq prp (strcase prp))
    (vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'allowedvalues)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Toggle Dynamic Block Flip State  -  Lee Mac
;; Toggles the Flip parameter if present in a supplied Dynamic Block.
;; blk - [vla] VLA Dynamic Block Reference object
;; Return: [int] New Flip Parameter value

(defun LM:toggleflipstate ( blk )
    (vl-some
       '(lambda ( prp / rtn )
            (if (equal '(0 1) (vlax-get prp 'allowedvalues))
                (progn
                    (vla-put-value prp (vlax-make-variant (setq rtn (- 1 (vlax-get prp 'value))) vlax-vbinteger))
                    rtn
                )
            )
        )
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)


;; Get Visibility Parameter Name  -  Lee Mac
;; Returns the name of the Visibility Parameter of a Dynamic Block (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [str] Name of Visibility Parameter, else nil

(defun LM:getvisibilityparametername ( blk / vis )  
    (if
        (and
            (vlax-property-available-p blk 'effectivename)
            (setq blk
                (vla-item
                    (vla-get-blocks (vla-get-document blk))
                    (vla-get-effectivename blk)
                )
            )
            (= :vlax-true (vla-get-isdynamicblock blk))
            (= :vlax-true (vla-get-hasextensiondictionary blk))
            (setq vis
                (vl-some
                   '(lambda ( pair )
                        (if
                            (and
                                (= 360 (car pair))
                                (= "BLOCKVISIBILITYPARAMETER" (cdr (assoc 0 (entget (cdr pair)))))
                            )
                            (cdr pair)
                        )
                    )
                    (dictsearch
                        (vlax-vla-object->ename (vla-getextensiondictionary blk))
                        "ACAD_ENHANCEDBLOCK"
                    )
                )
            )
        )
        (cdr (assoc 301 (entget vis)))
    )
)





;; Get Dynamic Block Visibility State  -  Lee Mac
;; Returns the value of the Visibility Parameter of a Dynamic Block (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [str] Value of Visibility Parameter, else nil

(defun LM:getvisibilitystate ( blk )
    (LM:getdynpropvalue blk (LM:getvisibilityparametername blk))
)
----- добавлено через ~1 ч. -----
Код:
[Выделить все]
(Defun C:specification (/ sel len i spec_list name vla sp title code ed
			id spec_row tmp_row cnt new_row p1 p2 mas rows cols
			spec_table row col x1 y1 x2 y2 spec_number)
  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)
  
(defun get-all-atts (obj)
    ;;;Use (get-all-atts (car(entsel "\nSelect block:")))
    ;;;Returs list  (("TAG1" . "Value1")("TAG2" . "Value2") ...)
(vl-load-com)
    (if (= (type obj) 'ENAME)
		(setq obj (vlax-ename->vla-object obj)))
  (if (and obj
           (vlax-property-available-p obj 'Hasattributes)
	   (eq :vlax-true (vla-get-HasAttributes obj))
      )
    (vl-catch-all-apply
      (function
	(lambda	()
	  (mapcar (function (lambda (x)
			      (cons (vla-get-TagString x)
				    (vla-get-TextString x)
			      )
			    )
		  )
		  (append (vlax-invoke obj 'Getattributes)
			  (vlax-invoke obj 'Getconstantattributes)
		  )
	  )
	)
      )
    )
  )
)


 ;Выбираем блоки
  (setq sel (ssget '((0 . "INSERT"))))

 ;Количество выбранных элементов
  (setq len (SSLENGTH sel))
  (setq i 0)

  (setq spec_list nil)
 ;Цикл обработки выбранных объектов
  (while (< i len)
 ;Имя выбранного объекта
    (setq name (ssname sel i))

 ;Преобразуем в vla-Объект
    (setq vla (vlax-ename->vla-object name))

    (setq spec_number 0)
    (while (<= spec_number 10)
    
 ;Читаем свойство и записываем в переменные название и код
    (setq title "")
    (setq code "")
    (setq ed "")
    (setq cnt "1")

    ;Получаем спецификацию из блока
    (setq sp (BlockLdata name (strcat "spec" (itoa spec_number))))
(if sp (progn
	 
    (setq tmp (cdr (assoc "code" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq code (strcat code (eval n)))))
      (setq code tmp)
    )

    (setq tmp (cdr (assoc "ed" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST) 
    (foreach n read_tmp (progn (setq ed (strcat ed (eval n)))))
       (setq ed tmp)
    )

    (setq cnt "")
    (setq tmp (cdr (assoc "cnt" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq cnt (strcat cnt (eval n)))))
       (setq cnt tmp)
    )

    (setq tmp (cdr (assoc "title" sp)))
    (setq read_tmp (read tmp))
    (if (= (type read_tmp) 'LIST)
    (foreach n read_tmp (progn (setq title (strcat title (eval n)))))
	(setq title tmp)
    )
))
      (if (or sp (= spec_number 0))
	(progn
    ;Если название пустое, присваиваем имя блока
	  (if (not sp)(progn
    (if (or (not title)(= title "")) (setq title (vla-get-effectivename vla)))
    (if (not code) (setq code ""))
    (if (or (not ed)(= ed "")) (setq ed "шт"))
    (if (or (not cnt)(= cnt "")) (setq cnt "1"))
    		       );end progn
	    );end if

	  (if (/= title "")(progn
    (setq id (strcat title "_" code "_" ed))

 	;spec_row ("id блока" ("title" . "Название") ("code" . "Код")("ed" . "шт") 1)
    (setq
      spec_row (cons id
		     (list (cons "title" title) (cons "code" code)(cons "ed" ed) (atof cnt))
	       )
    )

 ;Собираем спецификацию
 ;Считаем элемент уникальным, если у него уникален id, получаем спецификацию
    (if	(setq tmp_row (assoc id spec_list))
      (progn
	(setq cnt (+ (last tmp_row) (atof cnt)))
	(setq new_row (cons id (list (cons "title" title) (cons "code" code)(cons "ed" ed) cnt)))
	(setq spec_list (subst new_row tmp_row spec_list))
      );end progn
      (setq spec_list (cons spec_row spec_list))
    );end if

    	);end progn
	);endif
    
	);end progn
	);endif
      (setq spec_number (1+ spec_number))
      );end while

    (setq i (1+ i))
  ) ;end while

  (setq spec_list (reverse spec_list))
  (setq spec_len (length spec_list))

  ;Запрашиваем точку для вставки таблицы
  (setq p1 (getpoint "Точка вставки таблицы\n"))
  (setq p2 (GETCORNER p1 "Ширина таблицы\n"))
  (setq mas (/ (abs (- (car p1)(car p2))) 185))
  (setq x1 (car p1))
  (setq y1 (cadr p1))
  (setq x2 (car p2))
  (setq y2 (cadr p2))

  (setq p1 (list (min x1 x2)(max y1 y2) 0))

  

  ;Создаём таблицу
  (setq rows 2)
  (setq cols 7)
  (setq spec_table (vla-AddTable 
                    model_space 
                    (vlax-3d-point p1)
                    rows
                    cols 
                    10
                    10))

  ;Настраиваем размеры ячеек
  (vla-SetColumnWidth spec_table 0 15)
  (vla-SetColumnWidth spec_table 1 60)
  (vla-SetColumnWidth spec_table 2 65)
  (vla-SetColumnWidth spec_table 3 10)
  (vla-SetColumnWidth spec_table 4 15)
  (vla-SetColumnWidth spec_table 5 20)
  (vla-SetColumnWidth spec_table 6 20)
  
  (vla-setText spec_table 0 0 "Спецификация элементов узла")
  (vla-setText spec_table 1 0 "Поз.")
  (vla-setText spec_table 1 1 "Обозначение")
  (vla-setText spec_table 1 2 "Наименование")
  (vla-setText spec_table 1 3 "Ед.изм")
  (vla-setText spec_table 1 4 "Кол-во.")
  (vla-setText spec_table 1 5 "Длина")
  (vla-setText spec_table 1 6 "гайка")
 

  ;Заполняем таблицу
  (vla-insertrows spec_table 2 10 spec_len)
  (setq row 1)
  (repeat spec_len
    (progn
      (setq tmp (cdr (nth (1- row) spec_list)))
      (setq title (cdr (assoc "title" tmp)))
      (setq code (cdr (assoc "code" tmp)))
      (setq ed (cdr (assoc "ed" tmp)))
      (setq cnt (last tmp))
      
      (vla-setText spec_table (+ row 1) 0 (itoa row))
      (vla-setText spec_table (+ row 1) 1 title)
      (vla-setText spec_table (+ row 1) 2 code)
      (vla-setText spec_table (+ row 1) 3 ed)
      (vla-setText spec_table (+ row 1) 4 (ntos cnt))
      
      (setq row (1+ row))
    )
   )

  ;Шрифт в ячейках
  (setq text_height 3)
  (vla-SetCellTextHeight spec_table 0 0 text_height)
  
  (setq row 1)
  (repeat (1+ spec_len)
    (progn
        (setq col 0)
  	(repeat cols
	  (progn
	    	;Высота текста
		(vla-SetCellTextHeight spec_table row col text_height)
		;Выравнивание текста
		(cond
		  ((or (= col 0)(= col 2)(= col 3)(= col 4)(= row 1)) (vla-setcellalignment spec_table row col acmiddlecenter))
		  ((or (= col 1)) (vla-setcellalignment spec_table row col acMiddleLeft))
		  (t nil)
		)
	 	(setq col (1+ col))
	  )
	)
      (setq row (1+ row))
     )
   )

  ;Масштабируем таблицу
  (vla-ScaleEntity spec_table (vlax-3d-point (car p1) (cadr p1) 0) mas)
  
(vla-endundomark active_document)
);end Defun

(Defun C:setspecification (/ sel)

 ;Выбираем блок
  (setq spec_number "0")
  (setq sel (ssget "_:S" '((0 . "INSERT"))))
  (setSpecificationDialog sel)

);end Defun

(Defun setSpecificationDialog (sel / file handle item name vla tmp
			   sp title code ed cnt dcl_id ddi)

  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)

  (setq	file   (strcat (vl-string-right-trim
			 "\\"
			 (vla-get-tempfilepath
			   (vla-get-files
			     (vla-get-preferences (vlax-get-acad-object))
			   )
			 )
		       )
		       "\\dlg.dcl"
	       ) ;_ end of strcat
	handle (open file "w")
  ) ;_ end of setq
  (foreach item
	   '("
set_spec : dialog {label = \"Установка данных для спецификации\";

:row{
:column {
:text {label = \"Имя блока: \";
	key = \"block_name\";
	width = \"40\";
	}
}
:column {
:popup_list{label=\"Номер записи (0-10):\";
            key=\"spec_number\";
            edit_width=5;
            list = \"0\\n1\\n2\\n3\\n4\\n5\\n6\\n7\\n8\\n9\\n10\";
            is_default = true;
	    is_cancel = true;
           }
}
:column {
:button {
	key = \"clear\";
	label = \"Очистить\";
	is_default = true;
	is_cancel = true;
	}
}
}
:edit_box {label = \"Название\";
           key = \"title\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Код\";
           key = \"code\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Ед.изм\";
           key = \"ed\";
           edit_width=60;
           edit_limit = 1000;
          }
:edit_box {label = \"Кол.\";
           key = \"cnt\";
           edit_width=60;
           edit_limit = 1000;
          }   
ok_cancel;
}"	    )
    (write-line item handle)
  ) ;_ end of foreach
  (close handle)

   (setq name (ssname sel 0))

 ;Преобразуем в vla-Объект
    (setq vla (vlax-ename->vla-object name))

  ;Номер записи по умолчанию 0
  (if (or (not spec_number)(= spec_number "")) (setq spec_number "0"))
  
  ;Читаем свойство и записываем в переменные название и код
    (setq sp (BlockLdata name (strcat "spec" spec_number)))

    (setq title (cdr (assoc "title" sp)))
    (setq code (cdr (assoc "code" sp)))
    (setq ed (cdr (assoc "ed" sp)))
    (setq cnt (cdr (assoc "cnt" sp)))
    

  (if (not sp) (setq sp ""))
  (if (not title) (setq title ""))
  (if (not code) (setq code ""))
  (if (not ed) (setq ed ""))
  (if (not cnt) (setq cnt ""))

 

;Загружаем диалог
  (setq dcl_id (load_dialog file))
  (if (< dcl_id 0)
    (progn
      (alert "Не удалось загрузить форму приложения")
      (exit)
    )
  )

  (if (not (new_dialog "set_spec" dcl_id))
    (progn
      (alert "Диалоговое окно не может быть загружено!")
      (exit)
    )
  )

  (set_tile "title" title)
  (set_tile "code" code)
  (set_tile "ed" ed)
  (set_tile "cnt" cnt)
  (set_tile "spec_number" spec_number)

  (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object name)))
  (set_tile "block_name" (strcat "Имя блока: " strBlockName))
  

  (action_tile "cancel" "(done_dialog 0)")
  (action_tile "accept" "(setspec name)(done_dialog 1)")
  (action_tile "spec_number" "(setq spec_number (get_tile \"spec_number\"))(done_dialog 2)")
  (action_tile "clear" "(done_dialog 3)")

  
  (setq ddi (start_dialog))
  (unload_dialog dcl_id)
  
  (if (= ddi 0)(princ "\n Отменено!\n"))
  (if (= ddi 1)(princ "\n Сохранено!\n"))
  (if (= ddi 2)(setSpecificationDialog sel))
  (if (= ddi 3)(clear name (atoi spec_number)))
(vla-endundomark active_document)
) ;end Defun


(Defun setspec(name / title code ed cnt spec_str)
    (setq title (get_tile "title"))
    (setq code (get_tile "code"))
    (setq ed (get_tile "ed"))
    (setq cnt (get_tile "cnt"))

    (setq spec
   (list
	(cons "title" title)
	(cons "code" code)
	(cons "ed"  ed)
	(cons "cnt" cnt)
    )
   )
  
  (BlockLdataPut name (strcat "spec" spec_number) spec)
  
);end Defun

(Defun ntos (n / typ sl ns is_point i isloop)
(setq typ (type n))
  (cond
	((= typ 'INT) (itoa n))
	((= typ 'STR) (ntos (atof n)))
	((= typ 'REAL) (progn
			(setq ns (rtos n 2 3))
			(setq sl (strlen ns))

			(setq i 1)
			(while (<= i sl)
			  (if (= (substr ns i 1) ".")(setq is_point T));end if
			  (setq i (1+ i))
			  );end while

			
			;Пока последний символ 0 или ".", обрезаем его
			(setq isloop T)
			(if is_point
				(while (and isloop (or (= "0" (substr ns sl))(= "." (substr ns sl))))
				    (if (= "." (substr ns sl))(setq isloop nil))
				    (setq ns (substr ns 1 (1- sl))) 
				    (setq sl (strlen ns))
				);end while
			);end if
			
			ns
		        );end progn
	 )
  );end cond
);end Defun

(Defun C:clearSpecification()
  (vl-load-com)
  (setq acad_object (vlax-get-acad-object))
  (setq active_document (vla-get-ActiveDocument acad_object))
  (setq model_space (vla-get-ModelSpace active_document))
  (vla-startundomark active_document)

	;Выбираем блок
  (setq sel (ssget "_:S" '((0 . "INSERT"))))
  (setq name (ssname sel 0))

  (BlockLdataPut name "spec" nil)
  (setq i 0)
  (while (<= i 10)
    (clear name i)
    (setq i (1+ i))
    )
   (princ "\nСпецификация блока очищена!\n")
  (princ)
(vla-endundomark active_document)
);end Defun

(Defun clear(name spec_number)
(BlockLdataPut name (strcat "spec" (itoa spec_number)) nil)
   (princ (strcat "\nСпецификация №" (itoa spec_number) " блока очищена!\n"))
  
  (princ)
);end Defun


; Syntax (BlockLdataPut "MyBlockName" "key" "value")
(defun BlockLdataPut (blk_ent key lstLdata / entBlockDefinition objBlockDefinition)
 (and
  (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object blk_ent)))
  (setq entBlockDefinition (tblobjname "block" strBlockName))
  (setq objBlockDefinition (vlax-ename->vla-object entBlockDefinition))
  (vlax-ldata-put objBlockDefinition key lstLdata)
 )
)

; Syntax (BlockLdata "MyBlockName" "key")
(defun BlockLdata (blk_ent key / entBlockDefinition objBlockDefinition)
 (if
  (and
   (setq strBlockName (vla-get-effectivename (vlax-ename->vla-object blk_ent)))
   (setq entBlockDefinition (tblobjname "block" strBlockName))
   (setq objBlockDefinition (vlax-ename->vla-object entBlockDefinition))
  )
  (vlax-ldata-get objBlockDefinition key)
 )
)

 ;; Get Dynamic Block Property Value  -  Lee Mac
;; Returns the value of a Dynamic Block property (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)

(defun LM:getdynpropvalue ( blk prp )
    (setq prp (strcase prp))
    (vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'value)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Get Dynamic Block Properties  -  Lee Mac
;; Returns an association list of Dynamic Block properties & values.
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [lst] Association list of ((<prop> . <value>) ... )

(defun LM:getdynprops ( blk )
    (mapcar '(lambda ( x ) (cons (vla-get-propertyname x) (vlax-get x 'value)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Get Dynamic Block Property Allowed Values  -  Lee Mac
;; Returns the allowed values for a specific Dynamic Block property.
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)
;; Returns: [lst] List of allowed values for property, else nil if no restrictions

(defun LM:getdynpropallowedvalues ( blk prp )
    (setq prp (strcase prp))
    (vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'allowedvalues)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;; Toggle Dynamic Block Flip State  -  Lee Mac
;; Toggles the Flip parameter if present in a supplied Dynamic Block.
;; blk - [vla] VLA Dynamic Block Reference object
;; Return: [int] New Flip Parameter value

(defun LM:toggleflipstate ( blk )
    (vl-some
       '(lambda ( prp / rtn )
            (if (equal '(0 1) (vlax-get prp 'allowedvalues))
                (progn
                    (vla-put-value prp (vlax-make-variant (setq rtn (- 1 (vlax-get prp 'value))) vlax-vbinteger))
                    rtn
                )
            )
        )
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)


;; Get Visibility Parameter Name  -  Lee Mac
;; Returns the name of the Visibility Parameter of a Dynamic Block (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [str] Name of Visibility Parameter, else nil

(defun LM:getvisibilityparametername ( blk / vis )  
    (if
        (and
            (vlax-property-available-p blk 'effectivename)
            (setq blk
                (vla-item
                    (vla-get-blocks (vla-get-document blk))
                    (vla-get-effectivename blk)
                )
            )
            (= :vlax-true (vla-get-isdynamicblock blk))
            (= :vlax-true (vla-get-hasextensiondictionary blk))
            (setq vis
                (vl-some
                   '(lambda ( pair )
                        (if
                            (and
                                (= 360 (car pair))
                                (= "BLOCKVISIBILITYPARAMETER" (cdr (assoc 0 (entget (cdr pair)))))
                            )
                            (cdr pair)
                        )
                    )
                    (dictsearch
                        (vlax-vla-object->ename (vla-getextensiondictionary blk))
                        "ACAD_ENHANCEDBLOCK"
                    )
                )
            )
        )
        (cdr (assoc 301 (entget vis)))
    )
)





;; Get Dynamic Block Visibility State  -  Lee Mac
;; Returns the value of the Visibility Parameter of a Dynamic Block (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; Returns: [str] Value of Visibility Parameter, else nil

(defun LM:getvisibilitystate ( blk )
    (LM:getdynpropvalue blk (LM:getvisibilityparametername blk))
Миниатюры
Нажмите на изображение для увеличения
Название: gifspec.gif
Просмотров: 82
Размер:	1.40 Мб
ID:	185236  
Вложения
Тип файла: lsp hspec.lsp (16.6 Кб, 24 просмотров)
Sergey91@06 вне форума  
 
Непрочитано 21.03.2017, 09:49
#3289
valerik88


 
Регистрация: 02.07.2016
Сообщений: 249


Это же моя программа отсюда, только кем то переделаная
http://forum.dwg.ru/showthread.php?t=132979
Имя блока вставляется только для тех блоков, к которым не была ранее применена функция setspecification
С помощью команды setspecification можно настроить любой блок, что бы он в спецификацию что угодно выдавал.

Можно в строки "Название", "Код", "кол-во" вставлять autolisp код, который будет возвращать нужную информацию. В момент исполнения функции specification этот код из блоков исполнится и вставит в таблицу то что нужно.
Например у меня в блоках вставлены такие строки:
Код:
[Выделить все]
 ("Полка-" (rtos (getpropertyvalue name "AcDbDynBlockPropertylength") 2 0) "-10")
- возвращает значение динамического параметра "length"
Код:
[Выделить все]
 ((LM:getvisibilitystate vla))
- возвращает значение Видимости блока
Скинь свои блоки и укажи, что должно выдаваться в спецификации, я попробую сделать для примера один или 2 блока тебе.

Последний раз редактировалось valerik88, 21.03.2017 в 12:41.
valerik88 вне форума  
 
Непрочитано 21.03.2017, 16:28
#3290
Sergey91@06


 
Регистрация: 15.06.2014
Сообщений: 10


valerik88, а можешь расписать что куда именно прописать нужно(хочется самому научится ловить рыбу, т.е. попробовать понять ка как это работает, чтобы если необходимо будет внести какие-то корректировки самому можно было сделать), передо мной стоит задача - сделать чтобы несколько кнопок, которые немного ускорят мою работу:, т.е. хочу добавить потом ещё 2 аналогичные команды, отличатся будут они только определенным атрибутом - в столбце артикул. Но это все лирика, сейчас подробнее по примеру:
Нужно чтобы в столбец "обозначение" прописывалась "видимость" блока, в столбец "артикул" атрибут "_Article_galv", В столбец "длина" соответственно длина блока(если есть), ещё наверное условие какое-то нужно сделать, чтобы отдельно считались и нумеровались одинаковые блоки с разной длиной, также вопросы по lisp-таблице, как шрифт на программном уровне поменять и сделать чтобы длину таблицы не нужно было показывать а только точку вставки, длина автоматически по ГОСТ 1850мм.
Вложения
Тип файла: dwg
DWG 2004
блоки пример.dwg (578.2 Кб, 21 просмотров)
Sergey91@06 вне форума  
 
Непрочитано 22.03.2017, 10:24
1 | #3291
valerik88


 
Регистрация: 02.07.2016
Сообщений: 249


Sergey91@06, Вот сделал для примера 1 блок
Что бы всё понять, примени команду setspecification для блока, увидишь, что каждое поле вычисляется отдельным кодом:
Для наименования - ((LM:getvisibilitystate vla)) вставляет в спецификацию значение видимости блока
для кода - ((getpropertyvalue name "AcDbDynBlockProperty_Article_galv")) - вставляет атрибут _Article_galv
для единиц измерения - ((rtos (getpropertyvalue name "AcDbDynBlockPropertyРасстояние5") 2 0)) - вставляет длину консоли

В твоей программе добавлены столбцы Длина и Гайка, но в программе в них ни чего не заносится, поэтому для примера я вставил в поле Ед.изм. значение длины. Что бы вставлялось в нужное поле, придётся программу дорабатывать, но это время, поэтому я только советом помочь смогу.

Стоит отметить, что программа не совсем безопасна, т.к. в блок можно добавить любой код, который выполнится при использовании команды specification, поэтому предполагается, что программа для личного пользования и брать чужие блоки не безопасно.

Цитата:
также вопросы по lisp-таблице, как шрифт на программном уровне поменять
В программе есть строка
Код:
[Выделить все]
;Шрифт в ячейках
(setq text_height 3)
А стиль вроде ставится тот который установлен в данный момент (могу ошибаться)
Цитата:
сделать чтобы длину таблицы не нужно было показывать а только точку вставки, длина автоматически по ГОСТ 1850мм.
Для этого надо убрать строку
Код:
[Выделить все]
;Масштабируем таблицу
(vla-ScaleEntity spec_table (vlax-3d-point (car p1) (cadr p1) 0) mas)
Ну и запрос второй точки не нужен становится

Цитата:
В данный момент LISP код читает только блоки первого уровня, любопытно рассмотреть вариант выгрузки в таблицу блоков вложенных в другие блоки.
Для этого просто через команду setspecification нужно забить несколько номеров записей (там выпадающим списком выбираешь номер и забиваешь новую спецификацию)
Вложения
Тип файла: dwg
DWG 2013
блоки пример.dwg (594.1 Кб, 30 просмотров)

Последний раз редактировалось valerik88, 22.03.2017 в 10:58.
valerik88 вне форума  
 
Непрочитано 04.04.2017, 08:02
#3292
aTBepTKa


 
Регистрация: 16.11.2008
Сообщений: 55


*удалить

Последний раз редактировалось aTBepTKa, 04.04.2017 в 08:15.
aTBepTKa вне форума  
 
Непрочитано 05.04.2017, 12:55
#3293
Sergey91@06


 
Регистрация: 15.06.2014
Сообщений: 10


valerik88, спасибо огромное за разъяснения. в общем и целом понял как работает данный LISP(т.е. есть несколько переменных которым мы даем соответствующие значения атрибута, после чего выводим в таблицу), программа очень хорошая, но меня как я теперь понял интересуют более простые и приземленные вещи. Например есть у меня база блоков, штук 300, я переименовываю в них атрибуты, чтобы одинаково назывались: _visibility, _lenght, _article_galv и другое. А потом выполняю команду: и как итог имею таблицу, где элементы автоматически нумеруются(притом если у элементов с одинаковыми атрибутами _visibility, _article_galv отличается параметр _lenght, то это должна быть уже другая позиция) и в столбец "наименование" попадает значение атрибута _visibility, "длина"(если есть) - _lenght, _article_galv - "артикул". Насколько я понимаю в таком случае LISP не будет запускать никакие LISP или макросы прописанные в блоки, что является более безопасным. Если встречалось что-то подобное или есть понимание как это реализовать, то буду крайне благодарен
Sergey91@06 вне форума  
 
Непрочитано 06.04.2017, 08:43
#3294
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Sergey91@06, ты не пробовал attin / attout или его аналог?
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 06.04.2017, 09:49
#3295
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 11,004


Цитата:
Сообщение от Sergey91@06 Посмотреть сообщение
А потом выполняю команду: и как итог имею таблицу, где элементы автоматически нумеруются(притом если у элементов с одинаковыми атрибутами _visibility, _article_galv отличается параметр _lenght, то это должна быть уже другая позиция) и в столбец "наименование" попадает значение атрибута _visibility, "длина"(если есть) - _lenght, _article_galv - "артикул".
Непонятна только автоматическая нумерация (что именно имеет в виду автор), видимости, атрибуты и прочее выводятся стандартным извлечением данных.
Сергей812 вне форума  
 
Непрочитано 06.04.2017, 09:56
#3296
Sergey91@06


 
Регистрация: 15.06.2014
Сообщений: 10


Кулик Алексей aka kpblc, идея близка, но все же не то, т.к. у моих блоков могут быть и 10 атрибутов например, но выгружать на команду он должен только определенные, названия которых я прописываю в коде. И я хочу сделать 2 альтернативные кнопки: а)создает таблицу внутри файла б)создает внешний exel(svc) файл с аналогичной таблицей, таблица должна быть ГОСТовской, т.е. иметь определенные размеры. Сейчас начал курсы LISP изучать, возможно я скоро сам пойму как это сделать, если все получится то поделюсь наработками
Sergey91@06 вне форума  
 
Непрочитано 06.04.2017, 10:00
#3297
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Ну, в принципе код открыт - отфильтровать атрибуты можно хоть внутри кода, хоть при обработке готового файла, хоть где.
Один маленький, но серьезный момент: потребуются хендлы блоков, чтобы их можно было идентифицировать. А это гарантирует "негостовскость" таблицы.
Можно на сайте Lee Mac посмотреть - кажется, у него там были очень интересные нумераторы.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 17.04.2017, 06:07
#3298
Red Nova

ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Регистрация: 23.10.2007
Торонто
Сообщений: 1,980
Отправить сообщение для Red Nova с помощью Skype™


Доброго!
Есть ли у кого опыт по созданию полей со ссылкой на дин блок? (в лиспе естественно)
Научился манипулировать всеми параметрами дин. блока и содержимым атрибутов, но с полями пока не работал.

Собственно задача:
Есть исходный динамический блок с атрибутами. Кроме него есть блок маркер в котором только один атрибут.
Требуется создать в атрибуте блока маркера поля в перемешку с текстом, поля ссылаются на дин. параметры и атрибуты исходного блока.

Прикрепляю пример. В примере я мухлюю, и использую атрибут самого исходного блока, вокруг которого рисуется рамка маркера (блок маркера в примере вовсе не имеет атрибута).
А хочется сделать по человечески

Подскажите в каком направлении копать?
Заранее спасибо.
Вложения
Тип файла: dwg
DWG 2013
example.dwg (295.6 Кб, 19 просмотров)
__________________
Блог
Red Nova вне форума  
 
Непрочитано 17.04.2017, 06:19
#3299
Boxa

КЖ; C#
 
Регистрация: 03.11.2005
Санкт-Петербург
Сообщений: 2,588


В лисп с полями довольно просто... Вы руками сначала нужное поле создайте, потом посмотрите на него и увидите, что там objectID акрибута имеется и его свойство... по образу и подобию формируйте строку для других блоков, меняя ID и будет Вас счастье.... Путано как то сказал, но идея я думаю понятна.
Boxa вне форума  
 
Автор темы   Непрочитано 18.04.2017, 05:58
#3300
Red Nova

ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Регистрация: 23.10.2007
Торонто
Сообщений: 1,980
Отправить сообщение для Red Nova с помощью Skype™


Спасибо. Таким методом работают ссылки на дин. свойства но не на атрибуты.
На основе одного из кодов от VVA настряпал такой вот тестовый код для атрибутов.
Вот только при записи поля в другой атрибут сперва содержание отображается как ####, а корректное поле появляется только после регенерации.
При этом, если записывать поле не в атрибут блока а в текст, то все отображается сразу ОК.
Мне бы очень хотелось не использовать регенерацию, так как файлы тяжелые а операция довольно частая.
Может кто подскажет возможно ли это и как?

Код:
[Выделить все]
 (defun c:testwithblock (/ CSblk vlaCSblk attlst fld TAGblk vlaTAGblk)
  (vl-load-com)
  (setq CSblk (ssget "_:S" '((0 . "INSERT")(66 . 1))))
  (setq vlaCSblk (car (LM:ss->vla CSblk)))
  (setq attlst (get-all-atts vlaCSblk))
  (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                (vl-princ-to-string(Get-ObjectID-x86-x64 (caddr (assoc "BAY" attlst))))
                                ">%).TextString>%"
                                ))
  (setq TAGblk (ssget "_:S" '((0 . "INSERT")(66 . 1))))
  (setq vlaTAGblk (car (LM:ss->vla TAGblk)))
  (LM:vl-setattributevalue vlaTAGblk "LONGTAG" fld)
  )

(defun c:testwithtext (/ CSblk vlaCSblk attlst fld pt)
  (vl-load-com)
  (setq CSblk (ssget "_:S" '((0 . "INSERT")(66 . 1))))
  (setq vlaCSblk (car (LM:ss->vla CSblk)))
  (setq attlst (get-all-atts vlaCSblk))
  (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                (vl-princ-to-string(Get-ObjectID-x86-x64 (caddr (assoc "BAY" attlst))))
                                ">%).TextString>%"
                                ))
  (setq pt (getpoint "\nSpecify First Corner of MText Object: "))
  (command "._MTEXT" pt pause fld "")
  )


(defun Get-ObjectID-x86-x64 (obj / util)
  (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
  (if (= (type obj) 'VLA-OBJECT)
     (if (> (vl-string-search "x64" (getvar "platform")) 0)
       (vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
       (rtos (vla-get-objectid obj) 2 0)
     )
  )
)

(defun get-all-atts (obj)
  (if (and obj
    (eq :vlax-true (vla-get-HasAttributes obj))
    (vlax-property-available-p obj 'Hasattributes)
    
      )
    (vl-catch-all-apply
      (function
 (lambda ()
   (mapcar (function (lambda (x)
         (list (vla-get-TagString x)
	       (bg:get-TextString (vlax-vla-object->ename x))
                                    x
         )
       )
    )
    (append (vlax-invoke obj 'Getattributes)
     (vlax-invoke obj 'Getconstantattributes)
    )
   )
 )
      )
    )
  )
)

(defun LM:vl-setattributevalue ( blk tag val )
    (setq tag (strcase tag))
    (vl-some
       '(lambda ( att )
            (if (= tag (strcase (vla-get-tagstring att)))
                (progn (vla-put-textstring att val) val)
            )
        )
        (vlax-invoke blk 'getattributes)
    )
)


__________________
Блог

Последний раз редактировалось Red Nova, 23.04.2017 в 18:57.
Red Nova вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)

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

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
LISP. Вставка в таблицу поля, соотвествующего площади примитива Profan Готовые программы 272 06.06.2021 23:12
Сейсмозащита и сейсмоизоляция существующих, построенных зд. IANationalInformAgentstvo Прочее. Архитектура и строительство 216 20.01.2015 16:51
Мониторы LCD CRT Разное 94 17.06.2008 10:51
ЮМОР 2006 =) Perezz!! Разное 1122 04.01.2007 00:46