[Serge_Y]

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

[hwd]

Сообщение от Serge_Y есть два динамических блока, которые отличаются только цветом примитивов

цвет примитивам в составе определения блока назначай по слою. размещай вхождение блока на соответствующем слое - получишь примитивы нужного цвета и не придётся лепить предлагаемые тобою же костыли - достаточно одного определения грамотно продуманного блока.

[Кулик Алексей aka kpblc]

Сообщение от hwd цвет примитивам в составе определения блока назначай по слою

Или ПоБлоку? Андрей, единого рецепта я пока не нашел

[hwd]

Сообщение от Кулик Алексей aka kpblc Или ПоБлоку?

Ну или так

- Иосиф Виссарионович, нашли вашего двойника!
- Расстрелять..
- А может просто усы сбрить?
- Ну, или так

[Serge_Y]

Сообщение от hwd цвет примитивам в составе определения блока назначай по слою. размещай вхождение блока на соответствующем слое - получишь примитивы нужного цвета и не придётся лепить предлагаемые тобою же костыли - достаточно одного определения грамотно продуманного блока.

Каюсь, неполно поставил задачу: примитивы кроме разного цвета имеют еще определенный набор расширенных свойств(использую Architectural Desktop). Эти свойства не являются постоянной величиной, а меняются в зависимости от трансформации динамического блока

[TararykovDG]

Serge_Y, может лучше выложить чертеж с блоками (исходный с уже заданными параметрами и новый, на который надо заменить) ну так для большей наглядности (желательно файл версии не старше ACAD2008)

[Serge_Y]

Вот так примерно могут выглядеть блоки. Параметров может быть много.

[TararykovDG]

Serge_Y, что-то я навертел походу, но вроде работает, попробуй так

Код:

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

 
; Вызов: ReplBl
(defun c:ReplBl()
  (vl-load-com)
  ((lambda(old_blk actdoc)
     (vla-startundomark actdoc)
     (if (/= old_blk 1)
       ((lambda(new_blk sf_old_blk name_old_blk)
          (if (/= new_blk 1)
            ((lambda(lst_dyn_value_old_blk sf_new_blk name_new_blk)
               ((lambda(lst_dyn_value_new_blk)
                  (if (or (apply 'or (mapcar '(lambda(x) (assoc (car x) lst_dyn_value_new_blk)) lst_dyn_value_old_blk)))
                    ((lambda(nbr)
                       (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex nbr))))
                         (if (= (vla-get-EffectiveName item) name_old_blk)
                           (progn
                             ((lambda(blk lst_dyn_value_current_blk)
                                (foreach dyn_prop (vlax-safearray->list (vlax-variant-value (vla-GetDynamicBlockProperties blk)))
                                  ((lambda(dyn_rec)
                                     (if dyn_rec
                                       (vla-put-Value dyn_prop (cadr dyn_rec))
                                       )
                                     )
                                    (assoc (vla-get-PropertyName dyn_prop) lst_dyn_value_current_blk)
                                    )
                                  )
                                )
                               (vla-InsertBlock
				 (vla-get-ModelSpace actdoc)
				 (vla-get-InsertionPoint item)
				 name_new_blk
				 (vla-get-XEffectiveScaleFactor item)
				 (vla-get-YEffectiveScaleFactor item)
				 (vla-get-ZEffectiveScaleFactor item)
				 (vla-get-Rotation item)
				 )
			       (vl-remove-if '(lambda(x) (= (car x) "Origin"))
				 (mapcar '(lambda(x) (list (vla-get-PropertyName x) (vla-get-Value x)))
					 (vlax-safearray->list (vlax-variant-value (vla-GetDynamicBlockProperties item)))
					 )
				 )
                               )
                             (vla-Delete item)
                             )
                           )
                         )
                       )
                      (ssget "_X" (list (cons 0 "INSERT") (cons 2 (strcat name_old_blk ",`*U#*"))))
                      )
                    (prompt "\nВ указанных блоках нет ни одного одинакового атрибута!")
                    )
                  )
                 (if (> (vlax-safearray-get-u-bound sf_new_blk 1) -1)
                   (mapcar '(lambda(x) (list (vla-get-PropertyName x) (vla-get-Value x))) (vlax-safearray->list sf_new_blk))
                   )
                 )
               )
              (if (> (vlax-safearray-get-u-bound sf_old_blk 1) -1)
                (vl-remove-if '(lambda(x) (= (car x) "Origin"))
                              (mapcar '(lambda(x) (list (vla-get-PropertyName x) (vla-get-Value x)))
                                      (vlax-safearray->list sf_old_blk)
                                      )
                              )
                )
              (vlax-variant-value (vla-GetDynamicBlockProperties (vlax-ename->vla-object new_blk)))
              (vla-get-EffectiveName (vlax-ename->vla-object new_blk))
              )
            )
          )
         (_tdg-get-object-byselect "Укажите новый блок: " '("INSERT") T)
         (vlax-variant-value (vla-GetDynamicBlockProperties (vlax-ename->vla-object old_blk)))
         (vla-get-EffectiveName (vlax-ename->vla-object old_blk))
         )
       )
     (vla-endundomark actdoc)
     )
    (_tdg-get-object-byselect "Укажите блок для замены: " '("INSERT") T)
    (vla-get-activedocument (vlax-get-acad-object))
    )
  (princ)
  ); end c:ReplBl



