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

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Замена динамических блоков

Замена динамических блоков

Ответ
Поиск в этой теме
Непрочитано 17.08.2011, 17:56
Замена динамических блоков
Serge_Y
 
инженер-конструктор
 
Минск
Регистрация: 29.05.2004
Сообщений: 381

День добрый!
А можно ли создать программу, которая бы меняла один динамический блок на другой с учетом уже всех выполненных трансформаций исходного блока? Например, есть два динамических блока, которые отличаются только цветом примитивов. Произведя изменение первого блока (например растянув его, повернув, и т.д.) нужно заменить его другим блоком, но так, чтобы все изменения в геометрии остались.
Спасибо
Просмотров: 29323
 
Непрочитано 25.09.2011, 21:59
#21
GreyCard


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


у меня почему то эта программа не определяется. Акад пишет, что он не "знает" функции bchange, хотя лисп-файл я подгрузил. Кстати у меня Акад 2007, может из за этого? Попробую эту прогу на другой версии Када.
GreyCard вне форума  
 
Непрочитано 26.09.2011, 08:24
#22
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


Цитата:
Сообщение от GreyCard Посмотреть сообщение
Кстати у меня Акад 2007, может из за этого?
Должна работать во всех версиях, начиная с 2006.
Do$ вне форума  
 
Непрочитано 26.09.2011, 09:19
#23
TararykovDG

Программист-энтузиаст
 
Регистрация: 17.07.2009
Воронеж
Сообщений: 571


Цитата:
Сообщение от Do$ Посмотреть сообщение
Должна работать во всех версиях, начиная с 2006.
Do$, должна и будет работать, если в одной строке добавить недостающую скобку
Код:
[Выделить все]
(vla-StartUndoMark (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))))
__________________
cadtools
TararykovDG вне форума  
 
Непрочитано 26.09.2011, 10:18
#24
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


Ага, снова невнимательность... Перезалил файл.
Do$ вне форума  
 
Непрочитано 26.09.2011, 21:38
#25
GreyCard


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


Все заработало. Сейчас поюзаю, посмотрю. Большое спасибо.
попробовал. Эта тема уже обсуждалась в этом форуме, но в другой программе. Дело в том, что в моем случае необходимо:
1 выбирать блок, на который происходит замена в дальнейшем, вручную (путем выделения именно этого блока на чертеже). - это в программке учтено.
2 выбирать блок (или блоки), который будет заменен при помощи области выделения (потянули стрелочкой и выделили целое поле в котором находятся блоки)
3 выбрать блок и затем автоматически перебирать ВСЕ ВСЕ блоки с этим (выделенным ранее) именем в чертеже, которые затем буду заменены.(т.е заменить на чертеже все блоки с именем "1" на блоки с именем "2")

Последний раз редактировалось GreyCard, 26.09.2011 в 22:19. Причина: опробовал программку.
GreyCard вне форума  
 
Непрочитано 27.09.2011, 13:24
#26
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


Это все можно сделать, и довольно несложно, но я сейчас этим не буду заниматься - нет времени.
Do$ вне форума  
 
Непрочитано 28.09.2011, 11:27
#27
gizmo_zx

Проектировщик ЭО,ЭМ, ЭОС
 
Регистрация: 18.07.2007
Нижний Новгород
Сообщений: 256
<phrase 1= Отправить сообщение для gizmo_zx с помощью Skype™


Цитата:
Сообщение от Do$ Посмотреть сообщение
Программа из #16 не подойдет
Доброго дня.
Эта программулина сохраняет свойства, но не сохраняет атрибуты.
А еще хотелось бы выбирать блоки рамкой, а не тыкать каждый.

Хотя с заменой с сохранением атрибутов справился (эспартировав атрибуты, и импортировав после замены блоков) проблеммно отсортировать правильно т.к. имена изменились.

Может кто допилит из великих гуру
gizmo_zx вне форума  
 
Непрочитано 28.09.2011, 12:15
#28
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


Цитата:
Сообщение от gizmo_zx Посмотреть сообщение
Эта программулина сохраняет свойства, но не сохраняет атрибуты.
Сохраняет, но там должны быть выполнены определенные условия. Например, количество атрибутов у блока-образца и у заменяемого блока должно быть одинаковое.
Do$ вне форума  
 
Непрочитано 25.10.2011, 20:36
#29
АлексЮстасу

топограф, технолог
 
Блог
 
Регистрация: 24.05.2009
Москва
Сообщений: 3,030


Попробовал на 2012 и лисп Do$, и лисп TararykovDG, но 2012 на первый выдал
"Укажите блок-образец:; ошибка: no function definition: VLAX-ENAME->VLA-OBJECT",
а второй
"Укажите блок для замены: ; ошибка: no function definition: VLAX-GET-ACAD-OBJECT"
Что-то у меня на 2012 не так?

Последний раз редактировалось АлексЮстасу, 25.10.2011 в 20:44.
АлексЮстасу вне форума  
 
Непрочитано 25.10.2011, 21:54
#30
Кулик Алексей aka kpblc
Moderator

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


Опять (vl-load-com) забыли?
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 25.10.2011, 23:40
#31
АлексЮстасу

топограф, технолог
 
Блог
 
Регистрация: 24.05.2009
Москва
Сообщений: 3,030


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
Опять (vl-load-com) забыли?
В текстах это (vl-load-com) есть и в том, и в другом.
Если они там находятся в нужных местах, то в чем еще может быть дело?
АлексЮстасу вне форума  
 
Непрочитано 26.10.2011, 00:25
#32
Кулик Алексей aka kpblc
Moderator

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


Возможно, в необходимости переустановки AutoCAD...
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 26.10.2011, 01:55
#33
kakt00z

инженер-проектировщик КИПиА
 
Регистрация: 30.08.2008
Минск
Сообщений: 159


