[mankurt]

Только изучаю лисп, но пытаюсь сделать следующую штуку.

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

Навскидку подходит лисп отсюда:

Код:

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

 (defun replace( b_in b_out / ) 
(setq s_in (cons 2 b_in)) 
(if(/= nil (setq blokset (ssget "_X" (list '( 0 . "INS ERT") s_in)))) 
  (progn 
  (setq blklength (sslength blokset)) 
  (setq i -1 ) 
  (repeat blklength 
     (setq i (1+ i))       
     (setq name_blk (ssname blokset i)) 
     (setq spis_blk (entget name_blk)) 
     (setq kord_b   (cdr(assoc 10 spis_blk))) 
     (setq ugol (*(cdr(assoc 50 spis_blk)) 57.297469)) 
     (command "_.insert" b_out kord_b scl scl ugol) 
  ) ;repeat 
  (setq i -1) 
  (repeat blklength 
   (setq i (1+ i)) 
   (entdel (ssname blokset i)) 
  ) ;repeat 
  ) ;progn 
) ;if 
) 

(defun c:b2b( / snp scl) 
(command "_.undo" "_begin") 
(setq snp (getvar "Osmode")) 
(setvar "Osmode" 0) 
(setq scl (getvar "userr1")) 
(if(= 0 scl)(se tq scl 1.0)) 

(replace "a1" "b1") 
(replace "a2" "b2") 
(replace "a3" "b3") 

(setvar "Osmode" snp) 
(command "_.undo" "_end") 
)

Чтобы передать атрибуты вроде подходят функции get-all-atts и mip-block-setattr-bylist

Код:

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

 (defun get-all-atts (obj)
    ;;;Use (get-all-atts (car(entsel "\nSelect block:")))
    ;;;Returs list  (("TAG1" . "Value1")("TAG2" . "Value2") ...)
    (if (= (type obj) 'ENAME)
		(setq obj (vlax-ename->vla-object obj)))
  (if (and obj
           (vlax-property-available-p obj 'Hasattributes)
	   (eq :vlax-true (vla-get-HasAttributes obj))
      )
    (vl-catch-all-apply
      (function
	(lambda	()
	  (mapcar (function (lambda (x)
			      (cons (vla-get-TagString x)
				    (vla-get-TextString x)
			      )
			    )
		  )
		  (append (vlax-invoke obj 'Getattributes)
			  (vlax-invoke obj 'Getconstantattributes)
		  )
	  )
	)
      )
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun mip-conv-to-str (dat)
  (cond ((= (type dat) 'INT)(setq dat (itoa dat)))
         ((= (type dat) 'REAL)(setq dat (rtos dat 2 12)))
        ((null dat)(setq dat ""))
        (t (setq dat (vl-princ-to-string dat)))))
(defun mip-block-setattr-bylist (obj att_list / txt lst)
;; obj - Ename or Vla object of block
;; att_list - list ((Tag_Name1 . Value1)(Tag_Name2 . Value2) ...)
;;                 Tag_Name - string
;;                    Value - string
  
(vl-load-com)
(if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
(setq att_list (mapcar '(lambda(x)(cons (strcase (mip-conv-to-str(car x)))(mip-conv-to-str(cdr x)))) att_list))
  (if (and obj
           (not(vlax-erased-p obj))
           (= (vla-get-ObjectName obj) "AcDbBlockReference")
	   (eq :vlax-true (vla-get-HasAttributes obj))
	   (vlax-property-available-p obj 'Hasattributes)
	   (vlax-write-enabled-p obj)
      )
    (vl-catch-all-apply
      (function
	(lambda	()
          (foreach at (vlax-invoke obj 'Getattributes)
            (if (setq lst (assoc(strcase(vla-get-TagString at)) att_list))
              (vla-put-TextString at (cdr lst))
            )
            )
          )
        )
      )
    )
  )

Но столкнулся с следующими проблемами, подскажите, как решить:
1) Целевой блок ищется по пути в options, но он представляет собой не отдельный чертеж одноименный с блоком, а содержится в базе чертежа(доступен из design centre) и не отрисован в пространстве модели. Соответственно блок не находится. Что с этим делать?
2) Исходный блок содержит атрибуты, которые нужно не потерять. Целевой блок (которым надо заменить) из библиотеки атрибутов не содержит. Функция mip-conv-to-str работает, только если в целевом блоке есть такие же атрибуты, как и в блоке-доноре. Как осуществить передачу атрибутов от исходного в новый блок? Для этого обязательно требуется редактировать библиотеку целевых блоков и вручную присваивать им те же теги атрибутов? Какими средствами их можно создать/перенести?
Спасибо за ответы.

[Дима_]

На все вопросы могу дать только 1 общий ответ - изучайте объектную модель автокада.

[mankurt]

Посидел, поразбирался, пошерстил на предмет нужных кусков кода и вот что получилось. Делал под свои нужды, за грамотность кода не отвечаю, буду благодарен, если кто-то оптимизирует или на ошибки укажет.
Программа заменяет скопом блоки одной библиотеки в блоки другой библиотеки dwg, путь к которой запрашивается в начале выполнения. Библиотека при этом должна быть закрыта.
Соответствие блоков задается в тексте программы по имени. Целевым блокам передаются пара атрибутов NAME и FEATURE_CODE, присутствующие в исходном блоке, слой, цвет, угол разворота.

Код:

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

 ;|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;         Программа замены блоков          ;
;         библиотеки по заданному соответствию имен                                  ;
;                                                              ;
;                                                                                    ;
;         !Ниже задаем соответствие имен блоков, которые нужно заменить              ;
;         Файл библиотеки, на которую ссылаемся, должен быть закрыт                  ;
;                                                                                    ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|;

;---------------основная функция-----------------------------------------------------;
(defun C:test( / osmode_old osnapcoord_old layer_old osnapz_old scale echo_old Dbx)
  (vl-load-com)
  (vl-cmdf "_.undo" "_begin")
  
    (setq osmode_old (getvar "osmode")  
	  osnapcoord_old (getvar "osnapcoord")
	  layer_old (getvar "CLAYER")
	  osnapz_old (getvar "osnapz")
	  echo_old (getvar "CMDECHO")
      )
  
    (disable_osmode)
    (setvar "CMDECHO" 0)
  
    (setq scale (getvar "userr1"))                                                             ;=====================================;
    (if(= 0 scale)(setq scale 1.0)) ;                                                        - !изменение масштаба вставляемых блоков!
                                                                                               ;=====================================;
    (setq Dbx (open_dbx)) 
  
(blkreplace "KIK" "KIK"), ; список соответствий имен блоков
(blkreplace "OTMETKI" "25")
(blkreplace "otm" "25")
(blkreplace "VALVE" "ZADVIGKA")
(blkreplace "zd" "ZADVIGKA")
(blkreplace "ZADVIGKA" "ZADVIGKA")
(blkreplace "klapan" "ZADVIGKA")
  
    (vl-cmdf "_.zoom" "_e")
    (enable_osmode)
                  (setvar "osnapcoord" osnapcoord_old)
                  (setvar "clayer" layer_old)
	          (setvar "osnapz" osnapz_old)
                  (setvar "CMDECHO" echo_old)
   (vlax-release-object Dbx)
   (setq Dbx nil) 
  (vl-cmdf "_.undo" "_end")
  (princ)
 ); end of defun



;---------------вспомогательная функция замены блоков---------------;
(defun blkreplace( b_in b_out / s_in   blokset   i   name_blk   spis_blk   koord_b
		                ugol   blklength   l_bl   b_del   att1   blk_layer
		                blk_color  prop1   proverka                       )
(if(/= nil (setq proverka (ssget "_X" (list '( 0 . "INSERT") (cons 2 b_in))))) ; проверка, нужно ли заменять текущий блок
  
   (progn  (if (not (tblsearch "BLOCK" (strcat b_in "del")))
                    (vl-cmdf "_-rename" "Block" b_in (strcat b_in "del")) ;,                                 переименование блока
                    (princ "\nБлок существует")
            );if
  
  ; вставка целевого блока в чертеж ----------------------------------------------------------------------------------------------------------
    (if (not (tblsearch "BLOCK" b_out))
        (progn  
              (vla-CopyObjects
                               Dbx
                                 (vlax-safearray-fill
                                                (vlax-make-safearray vlax-vbObject '(0 . 0))
                                                (list (vla-item (vla-get-blocks dbx) b_out))
                                  )
                                   (vla-get-blocks
                                               (vla-get-activedocument (vlax-get-acad-object))
                                    )
               ); vla-CopyObjects
	
               (vl-cmdf "_-bedit" b_out) ; создание атрибутов для вставленного блока
               (vl-cmdf "_-attdef" "" "NAME" "" "" '(0.5 0.5 0) 0.5 0.0)
                   (progn (setq att1 (entget (entlast)))                               ; присваивание параметра invisible
                          (setq att1 (subst (cons 70 1) (assoc 70 att1) att1 ))        ;
                          (entmod att1)                                                ;
                    ); progn
               (vl-cmdf "_-attdef" "" "FEATURE_CODE" "" "" '(0.5 -0.5 0) 0.5 0.0)
                   (progn (setq att1 (entget (entlast)))                               ; присваивание параметра invisible
                          (setq att1 (subst (cons 70 1) (assoc 70 att1) att1 ))        ;
                          (entmod att1)                                                ;
                     ); progn
               (vl-cmdf "_bclose" "Save")
               (vl-cmdf "_attsync" "Name" b_out)
         );progn
     );if
	   
 (setq s_in (cons 2 (strcat b_in "del")))
(if(/= nil (setq blokset (ssget "_X" (list '( 0 . "INSERT") s_in)))) 
  (progn 
  (setq blklength (sslength blokset))
  (setq i -1 ) 
  (repeat blklength ; число повторений
     (setq i (1+ i))       
     (setq name_blk (ssname blokset i))
     (setq spis_blk (entget name_blk))
     (setq koord_b (cdr(assoc 10 spis_blk))) ; достаем координаты i-го блока из выборки
     (setq ugol (*(cdr(assoc 50 spis_blk)) 57.297469)) ; достаем угол поворота i-го блока из выборки
     (setq blk_layer (assoc 8 spis_blk))
     (setq blk_color (assoc 62 spis_blk))
    
     (vl-cmdf "_.insert" b_out koord_b scale scale ugol "" "") ;вставка блока в нужное место
     (setq l_bl (entlast))
     (progn (setq prop1 (entget l_bl))                               ; присваивание имени слоя
            (setq prop1 (subst blk_layer (assoc 8 prop1) prop1 ))
            (setq prop1 (subst blk_color (assoc 62 prop1) prop1 )) ;
            (entmod prop1)
       ); progn
     (mip-block-setattr-bylist l_bl (get-all-atts name_blk)) ; вставка атрибутов в новый блок из старого 
    
  ) ;repeat 
  (setq i -1) 
  (repeat blklength 
   (setq i (1+ i)) 
   (entdel (ssname blokset i)) ; удаление старых блоков
  ) ;repeat

  (vl-cmdf "_-purge" "_B" (strcat b_in "del") "_Y" "_Y")
 
  ) ;progn 
 ) ;if
 );progn
 ) ;if
); defun

;|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;         функция создания списка атомов атрибутов выбранного блока                  ;
;                                                                                    ;
;         Use:      (get-all-atts (car(entsel "\nSelect block:")))                   ;
;         Returs: list (("TAG1" . "Value1")("TAG2" . "Value2") ...)                  ;
;                                                                                    ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|;

(defun get-all-atts (obj) ; obj - параметр задается  
    (vl-load-com)
    (if (= (type obj) 'ENAME) ; проверка типа объекта
		(setq obj (vlax-ename->vla-object obj)) ; преобразование во vla-объект
      );if
    (if (and obj
           (vlax-property-available-p obj 'Hasattributes) 
	   (eq :vlax-true (vla-get-HasAttributes obj)) 
        );and
        (vl-catch-all-apply
            (function
	        (lambda	()
	              (mapcar (function (lambda (x); 
			                    (cons (vla-get-TagString x) 
				                  (vla-get-TextString x)
			                    ) ;cons
			                 ) ;lambda
		              );function
		              (append (vlax-invoke obj 'Getattributes)  
			              (vlax-invoke obj 'Getconstantattributes) 
		              );append
	              );mapcar
	        );lambda
            );function
        );vl-catch-all-apply
     );if
);defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;         функция присваивания атрибутов блокам по списку атомов,                    ;
;         теги атрибутов должны совпадать с списком                                  ;
;                                                                                    ;
;         Use: (mip-block-setattr-bylist obj att_list)                               ;
;              obj - Ename or Vla object of block                                    ;
;              att_list - list ((Tag_Name1 . Value1)(Tag_Name2 . Value2) ...)        ;
;                                Tag_Name - string                                   ;
;                                Value - string                                      ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|;

(defun mip-block-setattr-bylist (obj att_list / txt lst)  
(vl-load-com)
(if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj))) 
  (setq att_list 
       (mapcar '(lambda(x)(cons (strcase (mip-conv-to-str(car x)))(mip-conv-to-str(cdr x)))) att_list) ; ссылаемся на функцию ниже
   )
  (if (and obj
           (not(vlax-erased-p obj)) 
           (= (vla-get-ObjectName obj) "AcDbBlockReference") 
	   (eq :vlax-true (vla-get-HasAttributes obj)) 
	   (vlax-property-available-p obj 'Hasattributes) 
	   (vlax-write-enabled-p obj) 
      ); and
    (vl-catch-all-apply
      (function
	(lambda	()
          (foreach at (vlax-invoke obj 'Getattributes) ; присваиваем at значение каждого атрибута из obj
            (if (setq lst ; создание переменной lst - 
		       (assoc(strcase(vla-get-TagString at)) att_list) ; достаем имя тэга по запросу ТЭГА из att_list
		 ) ;setq
                (vla-put-TextString at
		                    (cdr lst) ; все кроме первого элемента листа lst
	       );vla-put-TextString
            ); if
           ); foreach
          );lambda
        ) ;function
      ) ; vl-catch-all-apply
    );if
  );defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;         функция конверсии различных типов значений в строку                        ;
;                                                                                    ;
;         Use:      mip-conv-to-str (dat)                                            ;
;         Returs: значение dat в строке                                              ;
;                                                                                    ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|;
(defun mip-conv-to-str (dat)
  (cond ((= (type dat) 'INT)(setq dat (itoa dat))) 
        ((= (type dat) 'REAL)(setq dat (rtos dat 2 12)))
        ((null dat)(setq dat "")) 
        (t (setq dat (vl-princ-to-string dat))) 
   )
 )

;|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;         функция отлова ошибок                                                      ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|;

(defun *error* (msg) 
           (princ msg)
           (progn (vl-cmdf "_redrawall")	     
	          (setvar "osmode" osmode_old)
                  (setvar "osnapcoord" osnapcoord_old)
                  (setvar "clayer" layer_old)
	          (setvar "osnapz" osnapz_old)
	          (setvar "CMDECHO" echo_old)
	          (vlax-release-object Dbx)
                  (setq Dbx nil)
	        
             ) ;end of progn
         ); defun

;|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;         функция отключения/включения привязок                                      ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|;
              (defun disable_osmode ()
                     (setvar "osmode" 16384)
                )

              (defun enable_osmode ()
                     (setvar "osmode" osmode_old)
                )

;|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;         функция открытия базы данных рисунка                                       ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|;
;(defun OPEN_DBX	(dwg / dbx)
;(if (< (atoi (substr (getvar "ACADVER") 1 2)) 16)
;(setq dbx (vlax-create-object "ObjectDBX.AxDbDocument"))
;(setq dbx (vlax-create-object(strcat "ObjectDBX.AxDbDocument."(substr (getvar "ACADVER") 1 2)))))
;(vla-open dbx dwg) dbx
;); defun
(defun OPEN_DBX	( / dbx)
      (setq odbx (odbx-test))
      (setq fn (getfiled "Выберите файл библиотеки" "" "dwg" 16))
      (setq fname (findfile fn))
      (progn(vla-open odbx fname) odbx)
    ); defun

;|;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;         функция тестирования                                                       ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;|;
(defun odbx-test (/ dbx_doc)
;; edited 5/28/06 by Jeff M
;; modified slightly to work with more versions
(or (vl-load-com))
(if (< (setq dbxver (atoi (getvar "ACADVER"))) 15)
(progn (alert
"ObjectDBX method not applicable\nin this AutoCAD version"
)
(exit)
(princ)
(gc)
)
(progn
(if (= (atoi (getvar "ACADVER")) 15)
(progn

(if (not (vl-registry-read
"HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID"
)
)
(startapp "regsvr32.exe"
(strcat "/s \"" (findfile "axdb15.dll") "\"")
)
)

(setq	dbx_doc	(vla-getinterfaceobject
(vlax-get-acad-object)
"ObjectDBX.AxDbDocument"
)
)
)

(setq dbx_doc (vla-getinterfaceobject
(vlax-get-acad-object)
(strcat "ObjectDBX.AxDbDocument." (itoa (fix dbxver)))
)
)
)
)
)
); defun odbx_test
;==============================================================================================