; Получить ссылку на указанный объект на чертеже
;	message - текст сообщения при запросе указать объект 
;	filter - список типов объктов для фильтрации (например: ("LINE" "INSERT") - значит будут восприниматься только объекты типа "LINE"  и "INSERT")
;	lock_enter - блокировка нажатия Enter (lock_enter - T при нажатии Enter будет снова запрос на указание объекта; lock_enter - nil выход из функции)
;	return - ссылка на указанный объект (например: <Имя объекта: 7e8ac738>) или 0 если нажали Enter при lock_enter - nil или 1 если нажали Esc
(defun _tdg-get-object-byselect(message filter lock_enter / return)
  ((lambda(errnovar)
     (setvar "errno" 0)
     (while (not (setq return ((lambda(obj)
                                 (if (not (vl-catch-all-error-p obj))
                                   (if obj
                                     (if filter
                                       (if (member (strcase (cdr (assoc 0 (entget (car obj))))) (mapcar 'strcase filter))
                                         (car obj)
                                         )
                                       (car obj)
                                       )
                                     (if (and (not lock_enter) (= (getvar "errno") 52))
                                       0
                                       )
                                     )
                                   1
                                   )
                                 )
                                (vl-catch-all-apply 'entsel
                                                    (list (strcat "\n" message))
                                                    )
                                )
                       )
                 )
       )
     (setvar "errno" errnovar)
     return
     )
    (getvar 'errno)
    )
  ); end _tdg-get-object-byselect

[Oliver_88]

Мне задача как-то проще казалась.

Код:

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

 ;Замена вхождений блоков с учетом динамических параметров
;Пример вызова (test1 "имя строго блока" "имя нового блока")
(defun test1 (old_name_blk new_name_blk / lst3 lst4 obj new_blk lst)
  (vl-load-com)
  (setq model_space (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
  (mapcar
    (function
      (lambda (x)
	(if (equal
	      (strcase (vla-get-EffectiveName (setq obj (vlax-ename->vla-object (cadr x)))))
	      (strcase old_name_blk))
	  (setq lst (cons obj lst))
	  )
	)
      )
    (ssnamex (ssget "_X" '((0 . "INSERT"))))
    )
  (mapcar
    (function
      (lambda (old_blk)
	(setq new_blk (vla-Insertblock model_space (vla-get-InsertionPoint old_blk) new_name_blk  1 1 1 0))
	(setq lst3 (vlax-safearray->list
		     (vlax-variant-value
		       (vla-GetDynamicBlockProperties new_blk)
		       )
		     )
	      )
	(setq lst4 (vlax-safearray->list
		     (vlax-variant-value
		       (vla-GetDynamicBlockProperties old_blk)
		       )
		     )
	      )
	(mapcar
	  (function
	    (lambda (a b)
	      (if (equal (vla-get-ReadOnly a) :vlax-false)
		(vla-put-Value a (vla-get-Value b))
		)
	      )
	    )
	  lst3 lst4
	  )
	(vla-Update new_blk)
	(vla-Delete old_blk)
	)
      )
    lst
    )
  )

[TararykovDG]

Сообщение от Oliver_88 Мне задача как-то проще казалась.

Мой код больше потому что блоки указывает пользователь непосредственно на чертеже, а это и доп. функция (_tdg-get-object-byselect) и обработка корректности исходных данных.

(setq new_blk (vla-Insertblock model_space (vla-get-InsertionPoint old_blk) new_name_blk 1 1 1 0))
А если угол поворота текущего из заменяемых блоков будет отличаться от нуля?

(ssnamex (ssget "_X" '((0 . "INSERT"))))
Вы перебирает все блоки на чертеже

(ssget "_X" (list (cons 0 "INSERT") (cons 2 (strcat name_old_blk ",`*U#*"))))
у меня только указанный блоки и все динамические.

А если пользователь по ошибке укажет не динамический блок?

Когда кажется креститься надо

[Oliver_88]

TararykovDG, спасибо за критику.

[Serge_Y]

Сообщение от TararykovDG Serge_Y, что-то я навертел походу, но вроде работает, попробуй так

Спасибо! А можно сделать так, чтобы в процессе работы лиспа заменялись не все блоки "2" в чертеже, а только конкретно мною выбранные?
И второй момент, после замены блоков, повторно вставленный в чертеж блок "1" странно модифицируется, т.е. попытка его стретчить в вертикальном направлении приводит к тому, что растягивается только первая линия.

[TararykovDG]

Сообщение от Serge_Y А можно сделать так, чтобы в процессе работы лиспа заменялись не все блоки "2" в чертеже, а только конкретно мною выбранные?

Замени в коде
строку

Код:

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

 
(ssget "_X" (list (cons 0 "INSERT") (cons 2 (strcat name_old_blk ",`*U#*"))))

на строку

Код:

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

 
(ssget (list (cons 0 "INSERT") (cons 2 (strcat name_old_blk ",`*U#*"))))

Сообщение от Serge_Y И второй момент, после замены блоков, повторно вставленный в чертеж блок "1" странно модифицируется, т.е. попытка его стретчить в вертикальном направлении приводит к тому, что растягивается только первая линия.

А вот это странно, и у меня такого не происходит на Твоем же чертеже (пост #7). Да и не должно такого происходить, код не изменяет описания блоков. а работает только с вхождениями блоков. Прикрепи файл где

Сообщение от Serge_Y повторно вставленный в чертеж блок "1" странно модифицируется, т.е. попытка его стретчить в вертикальном направлении приводит к тому, что растягивается только первая линия

[Serge_Y]

Замена строчек приводит к:
"Укажите блок для замены:
Укажите новый блок:
Select objects:
; error: bad argument type: lselsetp nil"

[TararykovDG]

Сообщение от Serge_Y Замена строчек приводит к: "Укажите блок для замены: Укажите новый блок: Select objects: ; error: bad argument type: lselsetp nil"

Укажите блок для замены: - указываем одно вхождение блока который надо заменить
Укажите новый блок: - указываем одно вхождение нового блока
В ответ на запрос Select objects: нужно выбрать (рамкой или по одному или если надо все - то набрать _all) те блоки (несколько вхождений блоков), которые надо заменить на новый блок и нажать Enter

[Do$]

Делал для себя и сам давно пользуюсь такой программой. Работает по принципу matchprop - указываем образец и заменяем на него указываемые блоки. При этом копируются свойства заменяемого блока и значения и свойства атрибутов. Помню при такой программной замене был какой-то глюк, если не соблюсти определенный порядок передачи свойств, приходилось отлавливать и править.

[TararykovDG]

Сообщение от Do$ Делал для себя и сам давно пользуюсь такой программой. Работает по принципу matchprop - указываем образец и заменяем на него указываемые блоки. При этом копируются свойства заменяемого блока и значения и свойства атрибутов. Помню при такой программной замене был какой-то глюк, если не соблюсти определенный порядок передачи свойств, приходилось отлавливать и править.

Do$, подправь код. *adoc* не инициализирован и (vla-StartUndoMark *adoc*) выдает ошибку

[Do$]

Выдрал из сборки, называется... Поправил, спасибо!

[GreyCard]

Добрый день!
Я не программист, но с удовольствием стараюсь пользоваться возможностями Автокада, для того чтобы упростить себе жизнь при проектировании. Программку по замене динамических блоков от TararykovDG с удовольствием юзаю, но заметил некоторую необходимость в сохранении атрибутов (именно атрибутов, как это понимается в Акаде обычному пользователю не программисту). На данный момент данная программка хорошо меняет один динамический блок на другой с сохранением внутренних атрибутов блока, таких как "visible", но значения атрибутов введенных пользователем(к примеру "маркировка оборудования" или "мощность" или "место установки") после замены автоматически устанавливаются значения по умолчанию для данных атрибутов. Прошу вас не могли бы вы немного доработать эту программку ?

[Do$]

Программа из #16 не подойдет?

[GreyCard]

у меня почему то эта программа не определяется. Акад пишет, что он не "знает" функции bchange, хотя лисп-файл я подгрузил. Кстати у меня Акад 2007, может из за этого? Попробую эту прогу на другой версии Када.

[Do$]

Сообщение от GreyCard Кстати у меня Акад 2007, может из за этого?

Должна работать во всех версиях, начиная с 2006.

[TararykovDG]

Сообщение от Do$ Должна работать во всех версиях, начиная с 2006.

Do$, должна и будет работать, если в одной строке добавить недостающую скобку

Код:

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

(vla-StartUndoMark (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))))

[Do$]

Ага, снова невнимательность... Перезалил файл.

[GreyCard]

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

[Do$]

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

[gizmo_zx]

Сообщение от Do$ Программа из #16 не подойдет

Доброго дня.
Эта программулина сохраняет свойства, но не сохраняет атрибуты.
А еще хотелось бы выбирать блоки рамкой, а не тыкать каждый.

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

Может кто допилит из великих гуру

[Do$]

Сообщение от gizmo_zx Эта программулина сохраняет свойства, но не сохраняет атрибуты.

Сохраняет, но там должны быть выполнены определенные условия. Например, количество атрибутов у блока-образца и у заменяемого блока должно быть одинаковое.

[АлексЮстасу]

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

[Кулик Алексей aka kpblc]

Опять (vl-load-com) забыли?

[АлексЮстасу]

Сообщение от Кулик Алексей aka kpblc Опять (vl-load-com) забыли?

В текстах это (vl-load-com) есть и в том, и в другом.
Если они там находятся в нужных местах, то в чем еще может быть дело?

[Кулик Алексей aka kpblc]

Возможно, в необходимости переустановки AutoCAD...

[kakt00z]

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

[Do$]

Сообщение от kakt00z есть мнение (мое скромное) что в 12 каде лисп резанули (раз в коде есть), переУстановка тут не помогет...

Ничего себе новости

[Кулик Алексей aka kpblc]

Я на 2005 и 2006 версиях "ловил" подобное сообщение - слетала регистрация каких-то dll и "рушились" arx, отвечающие за использование СОМ-модели. Как правило, переустановка (правда, не помню - то ли в режиме восстановления, то ли полная) проблему решала.

[Jonas]

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

[Do$]

Сообщение от Jonas В 2112

Offtop: В Жигулях чтоли?

[Jonas]

Сообщение от Do$ Offtop: В Жигулях чтоли?

Точно!

[gizmo_zx]

Бодрого дня.
А моможите с програмкой "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

Хотелось бы не тыкать блок для замены, а выделять рамкой.

[crosandr]

Сообщение от 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

[Denis Ch]

Здравствуйте уважаемые форумчане. Очень нужна помощь по замене одного динамического блока другим. Необходимо заменить один динамический блок отопительного прибора на другой более "легкий" и грамотно сделанный. Блоков несколько сотен в ручную совсем не вариант, а лиспом я не владею. Коды приведенные в теме в моем случае не срабатывают или совсем удаляют заменяемый объект не заменяя его нужным. Помогите пожалуйста, проект горит сдавать надо , а у меня чертежи весят по 15 метров каждый из-за "неправильных" блоков. Чертеж с блоками прикрепляю(формат AutoCad 2010).
Спасибо.

[Олег (jr.)]

Попробуй, сделал по-быстрому вроде работает
(код копируй полностью будет работать на автозагрузке,
если неправильно, нажимай кнопку отменить)

Код:

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

(defun C:REBD(/ blkobj1 blkobj2 ent1 ent2 prop1 prop2 props1 props2 propval1 propval2)
  (vl-load-com)
   (setq acapp (vlax-get-Acad-Object)
     adoc (vla-get-ActiveDocument acapp))
(vla-startundomark adoc)
  (setq osm (getvar 'osmode))
  (setvar 'osmode 4))
  (if (and 
  (setq ent1 (entsel "\nВыбрать заменяемый блок:"))
  (setq p1 (getpoint "\nВыбери точку в центре правого синего круга на заменяемом:"))	
  (setq ent2 (entsel "\nВыбрать заменяющий блок:"))
  (setq p2 (getpoint "\nВыбери точку в центре правого синего круга на заменяющем:")))
    (progn
  (setq blkobj1 (vlax-ename->vla-object (car ent1))
	blkobj2 (vlax-ename->vla-object (car ent2)))
(setq props1 (vlax-invoke blkobj1 'getdynamicblockproperties))
 (setq prop1 (car (vl-remove-if-not (function (lambda(x)(eq "Видимость1"(vlax-get-property x 'PropertyName) ))) props1)))
 (setq propval1 (vlax-get prop1 'Value))
    (setq props2 (vlax-invoke blkobj2 'getdynamicblockproperties))
 (setq prop2 (car (vl-remove-if-not (function (lambda(x)(eq "Выбор1"(vlax-get-property x 'PropertyName) ))) props2)))
 (setq propval2 (vlax-get prop2 'Value))
    
     (vlax-put prop2 'value propval1)
  
(vla-move blkobj2 (vlax-3d-point p2)(vlax-3d-point p1))
    (vla-update blkobj2)
    (vla-delete blkobj1)
    (vlax-release-object blkobj1)))
  (setvar 'osmode osm)
  (vla-endundomark adoc)
  (princ)
  )
(C:REBD)

[Denis Ch]

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

[Олег (jr.)]

Рад если уже легче, попозже вернусь

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

Код:

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

(defun C:REBD(/  acapp acsp adoc allprops axss b blkobj1 blkobj2 bname1 bname2 cp1 cp2 ent1 ent2 maxp
	      maxpt1 maxpt2 minp minpt1 minpt2 newblock prop1 prop2 props1 props2 propval1 rot1 sset)
  (vl-load-com)
   (setq acapp (vlax-get-acad-object)
     adoc (vla-get-activedocument acapp)
	 acsp (vla-get-block(vla-get-activelayout adoc)))
(vla-startundomark adoc)

  (if (setq ent1 (entsel "\nВыбрать заменяемый блок для образца:"))
    (progn
      (setq blkobj1 (vlax-ename->vla-object (car ent1))
	    bname1 (vla-get-effectivename blkobj1))
      (princ "\nВыбрать все заменяемые блоки: \n")
      (setq sset (ssget (list (cons 0 "insert")(cons 2 "`*U*,bname1"))))
      (if (> (sslength sset) 0)
	(progn
    (setq ent2 (entsel "\nВыбрать заменяющий блок для образца:")
 blkobj2 (vlax-ename->vla-object (car ent2))
	  bname2 (vla-get-effectivename blkobj2))
 
(setq axss (vla-get-activeselectionset adoc))
(vlax-for blkobj axss
  (if (eq (vla-get-effectivename blkobj1)bname1)
    (progn
(vla-getboundingbox blkobj 'minp 'maxp)
(setq minpt1 (vlax-safearray->list minp))
  (setq maxpt1 (vlax-safearray->list maxp))
  (setq cp1(mapcar '(lambda(a b)(/ (+ a b) 2))minpt1 maxpt1))

  (setq rot1 (vla-get-rotation blkobj))

(setq props1 (vlax-invoke blkobj 'getdynamicblockproperties))
(setq allprops(vl-remove-if-not (function (lambda(x)(eq "Видимость1"(vlax-get-property x 'PropertyName) ))) props1))
(if allprops
  (progn
 (setq prop1 (car allprops))
 (setq propval1 (vlax-get prop1 'Value))
 
(setq newblock (vla-insertblock acsp (vlax-3d-point cp1) ;|(vla-get-insertionpoint blkobj)|; bname2 1 1 1 0.0))
  (vla-getboundingbox newblock 'minp 'maxp)
(setq minpt2 (vlax-safearray->list minp))
  (setq maxpt2 (vlax-safearray->list maxp))
  (setq cp2(mapcar '(lambda(a b)(/ (+ a b) 2))minpt2 maxpt2))
  (vla-move newblock (vlax-3d-point cp2)(vlax-3d-point cp1))
  
 (setq props2 (vlax-invoke newblock 'getdynamicblockproperties))
 (setq prop2 (car (vl-remove-if-not (function (lambda(x)(wcmatch (vlax-get-property x 'PropertyName) "*Выбор*" ) )) props2)))
 
 (vlax-put prop2 'value propval1)
(vla-move newblock (vlax-3d-point cp2)(vlax-3d-point cp1))

    (vla-update newblock)
    (vla-delete blkobj)
    (vlax-release-object blkobj))))))))))
  
  (vla-endundomark adoc)
  (princ)
  )
(or (vl-load-com)(princ))
(C:REBD)

[Denis Ch]

Попробовал обновленный код.Замена блоков происходит, но они не устанавливаются под нужным углом и код выдает ошибки.

[crosandr]

Denis Ch, код из #40 пробовал?

[Олег (jr.)]

Скинул тебе еще вариант, посмотри в почте что как

[Denis Ch]

Сообщение от crosandr Denis Ch, код из #40 пробовал?

Пробовал, мне он не подходит. Он вообще просто удалил блок, либо перенес его в бесконечные пространства модели и искать я его не стал, так как при такой замене проще всё начертить заново.

[crosandr]

Сообщение от Denis Ch перенес его в бесконечные пространства модели

это оттого, что в исходном блоке точка вставки находится черти-где. Попробуй в редакторе определить точку вставки исходного блока.

[Denis Ch]

Сообщение от crosandr это оттого, что в исходном блоке точка вставки находится черти-где. Попробуй в редакторе определить точку вставки исходного блока.

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

[crosandr]

Сообщение от Denis Ch Похоже как раз в точке вставки блока и проблема.

Уже обсуждалось тут. Для динамических блоков лиспа не знаю, есть лисп для изменения точки вставки статических блоков

[Denis Ch]

Сообщение от crosandr Уже обсуждалось тут. Для динамических блоков лиспа не знаю, есть лисп для изменения точки вставки статических блоков

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

[hwd]

Как вариант решения проблемы с "разлётом" вхождений после переназначения базовой точки: Вычисли разности по осям X и Y между старым значением координат базовой точки и новым. После смены точки вставки, все вхождения перемести по осям X и Y на соответствующие дельты.

UPD
В коде из #44 имеется недостаток: не учтён такой момент, что на заменяемые вхождения блоков в чертеже могут уже иметься ссылки из полей (Fields), например в таблицах... По завершению операции все такие поля превратятся в значения вида #### (поскольку автор кода создаёт новые объекты, с новыми хэндлами и идентификаторами). Это как раз такой случай, когда следует пользоваться DBObject.HandOverTo().

[Denis Ch]

Сообщение от hwd Как вариант решения проблемы с "разлётом" вхождений после переназначения базовой точки: Вычисли разности по осям X и Y между старым значением координат базовой точки и новым. После смены точки вставки, все вхождения перемести по осям X и Y на соответствующие дельты. UPD В коде из #44 имеется недостаток: не учтён такой момент, что на заменяемые вхождения блоков в чертеже могут уже иметься ссылки из полей (Fields), например в таблицах... По завершению операции все такие поля превратятся в значения вида #### (поскольку автор кода создаёт новые объекты, с новыми хэндлами и идентификаторами). Это как раз такой случай, когда следует пользоваться DBObject.HandOverTo().

Возможно и подошел бы вариант с вычислением разности координат, но посмотрев на "разлет" блоков в моем случае, я не увидел какой-либо зависимости они "разлетелись" в абсолютно разные стороны. И по вхождению блоков тоже верно к каждому динамическому блоку привязана табличка отопительного прибора и поля после замены превращаются в значение вида #### .

[hwd]

Сообщение от Denis Ch я не увидел какой-либо зависимости они "разлетелись" в абсолютно разные стороны.

Разные определения блоков (у тебя их там несколько), имеют разные "кривые" точки вставки, поэтому смещения у вхождений будут отличаться. Кроме того, возможно, что в своём чертеже к каким-то вхождениям блоков ты применял команду _.MIRROR.

[Denis Ch]

Сообщение от hwd Разные определения блоков (у тебя их там несколько), имеют разные "кривые" точки вставки, поэтому смещения у вхождений будут отличаться. Кроме того, возможно, что в своём чертеже к каким-то вхождениям блоков ты применял команду _.MIRROR.

Именно так блок который мне нужно заменить сделан очень криво. Команда _.MIRROR так же применялась.

[hwd]

Сама по себе задача по корректной замене определений блоков, как обычных, так и динамических - весьма интересная и полезная. Много нюансов, которые следует учитывать. Из того, что вижу на вскидку:
1. Одно из участвующих в замене определений блоков может быть аннотативным, в то время как другое - не аннотативным (соответственно возникнут проблемы корректного отображения в различных видовых экранах). Новые вхождения блоков, если они аннотативны как и старые, должны получать тот же список аннотативных масштабов.
2. На некоторые свойства "старых" вхождений блоков, в чертеже могут иметься ссылки в виде полей - банальная замена блоков разрушит все связи.
3. Точки вставки в обоих определениях блоков могут размещаться таким образом, что после замены определений блоков, потребуется выполнять программно некоторое смещение позиций вхождений уже имеющихся блоков (на соответствующие дельты) с учётом того, было ли отзеркалено это вхождение (проверяем направление векторов).
4. Исходные вхождения блоков могут иметь подписку (выполненную программным образом, как я показывал выше по ссылке) на различные события - это тоже следует учитывать и корректно "разруливать". Одни юзеры с этим пунктом могут не сталкиваться, в то время как у других может иметься софт, который активно использует эту возможность - поэтому данный момент так же стоит учитывать.
5. Следует учитывать коэффициенты масштабирования "старых" вхождений блоков.
6. Следует учитывать то, на каких слоях размещаются "старые" вхождения блоков
7. Следует учитывать углы поворота "старых" вхождений блоков
8. Следует учитывать текущие параметры видимости "старых" вхождений блоков.
9. Следует учитывать, что в "старых" вхождениях ранее были назначены некоторые значения различных параметров, выбранных либо из списка, либо полученных за счёт манипуляции с "ручками".
10. Возможно в новом определении блока имена параметров, обозначенных в п.8 и п.9 будут иными. Т.о. нужно предоставить юзеру возможность указать соответствия имён.

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

[Denis Ch]

Сразу чувствуется подход профессионала.

Сама по себе задача по корректной замене определений блоков, как обычных, так и динамических - весьма интересная и полезная. Много нюансов, которые следует учитывать. Из того, что вижу на вскидку: 1. Одно из участвующих в замене определений блоков может быть аннотативным, в то время как другое - не аннотативным (соответственно возникнут проблемы корректного отображения в различных видовых экранах). Новые вхождения блоков, если они аннотативны как и старые, должны получать тот же список аннотативных масштабов.

Аннотативность я не применял, по крайней мере специально.

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

Связи есть и они разрушаются при замене блоков и приходится всё заново выставлять в ручную.

3. Точки вставки в обоих определениях блоков могут размещаться таким образом, что после замены определений блоков, потребуется выполнять программно некоторое смещение позиций вхождений уже имеющихся блоков (на соответствующие дельты) с учётом того, было ли отзеркалено это вхождение (проверяем направление векторов).

Некоторые вхождения были отзеркалены, но вот какие-это уже сказать сложнее, так как старый блок сделан из множества объектов, которые просто скрываются или показываются в зависимости от видимости. И зеркальных отражений в старом блоке порядка 20 шт.

4. Исходные вхождения блоков могут иметь подписку (выполненную программным образом, как я показывал выше по ссылке) на различные события - это тоже следует учитывать и корректно "разруливать". Одни юзеры с этим пунктом могут не сталкиваться, в то время как у других может иметься софт, который активно использует эту возможность - поэтому данный момент так же стоит учитывать.

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

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

Слой один и тот же.

7. Следует учитывать углы поворота "старых" вхождений блоков

Углы поворота различные.

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

[hwd]

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

Так оно и есть, причём в ходе её решения наверняка вылезут и др. подводные камни, которые я упустил в перечисленном выше списке. В приципе задача решаема, но под это дело нужно выделить достаточно времени и сил. Поставлю себе в планах "зарубку" на её решение - моим пользователям может пригодиться. Если что - на результат дам ссылку. Предупреждаю сразу - это будет не AutoLISP\Visual LISP, а .NET. Т.е. для каждой версии AutoCAD будет своя, отдельная версия библиотеки. Я не компилирую код для AutoCAD, версий ниже чем 2009-й (нет необходимости/желания/возможности).

[Дима_]

Сообщение от hwd 2. На некоторые свойства "старых" вхождений блоков, в чертеже могут иметься ссылки в виде полей - банальная замена блоков разрушит все связи. ... 4. Исходные вхождения блоков могут иметь подписку (выполненную программным образом, как я показывал выше по ссылке) на различные события - это тоже следует учитывать и корректно "разруливать". Одни юзеры с этим пунктом могут не сталкиваться, в то время как у других может иметься софт, который активно использует эту возможность - поэтому данный момент так же стоит учитывать.

Мне кажется эти пункты полностью решить никак не получится.

[Do$]

Вдобавок к #57:
Накинь еще пяток-другой пунктов, если блоки с атрибутами.

[hwd]

Сообщение от Дима_ Мне кажется эти пункты полностью решить никак не получится.

Зависит от конкретной ситуации... Если, к примеру, была завязка на чтение значения радиуса окружности, а в новом определении вместо окружности под тем же идентификатором вдруг стал прямоугольник, то в этом случае конечно, без вариантов, поскольку радиуса там и в помине нет. Но если в новом блоке под тем же ObjectId будет окружность или дуга (к примеру), то очень даже решаемо.

Сообщение от Do$ Вдобавок к #57: Накинь еще пяток-другой пунктов, если блоки с атрибутами.

Я не выделял это в отдельный пункт, поскольку это частный случай для п.2 (во всяком случае они схожи по сути и решению).

[Do$]

Сообщение от hwd Я не выделял это в отдельный пункт, поскольку это частный случай для п.2 (во всяком случае они схожи по сути и решению).

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

Это только часть задачи. Помимо значений, у них могут быть собственные геометрические характеристики: положение, поворот и т.п. А еще цвет, шрифт, коэффициент сжатия, угол наклона и т.п. К тому же, может оказаться что у заменяющего и заменяемого блока разное количество атрибутов... Так что, с атрибутами еще отдельно придется плотно разбираться.

[Krovlaf]

Уважаемый Do$! Не могли ли Вы, по возможности, дополнить Ваш лисп выбором всех заменяемых динамических блоков и множественным выбором рамкой? По моему, из всего вышепредложенного, bchange.LSP наиболее корректно меняет динамические блоки.

[Krovlaf]

Нашел! Весьма неплохой "реплейсер" блоков. Насчет особенностей сохранения динамических свойств сильно не разбирался. Для меня важно было сохранение значений атрибутов с совпадающими именами в заменяемых блоках без учета количества самих атрибутов, а также множественный выбор заменяемых блоков. Все это прекрасно реализовано.

[АлексЮстасу]

Сообщение от Krovlaf Нашел! Весьма неплохой "реплейсер" блоков.

Загрузка выдает сообщение: The RBLOC.dcl file is not found. Или это не программа еще для пользователей?

[Krovlaf]

Наверное, я сделал несколько коряво (как правильно компиллировать lsp и dcl, подскажут наши уважаемые лисперы).
В тексте представленного кода две части - RBLOC V2.22 и RBLOC.DCL V2.20. Я скопировал первую часть файла и обозвал это rb.lsp вторую часть назвал, как потребовала программа rbloc.dcl. Далее, все как обычно для запуска приложений (оба файла в папку с приложениями к Акаду). Единственное, в файле RBLOC.DCL нужно удалить строку с названием (** Rbloc.dcl **), а то ошибку выдает.

[Кулик Алексей aka kpblc]

Код:

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

 ;;;=================================================================
;;;
;;; RBLOC V2.22
;;;
;;; Replace a block with another
;;;
;;; Copyright (C) Patrick_35
;;; Translated to English and cosmetic changed by Igal Averbuh 2015
;;;=================================================================

(defun c:rb (/             bl            conserver_attr              conserver_dyna              dcl_id
             echo          echu          echx          echy          echz          js            liste_bl
             obj_liste     old_error     redef         resultat      selectiono    selectionr    *errrbloc*
             msgbox        affiche_choix idem_lst      ech_u         affiche_dial  liste_choix   liste_sel
             selection     verif_valeur  parcourir     selection_ecran             changer_blocs dcl_file
             )

;;;---------------------------------------------------------------
;;;
;;; Gestion des erreurs
;;;
;;;---------------------------------------------------------------

  (defun *errrbloc* (msg)
    (if (/= msg "Function cancelled")
      (if (= msg "quit / exit abort")
        (princ)
        (princ (strcat "\nErreur : " msg))
        ) ;_ end of if
      (princ)
      ) ;_ end of if
    (setq *error* old_error)
    (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
    (princ)
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; Message
;;;
;;;---------------------------------------------------------------

  (defun msgbox (titre bouttons message / reponse wshshell)
    (vl-load-com)
    (setq wshshell (vlax-create-object "WScript.Shell"))
    (setq reponse (vlax-invoke wshshell 'popup message 0 titre (itoa bouttons)))
    (vlax-release-object wshshell)
    reponse
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; Affichage tu type de s?lection du bloc d'origine
;;;
;;;---------------------------------------------------------------

  (defun affiche_choix ()
    (if (eq selectiono "0")
      (if js
        (set_tile "texte1" (strcat "Multiply Selection of " (itoa (sslength js)) " block(s)"))
        (set_tile "texte1" "Multiply Selection in whole drawing")
        ) ;_ end of if
      (if js
        (set_tile "texte1" (strcat "Final Selection of " (itoa (sslength js)) " block(s)"))
        (set_tile "texte1" "Final Selection in whole drawing")
        ) ;_ end of if
      ) ;_ end of if
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; Comparaison des deux listes
;;;
;;;---------------------------------------------------------------

  (defun idem_lst ()
    (if (and (eq (1- (atoi selectiono)) (atoi selectionr)) (not redef))
      (progn
        (set_tile "texte2" "The orriginal and replacement block can not be same")
        (mode_tile "accept" 1)
        (mode_tile "cancel" 2)
        ) ;_ end of progn
      (progn
        (if redef
          (set_tile "texte2" (strcat "Block : " redef))
          (set_tile "texte2" "")
          ) ;_ end of if
        (mode_tile "accept" 0)
        (mode_tile "accept" 2)
        ) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; Gestion de l'afficjage des facteurs d'?chelles
;;;
;;;---------------------------------------------------------------

  (defun ech_u ()
    (if (eq echo "1")
      (progn
        (mode_tile "fact_x" 1)
        (mode_tile "fact_y" 1)
        (mode_tile "fact_z" 1)
        (mode_tile "uniforme" 1)
        ) ;_ end of progn
      (progn
        (mode_tile "fact_x" 0)
        (mode_tile "uniforme" 0)
        (if (eq echu "1")
          (progn
            (mode_tile "fact_y" 1)
            (mode_tile "fact_z" 1)
            ) ;_ end of progn
          (progn
            (mode_tile "fact_y" 0)
            (mode_tile "fact_z" 0)
            ) ;_ end of progn
          ) ;_ end of if
        ) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; Afficher la boite de dialogue
;;;
;;;---------------------------------------------------------------

  (defun affiche_dial ()
    (new_dialog "rbloc" dcl_id)
    (set_tile "titre" "Block Replacer V2.22")
    (start_list "listeo")
    (add_list "** Blocks List **")
    (mapcar 'add_list liste_bl)
    (end_list)
    (set_tile "listeo" selectiono)
    (set_tile "attr" conserver_attr)
    (set_tile "dyna" conserver_dyna)
    (affiche_choix)
    (start_list "lister")
    (mapcar 'add_list liste_bl)
    (end_list)
    (set_tile "lister" selectionr)
    (if redef
      (mode_tile "lister" 1)
      (mode_tile "lister" 0)
      ) ;_ end of if
    (set_tile "echori" echo)
    (set_tile "fact_x" echx)
    (set_tile "fact_y" echy)
    (set_tile "fact_z" echz)
    (set_tile "uniforme" echu)
    (ech_u)
    (idem_lst)
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; Comparaison avec la liste du bloc rempla?ant
;;;
;;;---------------------------------------------------------------

  (defun liste_choix (val)
    (setq selectiono val
          js nil
          ) ;_ end of setq
    (affiche_choix)
    (idem_lst)
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; Comparaison avec la liste du bloc d'origine
;;;
;;;---------------------------------------------------------------

  (defun liste_sel (val)
    (setq selectionr val)
    (idem_lst)
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; S?lection dans le dessin suivant un filtre
;;;
;;;---------------------------------------------------------------

  (defun selection (/ js1)
    (if (eq selectiono "0")
      (setq js1 (ssget (list (cons 0 "INSERT"))))
      (setq js1 (ssget (list (cons 0 "INSERT") (cons 2 (strcat (nth (1- (atoi selectiono)) liste_bl) ",`*U*")))))
      ) ;_ end of if
    (and js1
         (setq js js1)
         ) ;_ end of and
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; V?rification que la valeur z?ro n'est pas entr?e
;;;
;;;---------------------------------------------------------------

  (defun verif_valeur (var val)
    (if (zerop (read val))
      (cond
        ((= var "x")
         (set_tile "texte3" "The X Scale factor can not be 0")
         (mode_tile "fact_x" 2)
         )
        ((= var "y")
         (set_tile "texte3" "The Y Scale factor can not be 0")
         (mode_tile "fact_y" 2)
         )
        ((= var "z")
         (set_tile "texte3" "The Z Scale factor can not be 0")
         (mode_tile "fact_z" 2)
         )
        ) ;_ end of cond
      (cond
        ((= var "x")
         (set_tile "texte3" "")
         (setq echx val)
         )
        ((= var "y")
         (set_tile "texte3" "")
         (setq echy val)
         )
        ((= var "z")
         (set_tile "texte3" "")
         (setq echz val)
         )
        ) ;_ end of cond
      ) ;_ end of if
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; Rechercher un bloc en tant que fichier
;;;
;;;---------------------------------------------------------------

  (defun parcourir (/ fic n result trouve)
    (if (setq fic (getfiled "Select External Block" "" "dwg" 16))
      (progn
        (setq n 0
              redef nil
              ) ;_ end of setq
        (while (nth n liste_bl)
          (if (eq (strcase (nth n liste_bl)) (strcase (vl-filename-base fic)))
            (progn
              (setq trouve t)
              (setq result (msgbox "Existing Block"
                                   (+ 4 48 256)
                                   (strcat "The Block "
                                           (strcase (nth n liste_bl))
                                           " Exist in the drawing.\nDo you want to replace it?"
                                           ) ;_ end of strcat
                                   ) ;_ end of msgbox
                    ) ;_ end of setq
              (if (eq result 6)
                (setq redef fic
                      selectionr (itoa n)
                      ) ;_ end of setq
                (setq redef nil
                      selectionr (itoa n)
                      ) ;_ end of setq
                ) ;_ end of if
              ) ;_ end of progn
            ) ;_ end of if
          (setq n (1+ n))
          ) ;_ end of while
        (or trouve redef (setq redef fic))
        ) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; Selection d'un bloc remplacant sur l'?cran
;;;
;;;---------------------------------------------------------------

  (defun selection_ecran (/ bl n no sel)
    (while (not (setq sel (ssget "_:E:S" (list (cons 0 "INSERT")))))
      (princ "\nPlease Select Block.")
      ) ;_ end of while
    (setq no (vlax-ename->vla-object (ssname sel 0))
          no (if (vlax-property-available-p no 'effectivename)
               (vla-get-effectivename no)
               (vla-get-name no)
               ) ;_ end of if
          ) ;_ end of setq
    (setq sel (tblsearch "block" no)
          n   0
          ) ;_ end of setq
    (if (and (not (eq (logand (cdr (assoc 70 sel)) 1) 1))
             (not (eq (logand (cdr (assoc 70 sel)) 4) 4))
             (not (eq (logand (cdr (assoc 70 sel)) 16) 16))
             ) ;_ end of and
      (while (setq bl (nth n liste_bl))
        (if (eq (cdr (assoc 2 sel)) bl)
          (setq selectionr (itoa n))
          ) ;_ end of if
        (setq n (1+ n))
        ) ;_ end of while
      (msgbox "" 48 "This block is an xref.")
      ) ;_ end of if
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; Remplacer un bloc par un autre
;;;
;;;---------------------------------------------------------------

  (defun changer_blocs (/ bl n nbl nn no nw imod nom cont result sav_dyna tot)
    (if (and (not js) (eq selectiono "0"))
      (progn
        (setq result (msgbox "ATTENTION !!!"
                             (+ 4 16 256)
                             "You will replace all blocks of the drawing by a TYPE ONLY !!!\nDo you want to continue?"
                             ) ;_ end of msgbox
              ) ;_ end of setq
        (if (eq result 7)
          (setq cont t)
          ) ;_ end of if
        ) ;_ end of progn
      ) ;_ end of if
    (if (not cont)
      (progn
        (setq imod (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
        (if redef
          (progn
            (vla-delete (vla-insertblock imod (vlax-3d-point '(0.0 0.0 0.0)) redef 1 1 1 0))
            (setq nom (vl-filename-base redef))
            ) ;_ end of progn
          (setq nom (nth (atoi selectionr) liste_bl))
          ) ;_ end of if
        (if (not js)
          (if (eq selectiono "0")
            (setq js (ssget "x" (list (cons 0 "INSERT"))))
            (setq
              js (ssget "x" (list (cons 0 "INSERT") (cons 2 (strcat (nth (1- (atoi selectiono)) liste_bl) ",`*U*"))))
              ) ;_ end of setq
            ) ;_ end of if
          ) ;_ end of if
        (setq n 0
              tot 0
              ) ;_ end of setq
        (while (ssname js n)
          (setq bl (entget (ssname js n))
                nw (vlax-ename->vla-object (ssname js n))
                no (if (vlax-property-available-p nw 'effectivename)
                     (vla-get-effectivename nw)
                     (vla-get-name nw)
                     ) ;_ end of if
                ) ;_ end of setq
          (if (or (eq selectiono "0")
                  (and (not (eq selectiono "0"))
                       (eq no (nth (1- (atoi selectiono)) liste_bl))
                       ) ;_ end of and
                  ) ;_ end of or
            (progn
              (and (eq conserver_dyna "1")
                   (eq (vla-get-isdynamicblock nw) :vlax-true)
                   (setq sav_dyna (mapcar '(lambda (x) (cons (vla-get-propertyname x) (vla-get-value x)))
                                          (vlax-invoke nw 'getdynamicblockproperties)
                                          ) ;_ end of mapcar
                         ) ;_ end of setq
                   ) ;_ end of and
              (if (eq conserver_attr "1")
                (if (not (eq (strcase no) (strcase nom)))
                  (setq bl (subst (cons 2 nom) (assoc 2 bl) bl))
                  ) ;_ end of if
                (progn
                  (setq nbl (entget (vlax-vla-object->ename (vla-insertblock imod
                                                                             (vlax-3d-point (cdr (assoc 10 bl)))
                                                                             nom
                                                                             (cdr (assoc 41 bl))
                                                                             (cdr (assoc 42 bl))
                                                                             (cdr (assoc 43 bl))
                                                                             (cdr (assoc 50 bl))
                                                                             ) ;_ end of vla-insertblock
                                                            ) ;_ end of vlax-vla-object->ename
                                    ) ;_ end of entget
                        ) ;_ end of setq
                  (entdel (cdr (assoc -1 bl)))
                  (foreach n '(6 8 44 45 67 70 71 210 410)
                    (setq nbl (subst (assoc n bl) (assoc n nbl) nbl))
                    ) ;_ end of foreach
                  (setq bl nbl)
                  ) ;_ end of progn
                ) ;_ end of if
              (if (eq echo "0")
                (if (eq echu "0")
                  (setq bl (subst (cons 41 (atof echx)) (assoc 41 bl) bl)
                        bl (subst (cons 42 (atof echy)) (assoc 42 bl) bl)
                        bl (subst (cons 43 (atof echz)) (assoc 43 bl) bl)
                        ) ;_ end of setq
                  (setq bl (subst (cons 41 (atof echx)) (assoc 41 bl) bl)
                        bl (subst (cons 42 (atof echx)) (assoc 42 bl) bl)
                        bl (subst (cons 43 (atof echx)) (assoc 43 bl) bl)
                        ) ;_ end of setq
                  ) ;_ end of if
                ) ;_ end of if
              (entmod bl)
              (entupd (cdr (assoc -1 bl)))
              (setq nw (vlax-ename->vla-object (cdr (assoc -1 bl))))
              (and (eq conserver_dyna "1")
                   (eq (vla-get-isdynamicblock nw) :vlax-true)
                   (progn
                     (foreach no (vlax-invoke nw 'getdynamicblockproperties)
                       (and (setq nn (assoc (vla-get-propertyname no) sav_dyna))
                            (/= (car nn) "Origin")
                            (/= (vlax-get no 'value) (vlax-variant-value (cdr nn)))
                            (vl-catch-all-apply 'vla-put-value (list no (cdr nn)))
                            ) ;_ end of and
                       ) ;_ end of foreach
                     ) ;_ end of progn
                   ) ;_ end of and
              (setq tot (1+ tot))
              ) ;_ end of progn
            ) ;_ end of if
          (setq n (1+ n))
          ) ;_ end of while
        (princ (strcat "\n\tRemplacement of " (itoa tot) " block(s)."))
        ) ;_ end of progn
      (princ "\n\tAbort.")
      ) ;_ end of if
    ) ;_ end of defun

;;;---------------------------------------------------------------
;;;
;;; Routine principale.
;;;
;;;---------------------------------------------------------------

  (vl-load-com)
  (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
  (setq old_error *error*
        *error*   *errrbloc*
        ) ;_ end of setq
  (if (setq dcl_file (cond
                       ((findfile "rbloc.dcl"))
                       (t
                        ((lambda (/ file handle)
                           (setq file   (strcat (vl-string-right-trim "\\" (getenv "temp")) "\\dlg.dcl")
                                 handle (open file "w")
                                 ) ;_ end of setq
                           (foreach item '("// ================================================================="
                                           "//"
                                           "// RBLOC.DCL V2.20"
                                           "//"
                                           "// Copyright (C) Patrick_35"
                                           "// Translated to English and cosmetic changed by Igal Averbuh 2015"
                                           "// ================================================================="
                                           "rbloc : dialog {"
                                           "key = \"titre\";"
                                           "is_cancel = true;"
                                           ": boxed_column {"
                                           "label = \" Original OLD Block \";"
                                           ": row {"
                                           ": popup_list {key = \"listeo\"; width = 30; label = \"Name\";}"
                                           ": button {key = \"sel\"; width = 15; label = \"Select...\";}"
                                           "}"
                                           "spacer;"
                                           ": toggle {key = \"attr\"; label = \"Keep attributes\";}"
                                           ": toggle {key = \"dyna\"; label = \"Keep Dynamic Properties\";}"
                                           ": text {key = \"texte1\";}"
                                           "}"
                                           ": boxed_column {"
                                           "label = \" Replacement NEW Block \";"
                                           ": popup_list {key = \"lister\"; width = 30; label = \"Name\";}"
                                           "spacer;"
                                           ": row {"
                                           ": button {key = \"pick\"; width = 15; label = \"Select...\";}"
                                           ": button {key = \"rech\"; width = 15; label = \"Browse...\";}"
                                           "}"
                                           ": text {key = \"texte2\";}"
                                           "}"
                                           ": boxed_column {"
                                           "label = \" Scale \";"
                                           ": toggle {key = \"echori\"; label = \"Keep original scale\";}"
                                           ": toggle {key = \"uniforme\"; label = \"Uniform Scale\";}"
                                           ": row {"
                                           ": edit_box {key = \"fact_x\"; width = 5; label = \"X:\";}"
                                           ": edit_box {key = \"fact_y\"; width = 5; label = \"Y:\";}"
                                           ": edit_box {key = \"fact_z\"; width = 5; label = \"Z:\";}"
                                           "}"
                                           ": text {key = \"texte3\";}"
                                           "}"
                                           "spacer;"
                                           "ok_cancel;"
                                           "}"
                                           )
                             (write-line item handle)
                             ) ;_ end of foreach
                           (close handle)
                           file
                           ) ;_ end of lambda
                         )
                        )
                       ) ;_ end of cond
            ) ;_ end of setq
    (progn
      (setq bl (tblnext "block" t))
      (while bl
        (if (and (not (eq (logand (cdr (assoc 70 bl)) 1) 1))
                 (not (eq (logand (cdr (assoc 70 bl)) 4) 4))
                 (not (eq (logand (cdr (assoc 70 bl)) 16) 16))
                 ) ;_ end of and
          (setq liste_bl (append liste_bl (list (cdr (assoc 2 bl)))))
          ) ;_ end of if
        (setq bl (tblnext "block"))
        ) ;_ end of while
      (if liste_bl
        (progn
          (setq dcl_id         (load_dialog dcl_file)
                liste_bl       (acad_strlsort liste_bl)
                conserver_attr "1"
                conserver_dyna "1"
                selectiono     "0"
                selectionr     "0"
                echo           "1"
                echu           "0"
                echx           "1"
                echy           "1"
                echz           "1"
                ) ;_ end of setq
          (while (and (not (eq resultat 0)) (not (eq resultat 1)))
            (affiche_dial)
            (mode_tile "accept" 2)
            (action_tile "listeo" "(liste_choix $value)")
            (action_tile "lister" "(liste_sel $value)")
            (action_tile "sel" "(done_dialog 2)")
            (action_tile "rech" "(done_dialog 3)")
            (action_tile "pick" "(done_dialog 4)")
            (action_tile "attr" "(setq conserver_attr $value)")
            (action_tile "dyna" "(setq conserver_dyna $value)")
            (action_tile "echori" "(setq echo $value)(ech_u)")
            (action_tile "fact_x" "(verif_valeur \"x\" $value)")
            (action_tile "fact_y" "(verif_valeur \"y\" $value)")
            (action_tile "fact_z" "(verif_valeur \"z\" $value)")
            (action_tile "uniforme" "(setq echu $value)(ech_u)")
            (action_tile "cancel" "(done_dialog 0)")
            (action_tile "accept" "(done_dialog 1)")
            (setq resultat (start_dialog))
            (cond
              ((= resultat 1)
               (changer_blocs)
               )
              ((= resultat 2)
               (selection)
               )
              ((= resultat 3)
               (parcourir)
               )
              ((= resultat 4)
               (selection_ecran)
               )
              ) ;_ end of cond
            ) ;_ end of while
          (unload_dialog dcl_id)
          ) ;_ end of progn
        (msgbox "" 48 "No block in the drawing")
        ) ;_ end of if
      ) ;_ end of progn
    (msgbox "" 16 "The RBLOC.DCL file is not found.")
    ) ;_ end of if
  (setq *error* old_error)
  (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
  (princ)
  ) ;_ end of defun

(setq nom_lisp "RBLOC")
(if (/= app nil)
  (if (= (strcase (substr app (1+ (- (strlen app) (strlen nom_lisp))) (strlen nom_lisp))) nom_lisp)
    (princ (strcat "..." nom_lisp " charg?."))
    (princ (strcat "\n" nom_lisp ".LSP Loaded....."))
    ) ;_ end of if
  (princ (strcat "\n" nom_lisp ".LSP Loaded......"))
  ) ;_ end of if
(setq nom_lisp nil)

(princ)

Дополнительно: убран самовызов при загрузке; код не оптимизировался и практически не менялся

[Krovlaf]

Спасибо! Все работает!

[RAD24]

Добрый день! Подскажите как заменить вхождение блока одного или нескольких сразу в чертеже? Блоки, на которые нужно менять старые- находятся в новом файле естественно (имена блоков для замены одинаковые). Желательно чтобы это работало в BricsCADe.

[crosandr]

Сообщение от RAD24 Подскажите как заменить вхождение блока одного или нескольких сразу в чертеже?

В акаде через Design Centrer можно сделать

[RAD24]

Да, можно, а c помощью lisp? Мне для удобства в BricsCADe хотелось бы.

[Boxa]

http://forum.dwg.ru/showthread.php?t=145333
не лисп, но адаптировать для BricsCAD думаю можно...

[RAD24]

Спасибо, почему то не загружается , ошибка : NETLOAD

Loading .NET runtime v4.0.30319:

Error Message: Не удалось загрузить файл или сборку "file:///C:\1Времянка\dynINOUT_2013-2018\dynINOUT_2017.dll" либо одну из их зависимостей. Операция не поддерживается. (Исключение из HRESULT: 0x80131515)(NETLOAD)

----- добавлено через 18 сек. -----
Это в Bricscade

[Boxa]

RAD24, эээ... я же написал:

Сообщение от Boxa но адаптировать для BricsCAD думаю можно...

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

[Сергей812]

Сообщение от RAD24 Добрый день! Подскажите как заменить вхождение блока одного или нескольких сразу в чертеже? Блоки, на которые нужно менять старые- находятся в новом файле естественно (имена блоков для замены одинаковые). Желательно чтобы это работало в BricsCADe.

Синхронизация блоков от Бушмана Андрея. Но это опять же под акад.

[RAD24]

Спасибо, посмотрю

[Dimitriy]

Проблемка с динамическим блоком: в модель вставляю - вижу его, он есть. Вставляю на поле листа - нет его. В чем проблема?

[zenon]

Сообщение от Dimitriy Проблемка с динамическим блоком: в модель вставляю - вижу его, он есть. Вставляю на поле листа - нет его. В чем проблема?

Разберись для начала с единицами чертежа.
А то размер рамки 594х420. а единицы чертежа в дюймах.

[Dimitriy]

Сообщение от zenon Разберись для начала с единицами чертежа. А то размер рамки 594х420. а единицы чертежа в дюймах.

Это не влияет никак. Если не знаете ответ, не надо писать "умные" фразы.

[Boxa]

Делать подобные блоки аннотативными - плохая идея, а указывать масштаб отличный от 1:1 в двойне.

[Кулик Алексей aka kpblc]

Сообщение от Dimitriy Это не влияет никак.

Да ну??

[Dimitriy]

Сообщение от Кулик Алексей aka kpblc Да ну??

Уже проверил. У меня был примерно аналогичный случай. Исправил путем перевода разных слоев в один.
А тут такой номер не прошёл....