есть мнение (мое скромное) что в 12 каде лисп резанули (раз в коде есть), переУстановка тут не помогет...
мимолетом вопрос: а есть кто писал прогу dcl-редактор матрицы?
(поясняю для прилиспенных ))) крысов ))) есть список списков ((1 2 3 ... ч)(ф ы в ... ч)(я ч с ... ч) ... (ш щ з ... ч)) - превратить в dcl редактирование 2D таблицы) помницца где то видел отжиг Алексея с генерированием динамического dcl фАЙЛА
ЗЫ завтра сам напишу, но мало ли уже есть
kakt00z вне форума  
 
Непрочитано 26.10.2011, 08:22
#34
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


Цитата:
Сообщение от kakt00z Посмотреть сообщение
есть мнение (мое скромное) что в 12 каде лисп резанули (раз в коде есть), переУстановка тут не помогет...
Ничего себе новости
Do$ вне форума  
 
Непрочитано 26.10.2011, 08:28
#35
Кулик Алексей aka kpblc
Moderator

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


Я на 2005 и 2006 версиях "ловил" подобное сообщение - слетала регистрация каких-то dll и "рушились" arx, отвечающие за использование СОМ-модели. Как правило, переустановка (правда, не помню - то ли в режиме восстановления, то ли полная) проблему решала.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 27.10.2011, 08:31
#36
Jonas

конструктор машиностроитель
 
Регистрация: 14.05.2007
Новосибирск
Сообщений: 893


В 2012 лисп из #16, не работал.
Случайно выгрузил acad.cuix (бывает) а после загрузки - заработал, чудеса.
Может такой прием взять на вооружение?

Последний раз редактировалось Jonas, 27.10.2011 в 13:41.
Jonas вне форума  
 
Непрочитано 27.10.2011, 12:19
#37
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


Цитата:
Сообщение от Jonas Посмотреть сообщение
В 2112
Offtop: В Жигулях чтоли?
Do$ вне форума  
 
Непрочитано 27.10.2011, 13:42
#38
Jonas

конструктор машиностроитель
 
Регистрация: 14.05.2007
Новосибирск
Сообщений: 893


Цитата:
Сообщение от Do$ Посмотреть сообщение
Offtop: В Жигулях чтоли?
Точно!
Jonas вне форума  
 
Непрочитано 22.01.2012, 10:15
#39
gizmo_zx

Проектировщик ЭО,ЭМ, ЭОС
 
Регистрация: 18.07.2007
Нижний Новгород
Сообщений: 256
<phrase 1= Отправить сообщение для gizmo_zx с помощью Skype™


Бодрого дня.
А моможите с програмкой "bchange.LSP"
Код:
[Выделить все]
 
