Lisp. авто-нумерация атрибута блока.

DonJad · 23.10.2014, 01:25

Давным давно нашел здесь на DWG один чудесный лисп:

Код:

 (defun C:KlampNum (/ *error* adoc att_list axss blk_list fpt num oaq oat oqa osm sort_list spt test_list cm) 
  (vl-load-com) 
  (defun *error* (error) 
    (cond ((not error)) 
          ((wcmatch (strcase error) "*QUIT*,*CANCEL*")) 
          (1 (princ (strcat "\nERROR: " error)))) 
    (setvar "osmode" osm)  (setvar "attdia" oat) 
    (setvar "attreq" oaq) (setvar "qaflags" oqa) 
    (setvar "cmdecho" 1) (vla-endundomark adoc) 
    (princ));defun 
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
  (vla-endundomark adoc) 
  (vla-startundomark adoc) 
  (setvar "cmdecho" 0) 
  (setq oat (getvar "attdia") osm (getvar "osmode") 
        oaq (getvar "attreq") oqa (getvar "qaflags")) 
  (setvar "attdia" 0);Выводятся запросы в командной строке (окно подавляется) 
  (setvar "attreq" 0);Для каждого атрибута не выдается запрос значения    
  (setvar "qaflags" 0);Запрет вывода на экран окон предупреждений, перенос их в командную строку  
  (setvar "osmode" 0) 
  (setq fpt (getpoint "\nПервый угол рамки выбора >> \n") 
               spt (getcorner fpt "\nВторой угол рамки выбора >> \n")) 
    (if (ssget "_W" fpt spt (list (cons 0 "INSERT") (cons 2 "Klamp") (cons 66 1))) 
      (progn (initget 4) 
        (setq num (getint "\n\t >> Начальный номер [Enter для продолжения] : ")) 
        (if (not num) (setq num (if *last_number* *last_number* 
                            (getint "\n\t >> Первый раз номер задается обязательно  : ")))) 
        (setq axss (vla-get-activeselectionset adoc)) 
        (vlax-for a axss (setq blk_list (cons a blk_list))) 
        (initget "Вперед Назад") 
        (setq dir (getkword "\nНаправление [Вперед/Назад]: <Вперед>")) 
        (if (null dir) (setq dir "Вперед")) 
        (if (= dir "Вперед") (setq cm <) (setq cm >))  
        (setq test_list (mapcar '(lambda (x) (vlax-get x 'Insertionpoint)) blk_list) 
              sort_list (vl-sort blk_list '(lambda (e1 e2) 
                          (if (vl-every '(lambda (x) (equal (cadr x) (cadar test_list) 0.1)) test_list) 
                            (cm (abs (- (car fpt) (car (vlax-get e1 'Insertionpoint)))) 
                               (abs (- (car fpt) (car (vlax-get e2 'Insertionpoint))))) 
                            (cm (abs (- (cadr fpt) (cadr (vlax-get e1 'Insertionpoint)))) 
                               (abs (- (cadr fpt) (cadr (vlax-get e2 'Insertionpoint)))))))));setq 
        (foreach blk_obj sort_list 
          (if (and (vlax-property-available-p blk_obj 'Hasattributes) 
                   (vlax-read-enabled-p blk_obj) (vlax-write-enabled-p blk_obj)) 
            (progn (setq att_list (vlax-invoke blk_obj 'Getattributes)) 
              (foreach at att_list 
                (if (eq (vla-get-tagstring at) "NUM") 
                  (progn (vla-put-textstring at (itoa num)) 
                    (vla-update at) (vla-update blk_obj))))));if 
          (setq num (1+ num)));foreach 
        (vla-clear axss) (vla-delete axss) 
        (vlax-release-object axss) (setq axss nil) 
        (setq blk_list nil)));if 
  (setq *last_number* num) 
  (vla-regen adoc acactiveviewport) 
  (*error* nil) 
  (princ) 
);end 
(prompt "\n Нумерация блока Klamp, в командной строке набери KlampNum \n") 
(princ)

Сам в Лиспе не силён, но эта штука сподвигла поучиться.

В данной модификации меняет значение атрибута NUM в выбранных вхождениях блока Klamp.
Функция очень спасает. Но хочется её немного улучшить. Добавить возможность выбора блока на лету. Т.е. в процессе выполнения функции добавить вариант выбора текущего блока.

сначала добавил вариант когда пользователь просто вводит желаемое имя блока.

Код:

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

   (setq blockName(getstring T "\n Enter block name: "))

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

Соответственно ковыряюсь в лиспе дальше, пока не придумал ничего лучше чем вот такое:

Код:

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

   
  (setq next t); добавляем буль для цикла
  (while next ;запускаем цикл
  (initget "Block Блок B Б B B B B");добавляем пользователю выбор
  (setq fpt (getpoint "\nПервый угол рамки выбораa [Блок] >> \n") ; соответственно теперь пользователь может ввести B либо выбрать точку
               spt (getcorner fpt "\nВторой угол рамки выбора >> \n")) ; вторая точка
	(cond ; тут мы добавляем обработчик для исключения, либо выполняем команду по старому.
	((= fpt "B")(setq blocName (entget (entsel "\nPick Block with NUM attribute >> \n"))));тут я хочу чтобы пользователь выбрал объёкт, и если это блок
                       ;;; то его имя будет записано в переменную blockName
        ((listtp fpt) ; если точка, то идем по стандартной функции.
          (if (ssget "_W" fpt spt (list (cons 0 "INSERT") (cons 2 blcName) (cons 66 1)))

соответственно вопрос, как с помощью entget получить имя блока из вхождения блока выбранного пользователем.

Спасибо!

Дима_ · 23.10.2014, 01:35

Цитата:

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

как с помощью entget получить имя блока из вхождения блока выбранного пользователем

Если именно через entget то (cdr (assoc 2 ...)), но на динамический блок вернет имя автоматически созданного вхождения, а не описания блока, так что возможно потребуется (vla-get-effectivename ...) - через dxf его копать долго да и незачем.

DonJad · 23.10.2014, 01:45

Цитата:

Сообщение от Дима_

Если именно через entget то (cdr (assoc 2 ...)), но на динамический блок вернет имя автоматически созданного вхождения, а не описания блока, так что возможно потребуется (vla-get-effectivename ...) - через dxf его копать долго да и незачем.

Я их для динамики и не использую так, что подойдёт и entget.

однако, если правильно понял должно быть как-то так:

(setq blcName (cdr (assoc 2 (entget (entsel "\nPick Block with NUM attribute >> \n")))))

но даёт ошибку:
; error: bad argument type: lentityp (<Entity name: 7ffffb70dd0> (-749.643
484.27 0.0))

nolte · 23.10.2014, 03:06

Автокад выдал подсказку

lentityp (<Entity name: 7ffffb70dd0> (-749.643
484.27 0.0

Entsel возвращает список, состоящий из примитива и координаты точки куда тыркнули, а entget-y требуется только примитив.

Profan · 23.10.2014, 06:30

car забыл.

DonJad · 23.10.2014, 10:41

Ура! Получилось. Спасибо. Теперь следущий вопрос. Что-то я с функцией cond натворил, и судя по всему что-то не то:

Код:

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

 
(defun blName ()
(cdr (assoc 2 (entget (car (entsel "\nPick Block with NUM attribute >> \n")))))
)

(defun C:NumTest (/ *error* adoc att_list axss blk_list next fpt num blockName oaq oat oqa osm sort_list spt test_list cm) 
  (vl-load-com) 
  (defun *error* (error) 
    (cond ((not error)) 
          ((wcmatch (strcase error) "*QUIT*,*CANCEL*")) 
          (1 (princ (strcat "\nERROR: " error)))) 
    (setvar "osmode" osm)  (setvar "attdia" oat) 
    (setvar "attreq" oaq) (setvar "qaflags" oqa) 
    (setvar "cmdecho" 1) (vla-endundomark adoc) 
    (princ));defun 
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
  (vla-endundomark adoc) 
  (vla-startundomark adoc) 
  (setvar "cmdecho" 0) 
  (setq oat (getvar "attdia") osm (getvar "osmode") 
        oaq (getvar "attreq") oqa (getvar "qaflags")) 
  (setvar "attdia" 0);Выводятся запросы в командной строке (окно подавляется) 
  (setvar "attreq" 0);Для каждого атрибута не выдается запрос значения    
  (setvar "qaflags" 0);Запрет вывода на экран окон предупреждений, перенос их в командную строку  
  (setvar "osmode" 0) 
  
  (setq next t);переменная для цикла в true
  (while next
	(initget "Block B B B")
	(setq fpt (getpoint "\nПервый угол рамки выбора [Block] >> \n")) 
	(cond ;обработчик типа  case

	((= fpt "B")(setq blockName (blName)));подхватываем имя блока
	((list fpt)	   ;нумеруем блоки
    ( (setq spt (getcorner fpt "\nВторой угол рамки выбора >> \n")) 
	(if (ssget "_W" fpt spt (list (cons 0 "INSERT") (cons 2 blockName) (cons 66 1))) 
      (progn (initget 4) 
        (setq num (getint "\n\t >> Начальный номер [Enter для продолжения] : ")) 
        (if (not num) (setq num (if *last_number* *last_number* 
                            (getint "\n\t >> Первый раз номер задается обязательно  : ")))) 
        (setq axss (vla-get-activeselectionset adoc)) 
        (vlax-for a axss (setq blk_list (cons a blk_list))) 
        (initget "Вперед Назад") 
        (setq dir (getkword "\nНаправление [Вперед/Назад]: <Вперед>")) 
        (if (null dir) (setq dir "Вперед")) 
        (if (= dir "Вперед") (setq cm <) (setq cm >))  
        (setq test_list (mapcar '(lambda (x) (vlax-get x 'Insertionpoint)) blk_list) 
              sort_list (vl-sort blk_list '(lambda (e1 e2) 
                          (if (vl-every '(lambda (x) (equal (cadr x) (cadar test_list) 0.1)) test_list) 
                            (cm (abs (- (car fpt) (car (vlax-get e1 'Insertionpoint)))) 
                               (abs (- (car fpt) (car (vlax-get e2 'Insertionpoint))))) 
                            (cm (abs (- (cadr fpt) (cadr (vlax-get e1 'Insertionpoint)))) 
                               (abs (- (cadr fpt) (cadr (vlax-get e2 'Insertionpoint)))))))));setq 
        (foreach blk_obj sort_list 
          (if (and (vlax-property-available-p blk_obj 'Hasattributes) 
                   (vlax-read-enabled-p blk_obj) (vlax-write-enabled-p blk_obj)) 
            (progn (setq att_list (vlax-invoke blk_obj 'Getattributes)) 
              (foreach at att_list 
                (if (eq (vla-get-tagstring at) "NUM") 
                  (progn (vla-put-textstring at (itoa num)) 
                    (vla-update at) (vla-update blk_obj))))));if 
          (setq num (1+ num)));foreach 
        (vla-clear axss) (vla-delete axss) 
        (vlax-release-object axss) (setq axss nil) 
        (setq blk_list nil)));if 
		(setq *last_number* num) 
		(vla-regen adoc acactiveviewport) 
		)
		);cond list end
		((null fpt)(setq next nil));выход из цикла в случае если нет значений в первой точке. 
		);end cond
		);end while
		
  (*error* nil) 
  (princ) 
);end 
(prompt "\n Нумерация блока Variable, в командной строке набери NumTest \n") 
(princ)

выдает ошибку:
NumberTest2.lsp successfully loaded.
Command: ; error: malformed list on input

UPD: Исправил. Спасибо Klo.

Но теперь при запуске при вводе первой точки (fpt) в любых вариантах дает ошибку: ERROR: bad point argument

Klo · 23.10.2014, 10:54

Сообщение об ошибке говорит за себя: неправильный список на вводе. То есть где-то потеряна скобка или что-то в этом роде...

Nike · 23.10.2014, 10:57

http://dwg.ru/dnl/1929

DonJad · 23.10.2014, 11:08

Цитата:

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

http://dwg.ru/dnl/1929

Спасибо!
Но лисп мне как-то милее. Заодно хороший повод разобраться.

DonJad · 25.10.2014, 02:35

Код:

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

 (setq fpt(getpoint))
(setq spt(getcorner fpt))
(setq tt (ssget "W" fpt spt '((0 . "INSERT"))))
(setq tt1 (ssget "W" fpt spt '((2 . "*U201"))))
(setq tt2 (ssget "W" fpt spt '((2 . "Shina"))))
(setq tt3 (ssget "W" fpt spt '((2 . "Terminal"))))

Таки столкнулся с динамическими блоками. Если у кого найдется минутка, разъясните, как их получить то?

вот накатал небольшой тест для собственного понимания вопрса.
в tt - помещаются все блоки
в tt1 и tt2 - пытаюсь получить ссылку на динамический блок shina, вхождения которого почему то имеют имя *U201, впрочем и так и эдак возвращается nil.
в tt3 - попадают обычные блоки с названием "terminal"

при этом в tt - вижу и блоки terminal и *U201...
как мне в tt1 или tt2 получить, что-то отличное от nil?

nolte · 26.10.2014, 02:04

подсмотри тут про работу с блоками.
вот такa вот функция поможет тебе вытащить все блоки (динамические в том числе) с именем определенным.
пример вызова: (test_bl <name block>)

Код:

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

 
(defun test_bl (nam / lst)
(vl-load-com)
(setq doc(vla-get-activedocument(vlax-get-acad-object)))
(vlax-for lay (vla-get-layouts doc)
	(vlax-for i (vla-get-block lay)
		(if(eq(vla-get-effectivename i) nam)(setq lst(cons i lst)))
	)
)
lst
)

правда на выходе ты получишь список VLA-OBJECT's блоков.

или это должно работать тоже

Код:

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

 
(defun test_b2 (nam / i ent sset lst_ent)
(setq sset(ssget "_W" (getpoint)(getpoint)(list(cons 0 "INSERT"))))
(repeat (setq i(sslength sset))
	(setq ent(ssname sset (setq i(1- i))))
	(if
		(or
			(= (cdr(assoc 2 (entget ent))) nam)
			(=(cdr(assoc 2 (tblnext "BLOCK" (cdr(assoc 2 (entget ent)))))) nam)
		)
		(setq lst_ent(cons ent lst_ent))
	)
)
lst_ent
)

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Назначение свойств атрибутов блока без attsync	Кулик Алексей aka kpblc	Программирование	9	15.08.2017 06:32
Проблема с базовой точкой блока и вхождением блока в DXF	nogaems	Программирование	5	29.08.2013 15:46
Извлечение атрибутов блока и вставка атрибутов в формулу	andery	AutoCAD	38	15.06.2009 02:39
Редактирование блока, используя значение его атрибутов	Mazai	Программирование	14	19.01.2009 20:49
Изменение характеристик атрибутов в вхождении блока	zenon	AutoCAD	9	27.11.2008 14:43