(defun c:bchange (/
		  sel-blk
		  ent-is-block-check
		  block-change
		  ss
		  ent1
		  ent2
		  adoc
		 )

;;;Вспомогательные функции:
;;;*****************************************************************************************

  (defun sel-blk (msg / ent safe-sel)
;;; (sel-blk "\nSelect block for change:")  
    (defun safe-sel (txt / ent)
;;; (safe-sel "\nSelect object:")
      (while
	(not
	  (setq	ent
		 (vl-catch-all-apply
		   (function (lambda () (entsel txt)))
		 ) ;_ end of vl-catch-all-apply
	  ) ;_ end of setq
	) ;_ end of not
      ) ;_ end of while
      (if (vl-catch-all-error-p ent)
	nil
	ent
      ) ;_ end of if
    ) ;_ end of defun

    (cond
      ((not (setq ent (safe-sel msg))) nil)
      ((not (ent-is-block-check
	      (setq ent (car ent))
	    ) ;_ end of ent-is-block-check
       ) ;_ end of not
       (prompt "\nУказанное не является блоком!")
       "not block"
      )
      (T ent)
    ) ;_ end of cond
  ) ;_ end of defun

  (defun ent-is-block-check (ent)
;;; (ent-is-block-check (car (entsel "\nSelect object:")))
    (if	(= (type ent) (quote ename))
      (setq ent (vlax-ename->vla-object ent))
    ) ;_ end of if
    (and (= (vla-get-ObjectName ent) "AcDbBlockReference")
	 (not (vlax-property-available-p ent "Path"))
    ) ;_ end of and
  ) ;_ end of defun

  (defun block-change (ent1
		       ent2
		       /
		       GetDynamicBlockPropertyList
		       _kpblc-block-dyn-change-values
		       block-get-attribute-list
		       conv-to-vla
		       adoc
		       pspace
		       mspace
		       dyn_prop_lst1
		       dyn_prop_lst2
		       att_lst_1
		       att_lst_2
		      )

;;;  ent1 - заменяемый блок
;;;  ent2 - блок-образец

    (defun GetDynamicBlockPropertyList (obj / lstProperties)
;;;  Взято с:
;;;  http://forum.abok.ru/index.php?showtopic=14612&view=findpost&p=171367
;;;  Изменена для получения иного возвращаемого результата.
;;;  (GetDynamicBlockPropertyList (vlax-ename->vla-object (car (entsel "\nSelect dynamic block:"))))
;;;  Было:
;;;  -->(("Visibility" "С кронштейном" #<VLA-OBJECT IAcadDynamicBlockReferenceProperty 0a8f7264>))
;;;  Стало:
;;;  -->(("Visibility" . "С кронштейном"))
      (if (and (vlax-property-available-p obj "IsDynamicBlock")
	       (= (vla-get-IsDynamicBlock obj) :vlax-true)
	       (not (vl-catch-all-error-p
		      (setq lstProperties
			     (vl-catch-all-apply
			       (function (lambda ()
					   (vlax-safearray->list
					     (variant-value
					       (vla-GetDynamicBlockProperties obj)
					     ) ;_ end of variant-value
					   ) ;_ end of vlax-safearray->list
					 ) ;_ end of lambda
			       ) ;_ end of function
			     ) ;_ end of vl-catch-all-apply
		      ) ;_ end of setq
		    ) ;_ end of vl-catch-all-error-p
	       ) ;_ end of not
	       lstProperties
	  ) ;_ end of and
	(progn
	  (mapcar '(lambda (x)
		     (cons (vla-get-propertyname X)
			   (variant-value (vla-get-value X))
			   ;;		       x
		     ) ;_ end of list
		   ) ;_ end of lambda
		  lstProperties
	  ) ;_ end of mapcar
	) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of defun

    (defun _kpblc-block-dyn-change-values (ent
					   lst
					   /
					   prop_lst
					   _kpblc-conv-vla-to-list
					  )
					  ;|
	ent	указатель на вхождение блока
	lst	список вида:
      '((<property> . <value>)
	(<property> . <value>)
	)
*    примеры вызова:
(_kpblc-block-dyn-change-values (car(entsel))'(("dist*" . 162.56) ("ang*" . 5.)))
;; Углы надо задавать в радианах!
(_kpblc-block-dyn-change-values (car (entsel)) '(("Visibility" . "Пустая")))
|;

      (defun _kpblc-conv-vla-to-list (value / res)
				     ;|
*    Преобразовывает vlax-variant или vlax-safearray в список.
|;
	(cond
	  ((= (type value) 'variant)
	   (_kpblc-conv-vla-to-list (vlax-variant-value value))
	  )
	  ((= (type value) 'safearray)
	   (if (>= (vlax-safearray-get-u-bound value 1) 0)
	     (vlax-safearray->list value)
	   ) ;_ end of if
	  )
	  (t value)
	) ;_ end of cond
      ) ;_ end of defun

      (vl-load-com)
      (if (and ent
	       (setq
		 ent (cond
		       ((= (type ent) 'ename) (vlax-ename->vla-object ent))
		       ((= (type ent) 'vla-object) ent)
		       (t nil)
		     ) ;_ end of cond
	       ) ;_ end of setq
	       (= (strcase (vla-get-objectname ent) t)
		  "acdbblockreference"
	       ) ;_ end of =
	       (= (vla-get-isdynamicblock
		    (vla-item
		      (vla-get-blocks
			(vla-get-activedocument (vlax-get-acad-object))
		      ) ;_ end of vla-get-blocks
		      (vla-get-effectivename ent)
		    ) ;_ end of vla-item
		  ) ;_ end of vla-get-isdynamicblock
		  :vlax-true
	       ) ;_ end of =
	  ) ;_ end of and
	(progn
	  (setq
	    prop_lst (vlax-safearray->list
		       (vlax-variant-value
			 (vla-getdynamicblockproperties ent)
		       ) ;_ end of vlax-variant-value
		     ) ;_ end of vlax-safearray->list
	  ) ;_ end of setq
	  (foreach item
		   (mapcar '(lambda (a) (cons (strcase (car a)) (cdr a)))
			   lst
		   ) ;_ end of mapcar
	    (if	(setq prop
		       (car
			 (vl-remove-if-not
			   '(lambda (x)
			      (wcmatch (strcase (vla-get-propertyname x))
				       (car item)
			      ) ;_ end of wcmatch
			    ) ;_ end of lambda
			   prop_lst
			 ) ;_ end of vl-remove-if-not
		       ) ;_ end of car
		) ;_ end of setq
	      ;; Имя совпало
	      (vl-catch-all-apply
		'(lambda ()
		   (vla-put-value
		     prop
		     (vlax-make-variant
		       (cdr item)
		       (vlax-variant-type (vla-get-value prop))
		     ) ;_ end of vlax-make-variant
		   ) ;_ end of vla-put-value
		   (vla-update ent)
		 ) ;_ end of lambda
	      ) ;_ end of vl-catch-all-apply
	    ) ;_ end of if
	  ) ;_ end of foreach
	) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of defun

    (defun block-get-attribute-list (blk / lst)
      ;; (block-get-attribute-list (car (entsel "\nSelect block:")))
      (if (= (type blk) (quote ename))
	(setq blk (vlax-ename->vla-object blk))
      ) ;_ end of if
      (if
	(vl-catch-all-error-p
	  (setq	lst
		 (vl-catch-all-apply
		   (function (lambda ()
			       (vlax-safearray->list
				 (vlax-variant-value
				   (vla-getattributes
				     blk
				   ) ;_ end of vla-getattributes
				 ) ;_ end of vlax-variant-value
			       ) ;_ end of vlax-safearray->list
			     ) ;_ end of lambda
		   ) ;_ end of function
		 ) ;_ end of vl-catch-all-apply
	  ) ;_ end of setq
	) ;_ end of vl-catch-all-error-p
	 nil
	 lst
      ) ;_ end of if
    ) ;_ end of defun


    (defun conv-to-vla (val)
      (cond
	((= (type val) (quote vla-object)) val)
	((= (type val) (quote ename)) (vlax-ename->vla-object val))
      ) ;_ end of cond
    ) ;_ end of defun


    (vl-load-com)
    (setq
      adoc   (vla-get-ActiveDocument (vlax-get-acad-object))
      pspace (vla-get-PaperSpace adoc)
      mspace (vla-get-ModelSpace adoc)
      ent1   (conv-to-vla ent1)
      ent2   (conv-to-vla ent2)
      ent2   (vla-InsertBlock
	       (if
		 (= (cdr (assoc 67 (entget (vlax-vla-object->ename ent1))))
		    0
		 ) ;_ end of =
		  mspace
		  pspace
	       ) ;_ end of if
	       (vla-get-InsertionPoint ent1)
	       (vla-get-EffectiveName ent2)
	       (vla-get-XScaleFactor ent1)
	       (vla-get-YScaleFactor ent1)
	       (vla-get-ZScaleFactor ent1)
	       (vla-get-Rotation ent1)
	     ) ;_ end of vla-InsertBlock
    ) ;_ end of setq 
    (mapcar
      (function
	(lambda	(prop)
	  (vlax-put-property ent2 prop (vlax-get-property ent1 prop))
	) ;_ end of lambda
      ) ;_ end of function
      (list "Layer"
	    "Linetype"
	    "LinetypeScale"
	    "Lineweight"
	    "Normal"
	    "InsertionPoint"
	    "Rotation"
	    ;;"PlotStyleName"
	    "TrueColor"
	    "Visible"
      ) ;_ end of list
    ) ;_ end of mapcar
    (if	(and (setq dyn_prop_lst1 (GetDynamicBlockPropertyList ent1))
	     (setq dyn_prop_lst2 (GetDynamicBlockPropertyList ent2))
	     (vl-some (function (lambda (a b) (= (car a) (car b))))
		      dyn_prop_lst1
		      dyn_prop_lst2
	     ) ;_ end of vl-some
	) ;_ end of and
      (_kpblc-block-dyn-change-values ent2 dyn_prop_lst1)
    ) ;_ end of if
    (if	(and (setq att_lst_1 (block-get-attribute-list ent1))
	     (setq att_lst_2 (block-get-attribute-list ent2))
	     (= (length att_lst_1) (length att_lst_2))
	) ;_ end of and
      (mapcar
	(function
	  (lambda (att1 att2)
	    (mapcar
	      (function
		(lambda	(prop)
		  (if (and (= prop "TextGenerationFlag"))
		    (progn
		      (entmod
			(list
			  (cons -1 (vlax-vla-object->ename att2))
			  (cons
			    71
			    (cdr (assoc
				   71
				   (entget (vlax-vla-object->ename att1))
				 ) ;_ end of assoc
			    ) ;_ end of cdr
			  ) ;_ end of cons
			) ;_ end of list
		      ) ;_ end of entmod
		    ) ;_ end of progn
		    (vl-catch-all-apply
		      (function
			(lambda	()
			  (vlax-put-property
			    att2
			    prop
			    (vlax-get-property att1 prop)
			  ) ;_ end of vlax-put-property
			) ;_ end of lambda
		      ) ;_ end of function
		    ) ;_ end of vl-catch-all-apply
		  ) ;_ end of if
		) ;_ end of lambda
	      ) ;_ end of function
	      (list
		"Alignment"
		"Backward"
		"FieldLength"
		"Height"
		"InsertionPoint"
		"Invisible"
		"Layer"
		"Linetype"
		"LinetypeScale"
		"Lineweight"
		"Normal"
		"ObliqueAngle"
		;;"PlotStyleName"
		"Rotation"
		"ScaleFactor"
		"StyleName"
		"TagString"
		"TextString"
		"TextAlignmentPoint"
		"TextGenerationFlag"
		"Thickness"
		"TrueColor"
		"UpsideDown"
		"Visible"
	      ) ;_ end of list
	    ) ;_ end of mapcar
	  ) ;_ end of lambda
	) ;_ end of function
	att_lst_1
	att_lst_2
      ) ;_ end of mapcar
    ) ;_ end of if
    (vla-delete ent1)
    (vla-update ent2)
  ) ;_ end of defun


;;;Основной блок:
;;;*****************************************************************************************

  (if (and (setq ss (ssget "_I" (quote ((0 . "INSERT")))))
	   (= 1 (sslength ss))
	   (ent-is-block-check (setq ent2 (ssname ss 0)))
      ) ;_ end of and
    (setq ent2 (vlax-ename->vla-object ent2))
    (setq ent2 (sel-blk "\nУкажите блок-образец:"))
  ) ;_ end of if
  (sssetfirst nil nil)
  (if ent2
    (while (setq ent1 (sel-blk "\nУкажите заменяемый блок (Esc-выход.):"))
      (if (and (/= ent1 "not block") (not (equal ent1 ent2)))
	(progn
	  (vla-StartUndoMark
	    (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)))
	  ) ;_ end of vla-StartUndoMark
	  (block-change ent1 ent2)
	  (vla-EndUndoMark adoc)
	) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of while
  ) ;_ end of if
  (princ)
) ;_ end of defun

Хотелось бы не тыкать блок для замены, а выделять рамкой.
gizmo_zx вне форума  
 
Непрочитано 13.04.2012, 10:19
#40
crosandr

Инженер-строитель
 
Регистрация: 09.07.2010
Санкт-Петербург
Сообщений: 1,988


Цитата:
Сообщение от gizmo_zx Посмотреть сообщение
Хотелось бы не тыкать блок для замены, а выделять рамкой
Такой вариант подойдет?
Использование:
  • Команда b2b запрашивает выбор объектов среди которых производить замену
  • Если в выборе больше одного блока, то в в окне "Что заменять" необходимо уточнить имена блоков для замены. Поддерживается множественный выбор. Имя блока можно указать, выбрав его на чертеже.
  • Масштабный коэффициент умножается на масштаб исходного блока
Код:
[Выделить все]
 
;;;(vl-load-com)

(defun _dclWrite (BlkLstFromHeight / dclcode filename filehandle)
  ;; Makes a temporary DCL file at runtime
  ;; Returns name of the file or NIL
  (setq    dclcode    (list ;_ tilenames are case sensitive
          "            // Temporary DCL file                                        "
          "            b2b:    dialog {label=\"Замена блока в указанной области\";                    "
          "            :column {label=\"Что заменять\";                                    "
          (strcat "        :list_box {key=\"block_from\"; multiple_select=true; height="
              (itoa (1+ BlkLstFromHeight))
              ";}"
          ) ;_ strcat
          "                :button {label=\"Выбрать >\"; key=\"choose_from\";}                    "
          "                }                                            "
          "            :column {label=\"Чем заменять\";                                 "
          "                :popup_list {key=\"block_to\";}                                "
          "                :button {label=\"Выбрать >\"; key=\"choose_to\";}                    "
          "                :list_box {label=\"Видимость (для динамических блоков)\"; key=\"dyn_view\";}        "
          "                }                                            "
          "            :edit_box {label=\"Коэффициент масштаба\"; key=\"scale_factor\";}                "
          "            :text {key=\"errmsg\"; alignment=right;}                            "
          "            ok_cancel;                                            "
          "            }                                                "
        ) ;_ list
  ) ;_ setq
  (if (and (setq filename (vl-filename-mktemp "b2b" nil ".tmp"))
       (setq filehandle (open filename "w"))
      ) ;_ and
    (progn (foreach line dclcode (write-line line filehandle))
       (close filehandle)
    ) ;_ progn
  ) ;_ if
  filename
) ;_ defun

;;;*********************************
;;; Возвращает список блоков чертежа 
(defun GetBlockList (/ lst AllValueList selset tmp DynBlkLst DynBlkLstSel OutList head)
  ;; получаем список динамических блоков с параметром видимость
  (if (setq selset (ssget "_A" '((0 . "INSERT"))))
    (progn (setq lst (mapcar '(lambda (x) (cons (cdr (assoc 2 (entget x))) x))
                 (dwgru-conv-pickset-to-list selset)
             ) ;_ mapcar
       ) ;_ setq
       ;; удаляем одинаковые имена блоков
       (while lst
         (setq head       (car lst)
           OutList (cons (cdr head) OutList)
           lst       (vl-remove-if '(lambda (z) (= (car z) (car head))) (cdr lst))
         ) ;_ setq
       ) ;_ while
       (setq DynBlkLst    (vl-remove-if (function (lambda (blk) ; список динамических блоков (vla объекты)
                            (and (vlax-property-available-p blk "IsDynamicBlock")
                                 (= (vla-get-isdynamicblock blk) :vlax-false)
                            ) ;_ and
                              ) ;_ lambda
                        ) ;_ function
;;;                        (mapcar 'vlax-ename->vla-object (mapcar 'cadr (ssnamex selset)))  mip_MakeUniqueMembersOfList
                        (mapcar 'vlax-ename->vla-object OutList)
                  ) ;_ vl-remove-if
         DynBlkLstSel (mapcar (function
                    (lambda    (obj)
                      (if (and (setq tmp (vlax-variant-value (vla-getdynamicblockproperties obj)))
                           (>= (vlax-safearray-get-u-bound tmp 1) 0)
                           (setq lstProperties (vlax-safearray->list tmp))
                          ) ;_ end of and
                        (progn (setq Pobj (car
                                (vl-remove-if-not '(lambda (x)
                                             (member (vla-get-propertyname x) (list "Видимость" "Visibility"))
                                           ) ;_ lambda
                                          lstProperties
                                ) ;_ vl-remove-if-not
                                  ) ;_ car
                           ) ;_ setq
                           (if (and Pobj
                                (vlax-property-available-p Pobj "AllowedValues")
                                (setq AllValueList (vlax-get-property Pobj "AllowedValues"))
                               ) ;_ end of and
                             (cons (vla-get-effectivename obj)
                               (mapcar 'vlax-variant-value
                                   (vlax-safearray->list
                                     (vlax-variant-value AllValueList) ;_ vlax-variant-value
                                   ) ;_ vlax-safearray->list
                               ) ;_ mapcar
                             ) ;_ cons
                           ) ;_ if
                        ) ;_ progn
                      ) ;_ if
                    ) ;_ lambda
                      ) ;_ function
                      DynBlkLst
                  ) ;_ mapcar
       ) ;_ setq
    ) ;_ progn
  ) ;_ if
  ;; получаем список имен блоков чертежа
  (setq lst nil)
  (vlax-for item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
    (setq lst (cons (list (vla-get-name item)) lst))
  ) ;_ vlax-for
  ;; удаляем неименованные блоки
  (setq    lst         (vl-remove-if-not (function (lambda (x) (wcmatch (car x) "~`**")))
                       lst
             ) ;_ vl-remove-if-not
    DynBlkLstSel (vl-remove-if 'null DynBlkLstSel)
  ) ;_ setq
  ;; дописываем к именам динамических блоков их состояния видимости
  (if DynBlkLst
    (setq lst (mapcar (function    (lambda    (x)
                  (if (setq tmp (assoc (car x) DynBlkLstSel))
                    tmp
                    x
                  ) ;_ if
                ) ;_ lambda
              ) ;_ function
              lst
          ) ;_ mapcar
    ) ;_ setq
  ) ;_ if
  ;; возвращаемое значение 
  lst
) ;_ defun

;;;*********************************
;;; возвращает список состояния диалогового окна
(defun get_cond_list ()
  (mapcar 'get_tile (list "block_from" "block_to" "scale_factor"))
) ;_ defun

;;;*********************************
;;; Заполняет список состояний видимости для динамических блоков
(defun dyn_view_fill (blk_name_lst / ViewLst)
  (if (and blk_name_lst
       (setq ViewLst (cdr (assoc (nth (atoi (get_tile "block_to")) blk_name_lst) AllBlkLst))
         ViewLst (if ViewLst
               (append ViewLst (list "<Оставить без изменения>") )
             ) ;_ if
       )                            ; список видов для блока
      ) ;_ and
    (progn (mode_tile "dyn_view" 0)    ; включаем поле
       (start_list "dyn_view")
       (mapcar 'add_list ViewLst)
       (end_list)
       (set_tile "dyn_view" "0")
    ) ;_ progn
    (progn (mode_tile "dyn_view" 1)    ; выключаем поле
       (start_list "dyn_view")    ; очищаем список от предыдущих данных
       (end_list)
    ) ;_ progn
  ) ;_ if
) ;_ defun

;;;*********************************
;;; управляет вводом коэффициента масштаба
(defun _scale_factor (/ tmp err_msg)
  (setq    tmp    (vl-string-trim    " "
                (vl-string-translate ",/бюOОЗ+" "....003 " (get_tile "scale_factor")) ; чистим строку от типичных ошибок
        ) ;_ vl-string-trim
    err_msg    (if (or    (wcmatch (vl-string-subst "" "." tmp) "*@*,*.*")
            (<= (atof tmp) 0)
            ) ;_ or
          "*Введите положительное число*"
          ""
        ) ;_ if
  ) ;_ setq
  (set_tile "errmsg" err_msg)
  (set_tile "scale_factor" tmp)
) ;_ defun

;;;*********************************
;;; возвращает строку с позицией блока в списке блоков 
(defun choose_block (blk_lst / blk_name tmp)
  (while (not (or (= (type blk_name) 'PICKSET)
          (= (getvar "ERRNO") 52)
          (vl-catch-all-error-p blk_name)
          ) ;_ or
     ) ;_ not
;;;    (princ "\nSelect block <exit>: ")
    (setq blk_name (vl-catch-all-apply '(lambda () (ssget "_:S:E:L" '((0 . "INSERT"))))))
  ) ;_ while
  (sssetfirst nil nil)
  (if (and (= (type blk_name) 'PICKSET)
       (setq tmp (vl-position (vla-get-effectivename (vlax-ename->vla-object (ssname blk_name 0)))
                  blk_lst
             ) ;_ vl-position
       ) ;_ setq
      ) ;_ and
    (itoa tmp)
    "0"
  ) ;_ if
) ;_ defun


;;;*********************************
;;; param_lst = (list BlkNmLstFrom BlkNmLstTo VlaLstBlkFrom)
(defun _AcceptButton (param_lst    / scl SelDiaLst    BlkFrom    BlkTo SclLst objMS Pobj    Plist DynViewNum NewBlk    proplst DynViewVal AllowDynProp PropCode
             )
  (setq    SelDiaLst (mapcar 'get_tile (list "block_from" "block_to" "scale_factor"))
    BlkFrom      (mapcar 'atoi (_kpblc-string-parser (car SelDiaLst) " ")) ;(vl-remove-if 'zerop (mapcar 'atoi (_kpblc-string-parser "1 9" " ")))
    proplst      (list 'Layer 'Linetype 'LinetypeScale 'TrueColor) ; свойства для передачи новому блоку
  ) ;_ setq
  (cond    ((> (strlen (get_tile "errmsg")) 0) ; корректируем неположительное число
     (progn (mode_tile "scale_factor" 2))
    )
    ((null BlkFrom) (mode_tile "block_from" 2)) ; корректируем пустой выбор
    ((zerop (atoi (cadr SelDiaLst))) (mode_tile "block_to" 2)) ; корректируем пустой выбор
    (t                ; при корректном выборе всех значений диалогового окна
     (progn    (setq scl     (atof (caddr SelDiaLst))
              BlkFrom (mapcar '(lambda (x) (nth x (car param_lst))) BlkFrom) ;_ mapcar
              BlkTo   (nth (atoi (cadr SelDiaLst)) (cadr param_lst))
              objMS   (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
        ) ;_ setq
        (foreach vl (caddr param_lst)
          (if (member (vla-get-effectivename vl) BlkFrom)
            (progn (setq SclLst          (mapcar '(lambda (x)
                             (if (vlax-property-available-p vl x)
                               (* scl (vlax-get-property vl x))
                               1
                             ) ;_ if
                               ) ;_ lambda
                              '(XEffectiveScaleFactor YEffectiveScaleFactor ZEffectiveScaleFactor)
                          ) ;_ mapcar
                 NewBlk          (vla-insertblock objMS
                                   (vla-get-insertionpoint vl)
                                   BlkTo
                                   (car SclLst)
                                   (cadr SclLst)
                                   (caddr SclLst)
                                   (vla-get-rotation vl)
                          ) ;_ vla-insertblock
                 AllowDynProp t            ; разрешение на перенос других динамических свойств (заглушка checkbox)
               ) ;_ setq
               ;; копируем динамические параметры из старого блока в новый (при условии совпадения имен параметров)
               (if (and (/= (setq DynViewNum (get_tile "dyn_view")) "") AllowDynProp)
                 (progn (setq Plist            ; список динамических параметров для старого и нового блоков
                       (mapcar '(lambda (blk)
                              (reverse ; из-за повторного применения зеркала (убрать и доработать!!)
                            (vlax-safearray->list
                              (vlax-variant-value (vla-getdynamicblockproperties blk))
                            ) ;_ vlax-safearray->list
                              ) ;_ reverse
                            ) ;_ lambda
                           (list vl NewBlk)
                       ) ;_ mapcar
                    ) ;_ setq
                    (foreach NewProp (cadr Plist) ; список динамических свойств нового блока
                      (foreach OldProp (car Plist) ; список динамических свойств старого блока
                    (setq PropCode (mapcar '(lambda    (pold)
                                  (vl-string->list
                                    (vlax-get-property pold 'PropertyName) ; получаем значение имен свойств
                                  ) ;_ vl-string->list
                                ) ;_ lambda
                                   (list NewProp OldProp)
                               ) ;_ mapcar
                    ) ;_ setq
                    (if (vl-every '= (car PropCode) (cadr PropCode))
                      (vla-put-value NewProp (vla-get-value OldProp))
                    ) ;_ if
                      ) ;_ foreach
                    ) ;_ foreach
;;;                    (vla-update NewBlk)
                 ) ;_ progn
               ) ;_ if
               ;; устанавливаем видимость
               (if (/= (setq DynViewNum (get_tile "dyn_view")) "")
                 (progn (setq Plist            ; список динамических параметров для старого и нового блоков
                       (mapcar '(lambda (blk)
                              (car (vl-remove-if-not '(lambda (x)
                                        (member (vla-get-propertyname x) (list "Видимость" "Visibility"))
                                          ) ;_ end of lambda
                                         (vlax-safearray->list
                                           (vlax-variant-value (vla-getdynamicblockproperties blk))
                                         ) ;_ vlax-safearray->list
                               ) ;_ vl-remove-if-not
                              ) ;_ car
                            ) ;_ lambda
                           (list vl NewBlk)
                       ) ;_ mapcar
                    ) ;_ setq
                    (if    (and (vl-member-if-not 'null Plist)
                         (setq Pobj        (cadr Plist)
                           AllValueList ; список параметров видимости нового блока
                                (mapcar    'vlax-variant-value
                                    (vlax-safearray->list
                                      (vlax-variant-value (vlax-get-property Pobj 'AllowedValues))
                                    ) ;_ vlax-safearray->list
                                ) ;_ mapcar
                         ) ;_ setq
                    ) ;_ and
                      (progn
                    (setq DynViewVal
                           (if        ; "<Текущее при совпадении>" выбрано? 
                         (< (atoi DynViewNum) (vl-list-length AllValueList))
                          (nth (atoi DynViewNum) AllValueList) ; выбрано конкретное имя видимости
                          (vlax-variant-value (vlax-get-property (car Plist) 'Value)) ; имя видимости старого блока

                           ) ;_ if
                    ) ;_ setq
                    (vla-put-value Pobj (vlax-make-variant DynViewVal vlax-vbstring))
                      ) ;_ progn
                    ) ;_ if
                 ) ;_ progn
               ) ;_ if
               ;; передаем свойства от старого блока новому
               (mapcar '(lambda (x y) (vlax-put-property NewBlk x y))
                   proplst
                   (mapcar '(lambda (x) (vlax-get-property vl x)) proplst)
               ) ;_ mapcar
;;;               (vla-update NewBlk)
               (vla-delete vl)
            ) ;_ progn
          ) ;_ if
        ) ;_ foreach
        (done_dialog 1)
     ) ;_ progn
    ) ;_ t
  ) ;_ cond
) ;_ defun

;;;*********************************
;;; запускает диалог
;;; cond_list = (list BlockFrom BlockTo ScaleFactor)
(defun _RunDialog (cond_list VlaLstBlkFrom BlkNmLstFrom    / status block_pos AllBlkLst BlkNmLstTo    BlkNmLstFrom BlkSelFrom
          )
  (setq    AllBlkLst    (GetBlockList)
    BlkNmLstTo   (append (list "")
                 (if AllBlkLst
                   (acad_strlsort (mapcar 'car AllBlkLst))
                 ) ;_ if
             ) ;_ append
    status         2
    BlkNmLstFrom (acad_strlsort BlkNmLstFrom)
  ) ;_ setq
  ;; заполняем списки
  (mapcar '(lambda (x y) (start_list x) (mapcar 'add_list y) (end_list))
      '("block_from" "block_to")
      (list BlkNmLstFrom BlkNmLstTo)
  ) ;_ mapcar
  (if (= (vl-list-length BlkNmLstFrom) 1) ; выбираем блок, если он единственный в списке
    (setq cond_list (subst-i 0 "0" cond_list))
  ) ;_ if
  (if (= (vl-list-length BlkNmLstTo) 2)    ; выбираем блок, если он единственный в списке
    (setq cond_list (subst-i 1 "1" cond_list))
  )                    ; для множественного выбора
  (if (setq BlkSelFrom (mapcar 'atoi (_kpblc-string-parser (car cond_list) " ")))
    (mapcar '(lambda (z) (set_tile "block_from" (itoa z))) BlkSelFrom)
  ) ;_ if
  (mapcar '(lambda (x y) (set_tile x (nth y cond_list)))
      '("block_to" "scale_factor")
      '(1 2)
  ) ;_ mapcar
  (_scale_factor)
  (action_tile "accept"
           "(_AcceptButton (list BlkNmLstFrom BlkNmLstTo VlaLstBlkFrom))"
  ) ;_ action_tile
  (action_tile "cancel" "(done_dialog 0)")
  (action_tile "choose_from"
           "(setq cond_list (get_cond_list)) (done_dialog 3)"
  ) ;_ action_tile
  (action_tile "choose_to"
           "(setq cond_list (get_cond_list)) (done_dialog 4)"
  ) ;_ action_tile
  (action_tile "block_to" "(dyn_view_fill BlkNmLstTo)")
  (action_tile "scale_factor" "(_scale_factor)")
  (dyn_view_fill BlkNmLstTo)
  (while (>= status 2)
    (setq status (start_dialog))
    (cond ((= status 3)
       (progn (setq block_pos (choose_block BlkNmLstFrom))
          (if (null (new_dialog "b2b" dcl_id))
            (exit)
            (_RunDialog    (append (list (strcat block_pos " " (car cond_list))) (cdr cond_list))
                VlaLstBlkFrom
                BlkNmLstFrom
            ) ;_ _RunDialog
          ) ;_ if
       ) ;_ progn
      )
      ((= status 4)
       (progn (setq block_pos (choose_block BlkNmLstTo))
          (if (null (new_dialog "b2b" dcl_id))
            (exit)
            (_RunDialog    (list (nth 0 cond_list) block_pos (nth 2 cond_list))
                VlaLstBlkFrom
                BlkNmLstFrom
            ) ;_ _RunDialog
          ) ;_ if
       ) ;_ progn
      )
    ) ;_ cond
  ) ;_ while
  (unload_dialog dcl_id)
  ;; Despite what the manual says, vl-filename-mktemp
  ;; files were not always being automatically deleted
  (vl-file-delete *b2b-dclfilename*)
) ;_ defun


;;;*********************************
;;; основная функция
(defun c:b2b (/    dcl_id *b2b-dclfilename* error-save sysvar-name    sysvar-save selset VlaLstBlkFrom BlkNmLstFrom
         )
;;;*** обработка ошибок
  (defun *error* (msg)
    (if    error-save
      (setq *error* error-save)
    ) ;_ if
    (if    msg
      (princ "*Прервано*")
    ) ;_ if
    ;; vl-filename-mktemp not consistently deleting temp files
    (if    *b2b-dclfilename*
      (vl-file-delete *b2b-dclfilename*)
    ) ;_ if
    (mapcar 'setvar sysvar-name sysvar-save) ; Восстановление значений системных переменных
    (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
    (princ)
  ) ;_ defun  
;;;***           
  (setq    error-save  *error*
    sysvar-name (list "OSMODE" "INSUNITS" "ATTREQ")
    sysvar-save (mapcar 'getvar sysvar-name)
    actDoc        (vla-get-activedocument (vlax-get-acad-object))
  ) ;_ setq
  (vla-startundomark actDoc)
  (mapcar 'setvar sysvar-name '(0 0 0))
;;; Выбор блоков для замены
  (while (not (or (= (type selset) 'PICKSET) (= (getvar "ERRNO") 52)))
    (princ "\nВыберите объекты для замены <Выход>: ")
    (setq selset (ssget '((0 . "INSERT"))))
  ) ;_ while
  (sssetfirst nil nil)
  (if (= (type selset) 'PICKSET)
    (progn (setq VlaLstBlkFrom (mapcar 'vlax-ename->vla-object
;;;                       (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
                       (dwgru-conv-pickset-to-list selset)
                   ) ;_ mapcar
       ) ;_ setq
       (foreach item (mapcar 'vla-get-effectivename VlaLstBlkFrom) ; список имен блоков для выбора заменяемого
         (if (not (member item BlkNmLstFrom)) ; удаляем повторения
           (setq BlkNmLstFrom (cons item BlkNmLstFrom))
         ) ;_ end of if
       ) ;_ foreach
       ;; Create DCL file
       (cond ((null
            (setq *b2b-dclfilename* (_dclwrite (vl-list-length BlkNmLstFrom)))
          ) ;_ null
;;;         ((null (setq *b2b-dclfilename* "tmp.dcl"))
          (alert "B2B Error:\nUnable to write DCL file")
         )
         ;; Exit if cannot find DCL file
         ((< (setq dcl_id (load_dialog *b2b-dclfilename*)) 0)
          (alert
            (strcat "B2B Error:\nCannot load DCL file:\n" *b2b-dclfilename*)
          ) ;_ alert
         )
         ;; Exit if DCL fails to load
         ((not (new_dialog "b2b" dcl_id))
          (alert "B2B Error:\nCannot display dialog")
         )
         ;; запуск диалога с начальными значениями
         (t (_RunDialog (list "" "0" "1.0") VlaLstBlkFrom BlkNmLstFrom))
       ) ;_ cond
    ) ;_ progn
  ) ;_ if
  (mapcar 'setvar sysvar-name sysvar-save) ; Восстановление значений системных переменных
  (setq *error* error-save) ;_ setq
  (vla-endundomark actDoc)
  (princ)
) ;_ defun


(defun _kpblc-string-parser (string separator / i)
                ;|
*    Функция разбора строки. Возвращает список либо точечную пару.
*    Параметры вызова:
*    string        разбираемая строка
*    separator    символ, используемый в качестве разделителя частей
*    Примеры вызова:
(_kpblc-string-parser "1;2;3;4;5;6" ";")    ;'(1 2 3 4 5 6)
(_kpblc-string-parser "1;2" ";")        ;'(1 . 2)
*    За основу взяты уроки Евгения Елпанова по рекурсиям
|;
  (cond    ((= string "") nil)
    ((setq i (vl-string-search separator string))
     (cons (substr string 1 i)
           (_kpblc-string-parser
         (substr string (+ (strlen separator) 1 i))
         separator
           ) ;_ end of _kpblc-string-parser
     ) ;_ end of cons
    )
    (t (list string))
  ) ;_ end of cond
) ;_ end of defun
 ;_ end of defun

(defun subst-i (i itm lst)
;;;================================================================
;;;Ф-ция изменяет i-й(начиная с 0) элемент списка новым значением
;;; i - индекс элемента
;;;itm - новое значение
;;;lst - список
;;;http://www.theswamp.org/index.php?topic=14170.0
;;;================================================================
  (setq i (1+ i))
  (mapcar '(lambda (x)
         (if (zerop (setq i (1- i)))
           itm
           x
         ) ;_ end of if
       ) ;_ end of lambda
      lst
  ) ;_ end of mapcar
) ;_ end of defun


;;; ************************************************************************
;;; * Библиотека DWGruLispLib Copyright ©2007  DWGru Programmers Group
;;; *
;;; * _dwgru-conv-pickset-to-list
;;; *
;;; * 03/12/2007 Версия 0001. 
;;; ************************************************************************

(defun dwgru-conv-pickset-to-list (value / lst item)
;;; Назначение:
;;; Преобразовывает набор (pickset) в обычный список имен примитивов (ename)
;;; Низкоуровневая функция. Контроль соответствия типов не производится
;;; Параметры: 
;;; value - набор (pickset) или nil если пустой набор
;;; Возврат:
;;;   - список примитивов (Ename)
;;;; Пример
  ;|
(dwgru-conv-pickset-to-list (ssget "_L")) ;_(<Имя объекта: 7ef85e00>)
(dwgru-conv-pickset-to-list (ssadd)) ;_nil
  |;
  (repeat (setq item (sslength value)) ;_ end setq
    (setq lst (cons (ssname value (setq item (1- item))) lst))
  ) ;_ end repeat
  lst
) ;_ end of defun

Последний раз редактировалось crosandr, 18.01.2013 в 14:16. Причина: обновил код
crosandr вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Замена динамических блоков

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
подсчет динамических блоков AAI Программирование 37 25.06.2012 15:05
Тормозит команда расчленения набора блоков batmax Программирование 4 31.08.2010 17:37
Замена названий блоков, типов линий АлексЮстасу Программирование 9 04.06.2010 21:51
Замена текстовых блоков Sputnik-e AutoCAD 2 11.09.2009 09:22
Библиотека динамических блоков Коробейников Алексей Динамические блоки 2 05.04.2005 16:08