Змена блока на другой блок

Змена блока на другой блок · 12.10.2005, 19:15

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

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

{Smirnoff} · 12.10.2005, 20:15

http://www.autocad.ru/cgi-bin/f1/board.cgi?t=21048Af

Perezz!! · 12.10.2005, 21:53

Пожалуйста, создавайте темы соответственно разделам на форуме. Я понимаю, что это требует сложных умственных усилий, а польза возможно сомнительна, но в данном случае, ответ был очевиден - раздел Программирование.
Коллегу Смирнова, тоже прошу переносить такие темы.

X-DeViL · 12.10.2005, 21:56

Ой... а что у нас новый модер? или это фантомас разбушевался?

{Smirnoff} · 12.10.2005, 22:25

>Perezz!!

Ok. В запарке даже не обратил внимание где она была. Если тема в "моих" разделах то конечно буду перекидывать. В отстальных правов на телепортацию нету. Так что не обезсудь.

>X-Devil

Истина где то рядом...

ilka_t · 13.10.2005, 10:13

Спасибо {Smirnoff} за помощь, пойду пробывать

to Perezz!! извини, ошибся с разделом, буду вниметельней

Лентяй · 13.10.2005, 12:31

Цитата:

{Smirnoff}: http://www.autocad.ru/cgi-bin/f1/board.cgi?t=21048Af

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

Код:

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

(defun *ERROR* (msg / objLay olaySt actDoc)
  (if olaySt (progn (vla-put-Lock objLay olaySt) (vla-EndUndoMark actDoc)) (princ))
); end of *ERROR*
;
(defun c:frto (/ ACTDOC COPOBJ ERRCOUNT EXTLST EXTSET BLKCOL BNAME PROP OBJLAY OKCOUNT OLAYST TOCEN VLAOBJ *ERROR*)
  (vl-load-com)
  (setq actDoc (vla-get-ActiveDocument (vlax-get-Acad-object))
        blkCol (vla-get-blocks actDoc))
  (if (not (setq extSet (ssget "_I")))
    (progn (princ "\n+++ Select distination objects and press Enter <- ")
      (setq extSet (ssget))));if
  (if (not extSet) (princ "\nDistination objects isn't selected!"));if
  (initget "Enter Select")
  (setq kword (getkword "\n[Enter/Select] source object: ? <Select>"))
  (if (null kword) (setq kw "Select"))
  (setq vlaObj (if (= kw "Select") (vlax-ename->vla-object (car (entsel)))
                 (progn (setq bname (getstring T "\nEnter New Block's Name: ? "))
                   (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list blkCol bname)))
                     (vla-delete (vla-insertBlock (vla-get-ModelSpace actdoc) (vlax-3d-point '(0.0 0.0 0.0))
                                   (getfiled "Select Source File" "" "dwg" 8) 1 1 1 0 "X")));if
                   (vla-item blkCol bname))));setq
  (if vlaObj 
    (progn (setq extLst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex extSet))))
                 objLay (vla-Item (vla-get-Layers actDoc) (vla-get-Layer vlaObj))
                 olaySt (vla-get-Lock objLay) errCount 0 okCount 0);setq
      (vla-StartUndoMark actDoc)
      (foreach obj extLst
        (setq toCen (vla-get-InsertionPoint obj)
              prop (mapcar '(lambda (x) vlax-get-property obj (list x))
                         '(Layer XScaleFactor YScaleFactor ZScaleFactor Rotation))
              owner (vla-ObjectIDToObject actDoc (vla-get-objectID obj)));setq
        (if (/= :vlax-true (vla-get-Lock scLay))
          (progn (vla-put-Lock objLay :vlax-false)
            (setq copObj (vla-insertblock owner toCen bname 1 1 1 0))
            (apply '(lambda (x) (vlax-put-property copObj x)) prop)
            (vla-put-Lock objLay olaySt)
            (vla-Delete obj)
            (setq okCount (1+ okCount)));progn
          (setq errCount (1+ errCount)));if
      );foreach
      (princ (strcat "\n" (itoa okCount) " were changed. "
               (if (/= 0 errCount)
                 (strcat (itoa errCount) " were on locked layer! ") "")));princ
      (vla-EndUndoMark actDoc)
    );progn
    (princ "\nSource object isn't selected! ")
  );if
  (princ)
);end

Код не проверял.

boban · 16.10.2005, 21:57

Код не работает.!!!!???
Можно ли в программе задать имя файла, на который нужно поменять?

Лентяй · 17.10.2005, 03:51

Цитата:

boban:Код не работает.!!!!???

Ну, и подлец он после этого! Ничего, я им через пару часов займусь!

Цитата:

Можно ли в программе задать имя файла, на который нужно поменять?

Можно. У меня предучмотрена соотв. опция. Потерпите немного - отрихтую.

Vova · 17.10.2005, 05:47

Экспрессовская команда Blockreplace, по-видимому, предназначена для того, чтобы блоку с атрибутами поменять сам блок, а старые атрибуты переходят как-бы под новую оболочку. Таким образом, поменять блок с атрибутами на другой блок с атрибутами по-простому не получается. Вот-бы сделать альтернативу Blockreplace чтобы блоки менялись с потрохами. По-умолчанию новый блок должен встать на место старого своей базовой точкой, а по желанию, если это возможно, базовой точкой нового блока в указанную точку старого. И все должно заменятся либо глобально, либо только в указанных местах, one by one или в указанной рамкой области

{Smirnoff} · 17.10.2005, 08:53

>Лентяй

Брателло, зачем ты в моей "покалеченной" функции вынес локальный *ERROR* из тела основной функции?! Он ведь теперь глобальный и будет срабатывать на ошибки других прог.

Цитата:

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

Честно говоря нифига не понял... Ну естественно должен быть, а как иначе?

Лентяй · 17.10.2005, 10:08

Теперь работает! Выставляю на всеобщее осмеяние.

Код:

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

 (defun *ERROR* (msg / bklay bklyst adoc)
  (if bklay (progn (vla-put-Lock bklay bklyst) (vla-EndUndoMark adoc)) (princ))
); end of *ERROR*
;
(defun c:Bk2Bk (/ adoc atq nblk ass SSet blks bname kw prop lay owner errCount okCount bklay bklyst ins blk *error*)
  (vl-load-com)
  (setq adoc (vla-get-ActiveDocument (vlax-get-Acad-object))
        blks (vla-get-blocks adoc)
        atq (getvar "ATTREQ"))
  (setvar "ATTREQ" 0)
  (if (not (setq SSet (ssget "_I")))
    (progn (princ "\nSelect objects to change: ")
      (setq SSet (ssget))));if
  (if (not SSet) (alert "\nNo objects selected!"));if
  (initget "Enter Select")
  (setq kw (getkword "\n[Enter/Select] source object: ? <Select>"))
  (if (null kw) (setq kw "Select"))
  (setq blk (if (= kw "Select") (vlax-ename->vla-object (car (entsel)))
                 (progn (setq bname (getstring T "\nEnter New Block's Name: ? "))
                   (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list blks bname)))
                     (vla-delete (vla-insertBlock (vla-get-ModelSpace adoc) (vlax-3d-point '(0.0 0.0 0.0))
                                   (getfiled "Select Source File" "" "dwg" 8) 1 1 1 0)));if
                   (vla-item blks bname))));setq
  (if blk
    (progn (if (= kw "Select")
             (progn (setq bklay (vla-Item (vla-get-Layers adoc) (vla-get-Layer blk)))
               (setq bklyst (vla-get-Lock bklay))
               (vla-put-Lock bklay :vlax-false)));if
    (setq ass (vla-get-ActiveSelectionset adoc) errCount 0 okCount 0)
      (vla-StartUndoMark adoc)
      (vlax-for obj ass
        (setq ins (vla-get-InsertionPoint obj)
              lay (vla-Item (vla-get-Layers adoc) (vla-get-Layer obj))
              owner (vla-ObjectIDToObject adoc (vla-get-ownerID obj)))
              prop (mapcar '(lambda (x) (vlax-get-property obj x))
                         '(Layer XScaleFactor YScaleFactor ZScaleFactor Rotation)))
        (if (/= :vlax-true (vla-get-Lock lay))
          (progn (setq nblk (vla-insertblock owner ins bname 1 1 1 0.0))
            (mapcar '(lambda (x y) (vlax-put-property nblk x y))
                         '(Layer XScaleFactor YScaleFactor ZScaleFactor Rotation) prop)
            (vla-Delete obj)
            (setq okCount (1+ okCount)));progn
          (setq errCount (1+ errCount)));if
      );vlax-for
      (if (= kw "Select") (vla-put-Lock bklay bklyst))
      (princ (strcat "\n" (itoa okCount) " blocks were changed. "
               (if (/= 0 errCount)
                 (strcat (itoa errCount) " blocks were on locked layer! ") "")));princ
      (vla-EndUndoMark adoc)
    );progn
    (princ "\nSource object isn't selected! ")
  );if
  (setvar "ATTREQ" atq)
  (princ)
);end

Цитата:

{Smirnoff}: Брателло, зачем ты в моей "покалеченной" функции вынес локальный *ERROR* из тела основной функции?! Он ведь теперь глобальный и будет срабатывать на ошибки других прог.

Потому что мне так больще ндравицца.

Цитата:

Честно говоря нифига не понял... Ну естественно должен быть, а как иначе?

А вот, как у меня! Если нового блока еще нету, то мы его вставим извне, и будет стоять, как у молодого.

Лентяй · 17.10.2005, 10:21

Цитата:

Vova: Вот-бы сделать альтернативу Blockreplace чтобы блоки менялись с потрохами

У меня именно так и сделано: поскольку ATTREQ = 0, значения атрибутов либо игнорируются, либо вставляются те, которые по умолчанию. Впрочем. можно сделать проверку на соответсвие TAGS (кстати, как это будет по русски - я уже забыл :? ) старого блока новому. В случае TRUE можно ввести присвоение атрибутам нового блока значений старого, а в случае FAULS - игнорировать. Но это уже завтра.

{Smirnoff} · 17.10.2005, 11:14

>Лентяй

Цитата:

Потому что мне так больще ндравицца.

Если тебе так больше нравится то надо по крайней мере надо сохранять старое значение функции *ERROR* перед тем ка ты её переопределяешь, а при окончании программы и в теле самого обработчика ошибок его восстанавливать :!:

У тебя же теперь любая ошибка будет обрабатываться именно функцией *ERROR* которую ты вынес за пределы основной функции и геммороя необерёшся.

И вообще интересно как одна функция работает с локальными переменными другой функции :?:

А идея модернизации у тебя хорошая, правильная.

Лентяй · 17.10.2005, 11:39

Цитата:

{Smirnoff}: У тебя же теперь любая ошибка будет обрабатываться именно функцией *ERROR* которую ты вынес за пределы основной функции и геммороя необерёшся.

Да пока бог миловал. и ничего такого не наблюдалось.

Цитата:

И вообще интересно как одна функция работает с локальными переменными другой функции.

Мне так кааца, что по заврешении программы, вызванной С:, все вспомагательные, даже если они находятся вне (defun C:), дезактивируются.[/b]

{Smirnoff} · 17.10.2005, 12:29

>Лентяй

Цитата:

Да пока бог миловал. и ничего такого не наблюдалось.

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

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

Самый простой способ включать внутрь основной функции и писать *ERROR* в списке локальных переменных.

Либо в начале программы сохранять метку на старый *ERROR* в переменной, а потом восстанавливать.

Извиняй, расфилосовствовался... Но по такому поводу стоило сказать.

Лентяй · 18.10.2005, 09:17

Спаибо за ценный совет, при случае как-нить попробую.

Dym · 05.12.2005, 16:15

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

fixo · 06.12.2005, 01:02

Цитата:

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

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

Пробуй:

Код:

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

(defun C:fbb (/ acsp adoc bname cent circ cset hatch_obj midp pt1 pt2 sset)
(vl-load-com)
(or adoc
    (setq adoc (vla-get-activedocument
(vlax-get-acad-object))))
(or acsp (setq acsp (if (= (getvar "CVPORT") 1)
(vla-get-paperspace
adoc)
(vla-get-modelspace
adoc)
)
)
    )
(vla-endundomark
  adoc)  
(vla-startundomark
  adoc)  
(while (or (not (setq sset (ssget "+.:S" '((0 . "HATCH")))))
	   (not (setq hatch_obj (vlax-ename->vla-object (ssname sset 0))))))
(vla-highlight hatch_obj :vlax-true)  
(vla-getboundingbox hatch_obj 'pt1 'pt2)
(setq midp (vlax-3d-point (setq cent
	   (mapcar '* (mapcar '+
		(vlax-safearray->list pt1) 
                (vlax-safearray->list pt2))
		   '(0.5 0.5 0.5)))))

(vla-delete hatch_obj)
(vlax-release-object hatch_obj)
(if (setq cset (ssget "F" (list cent (getvar "vsmin"))'((0 . "CIRCLE"))))
(progn  
(setq circ (ssname cset 0))  
(vl-cmdf "erase" circ "")))
(setq bname (getstring "\n\t***\tУказать имя блока\t*** \n : "))  
(vla-Insertblock acsp  midp bname 1 1 1 0)  
(vla-endundomark
  adoc)
(vla-regen adoc acactiveviewport)
(princ)
)
(prompt "\n\t***\tВ командной строке ввести FBB  для выполнения\t*** \n : ")

Dym · 06.12.2005, 01:47

2fatty:
слегка обкатал, а к примеру чтоб эта штучка объекты мгла выделять рамкой или поочерёдно в набор и вставляемый блок указывать на экране возможно? брошу пиво, сяду за учебники

p.s. мутно понимаю что сей код заточен под конкретное условие

fixo · 06.12.2005, 23:32

Цитата:

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

2fatty:
слегка обкатал, а к примеру чтоб эта штучка объекты мгла выделять рамкой или поочерёдно в набор и вставляемый блок указывать на экране возможно? брошу пиво, сяду за учебники

p.s. мутно понимаю что сей код заточен под конкретное условие

Небольшая доработка требуется
но неt времени попозже vернусь

Fatty

fixo · 07.12.2005, 11:44

Цитата:

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

2fatty:
слегка обкатал, а к примеру чтоб эта штучка объекты мгла выделять рамкой или поочерёдно в набор и вставляемый блок указывать на экране возможно? брошу пиво, сяду за учебники

p.s. мутно понимаю что сей код заточен под конкретное условие

По просьбе трудящихся

Код:

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

(defun C:fbb (/ acsp adoc bname cent circ cpt
	      cset hatch_obj midp opt pt1 pt2 ss sset)
(vl-load-com)
(or adoc
    (setq adoc (vla-get-activedocument
(vlax-get-acad-object))))
(or acsp (setq acsp (if (= (getvar "CVPORT") 1)
(vla-get-paperspace
adoc)
(vla-get-modelspace
adoc)
)
)
    )
(vla-endundomark
  adoc)  
(vla-startundomark
  adoc)  
(while (or (not (setq sset (ssget  '((0 . "HATCH")))))
	   (not (setq hatch_obj (vlax-ename->vla-object (ssname sset 0))))))
(vla-highlight hatch_obj :vlax-true)  
(vla-getboundingbox hatch_obj 'pt1 'pt2)
(setq midp (vlax-3d-point (setq cent
	   (mapcar '* (mapcar '+
		(vlax-safearray->list pt1) 
                (vlax-safearray->list pt2))
		   '(0.5 0.5 0.5)))))

(vla-delete hatch_obj)
(vlax-release-object hatch_obj)
(if (setq cset (ssget "F" (list cent (getvar "vsmin"))'((0 . "CIRCLE"))))
(progn  
(setq circ (ssname cset 0))  
(vl-cmdf "erase" circ "")))  
(initget 1 "Insert Copy")
(setq opt (getkword (strcat "\n\tВыбрать метод клонирования объектов : \n"
		"\t[I]nsert - вставить блок или [C]opy - скопировать объект <C> : \n")))
(if (not opt)(setq opt "Copy"))
(if (eq opt "Copy")
(progn
(prompt "\n\t***\tВыбрать объекты на экране \t*** \n : ")  
(setq ss (ssget))  
(initget 1)
(setq cpt (getpoint "\n\t***\tЦентр выбранной группы объектов \t*** \n : "))
(vl-cmdf "copy" "P" "" cpt cent "")
(setq ss nil))
(progn
(setq bname (getstring "\n\t***\tУказать имя блока \t*** \n : "))
(if (tblsearch "block" bname)
(vla-Insertblock acsp  midp bname 1 1 1 0)
(alert "Нет такого блока!"))))    
(vla-endundomark
  adoc)
(vla-regen adoc acactiveviewport)
(princ)
)
(prompt "\n\t***\tВ командной строке ввести FBB  для выполнения\t*** \n : ")

Dym · 07.12.2005, 12:52

2Fatty:
однако не работает

fixo · 07.12.2005, 15:57

Цитата:

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

2Fatty:
однако не работает

Теперь будет (А2005)

Код:

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

(defun C:fbb (/ acsp adoc bname cent circ cpt
	      cset hatch_obj midp opt pt1 pt2 ss sset) 
(vl-load-com) 
(or adoc 
    (setq adoc (vla-get-activedocument 
(vlax-get-acad-object)))) 
(or acsp (setq acsp (if (= (getvar "CVPORT") 1) 
(vla-get-paperspace 
adoc) 
(vla-get-modelspace 
adoc) 
) 
) 
    ) 
(vla-endundomark 
  adoc)  
(vla-startundomark 
  adoc)
  (setvar "cmdecho" 0)
 (prompt "\n\t***\tВыбрать штриховку любым способом \t*** \n : ") 
(while (or (not (setq sset (ssget  '((0 . "HATCH"))))) 
      (not (setq hatch_obj (vlax-ename->vla-object (ssname sset 0)))))) 
(vla-highlight hatch_obj :vlax-true)  
(vla-getboundingbox hatch_obj 'pt1 'pt2) 
(setq midp (vlax-3d-point (setq cent 
      (mapcar '* (mapcar '+ 
      (vlax-safearray->list pt1) 
                (vlax-safearray->list pt2)) 
         '(0.5 0.5 0.5))))) 

(vla-delete hatch_obj) 
(vlax-release-object hatch_obj) 
(if (setq cset (ssget "F" (list cent (getvar "vsmin"))'((0 . "CIRCLE")))) 
(progn  
(setq circ (ssname cset 0))  
(vl-cmdf "erase" circ "")))  
(initget "Insert Copy") 
(setq opt (getkword (strcat "\n\tВыбрать метод клонирования объектов : \n" 
      "\t[I]nsert - вставить блок или [C]opy - скопировать объект <C> : \n"))) 
(if (not opt)(setq opt "Copy")) 
(if (eq opt "Copy") 
(progn 
(prompt "\n\t***\tВыбрать объекты на экране \t*** \n : ")
(setq ss (ssget))
(setvar "osmode" 0)
(initget 1) 
(setq cpt (getpoint "\n\t***\tЦентр выбранной группы объектов \t*** \n : "))
(command "copy" ss "" cpt cent) 
) 
(progn 
(setq bname (getstring "\n\t***\tУказать имя блока \t*** \n : ")) 
(if (tblsearch "block" bname) 
(vla-Insertblock acsp  midp bname 1 1 1 0) 
(alert "Нет такого блока!"))))
(setvar "osmode" 703)
(setvar "cmdecho" 1)
(vla-endundomark 
  adoc) 
(vla-regen adoc acactiveviewport) 
(princ) 
) 
(prompt "\n\t***\tВ командной строке ввести FBB  для выполнения\t*** \n : ")

Dym · 08.12.2005, 00:20

ок, в целом чего хочеться:
модификацию кода FRTO ( by Smirnoff & drugi) тема-"Змена блока блоками" + кусок кода выбора группы заменяемых объектов как одно целое MROTATE CENTRER от krbIs(СПб)&drugi , тема - "Вращение множества объектов вокруг локальных центров". А как-нибудь потом найти способ выявления фрагментов документа тождественных выбранному.
А как-нибудь до этого толковый словарь LISPa и ещё на чем пишут письма ACADу

fixo · 08.12.2005, 00:53

Цитата:

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

ок, в целом чего хочеться:
модификацию кода FRTO ( by Smirnoff & drugi) тема-"Змена блока блоками" + кусок кода выбора группы заменяемых объектов как одно целое MROTATE CENTRER от krbIs(СПб)&drugi , тема - "Вращение множества объектов вокруг локальных центров". А как-нибудь потом найти способ выявления фрагментов документа тождественных выбранному.
А как-нибудь до этого толковый словарь LISPa и ещё на чем пишут письма ACADу

Извини брат нет времени...

Dym · 08.12.2005, 01:13

в этом понимаю

я пока книжки поищу

Лентяй · 08.12.2005, 05:10

Fatty,
Всем бы ваш прога была хороша, если бы не три "НО" - одно маленькое и, соот-но, вва больших. Маленькое состоит втом, чро мидп определено уж больно коряво. Первое большое "НО" - забор ваш уж больно велик, и нет гарантии, что вместе ц нужной окружностью он не подцепит какую-нить другую ненужную.
Второе большое "НО" - замена штриховок на наборы/блоки у вас производится по принципу "одна штриховка - один набор/блок". А ежели штриховок много, и всех их надо заменить одним и тем же набором/блоком? Неужто несчастному оператору мучиться, многожды повторяя одну и ту же замену? Негуманно это! Поетопму ниже предлагается вариант "набор штриховок - один набор/блок". Кроме того, поиск окружности производится не вылезая за границы ББ, и введена возможнось замены штриховок на блок, изначально отсутствующий в чертеже.
Выставляю творение свое на всеобщее осмеяние.

Код:

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

 (defun flt (typ)
  (list 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0)) 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list typ)))
);ssel
;
(defun C:FBB (/ acsp adoc util bks sss css bname pts vpts ht cpt opt pt1 pt2) 
  (vl-load-com) 
  (setq om (getvar "OSMODE") cmd (getvar "CMDECHO") 
        adoc (vla-get-activedocument (vlax-get-acad-object)) 
        util (vla-get-utility adoc) 
        bks (vla-get-blocks adoc) 
        sss (vla-get-SelectionSets adoc))
  (setq css (mapcar '(lambda (x) (if (vl-catch-all-error-message (vl-catch-all-apply 'vla-add (list sss x))) 
         (vla-item sss x) (vla-add sss x))) (list "CSS1" "CSS2")))
  (mapcar '(lambda (x) (if (/= (vla-get-count x) 0) (vla-erase x))) css) 
  (vla-endundomark adoc) 
  (vla-startundomark adoc) 
  (setvar "cmdecho" 0) 
  (prompt "\n\t***\tSelect Hatches to Replace \t*** \n : ") 
  (vla-SelectOnScreen (car css) (car (flt "*Hatch")) (cadr (flt "*Hatch")))
  (setq acsp (vla-ObjectIDToObject adoc (vla-get-OwnerID (vla-item (car css) 0))))
  (vlax-for ht (car css)
    (vla-getboundingbox ht 'pt1 'pt2)
    (setq pts (mapcar 'vlax-safearray->list (list pt1 pt2))
          vpts (mapcar 'vlax-3d-point (list (car pts) (mapcar ' (lambda (x y)
            (* 0.5 (+ x y))) (car pts) (cadr pts))))
          lvpts (if (null lvpts) (list vpts) (cons vpts lvpts)))
    (vla-select (cadr css) acSelectionSetCrossing (car vpts) (cadr vpts) (car (flt "*Circle")) (cadr (flt "*Circle")))
    (vla-erase (cadr css)));vlax-for
  (vla-erase (car css))
  (vla-InitializeUserInput util 128 "Insert Copy") 
  (setq opt (vla-getKeyWord util (strcat "\nSelect Cloning Methode [Insert/Copy] <Copy> :"))) 
  (if (eq "" opt)(setq opt "Copy")) 
  (if (eq opt "Copy") 
    (progn (prompt "\n\t***\tSelect Objects \t*** \n : ") 
      (setvar "osmode" 0) 
      (vla-SelectOnScreen (car css)) 
      (vla-InitializeUserInput util 1) 
      (setq cpt (vla-getpoint util nil "\n\t***\tSelect Refernce Point \t*** \n : ")) 
      (foreach pt lvpts
        (vlax-for obj (car css) (vla-copy obj) (vla-move obj cpt (cadr pt)))));Copy
    (progn (vla-InitializeUserInput util 128 "Drawing File")
      (setq kword (vla-getKeyWord util "\nSelect Source Object from [Drawing/File]: ? <Drawing>")) 
      (if (eq "" kword) (setq kw "Drawing")) 
      (if (= kword "Drawing") (progn
          (setq bname (getstring T "\nEnter New Block's Name or <Enter> to Select: "))
          (if (= bname "") (progn (vla-getEntity util 'blk) (setq bname (vla-get-name blk))))));if
      (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list bks bname)))
        (setq bname (getfiled "Select Source File" "" "dwg" 8)));if
      (vla-delete (vla-insertBlock acsp (vlax-3d-point '(0.0 0.0 0.0)) bname 1 1 1 0 "X"))
      (foreach pt lvpts (vla-Insertblock acsp (cadr pt) bname 1 1 1 0))));if
  (setvar "OSMODE" om) (setvar "CMDECHO" cmd) 
  (vla-endundomark adoc) 
  (vla-regen adoc acactiveviewport) 
(princ) 
);end 
(prompt "\n\t***\tEnter FBB to execute\t*** \n : ")

Dym · 08.12.2005, 13:24

не работает

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

а при попытке UNDO CAD2006 завис

Лентяй · 09.12.2005, 03:50

Цитата:

не работает

Теперь работает. :!:

Код:

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

(defun *error* (msg)
  (if (= msg "Function cancelled") (princ msg)(princ));if
  (setvar "OSMODE" om) (setvar "CMDECHO" cmd) (mapcar 'vla-clear css)  
);*error*
;
(defun flt (typ) 
  (list 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0)) 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list typ))) 
);flt
;
(defun C:FBB (/ acsp adoc util bks sss css bname pts vpts ht cpt opt pt1 pt2) 
  (vl-load-com) 
  (setq om (getvar "OSMODE") cmd (getvar "CMDECHO") 
             adoc (vla-get-activedocument (vlax-get-acad-object)) 
             util (vla-get-utility adoc) 
             bks (vla-get-blocks adoc) 
             sss (vla-get-SelectionSets adoc)
             css (mapcar '(lambda (x) (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list sss x)))
         (vla-add sss x) (vla-item sss x))) (list "CSS1" "CSS2")))
  (mapcar '(lambda (x) (if (/= (vla-get-count x) 0) (vla-clear x))) css) 
  (vla-endundomark adoc) 
  (vla-startundomark adoc) 
  (setvar "cmdecho" 0) 
  (prompt "\n\t***\tSelect Hatches to Replace \t*** \n : ") 
  (vla-SelectOnScreen (car css) (car (flt "*Hatch")) (cadr (flt "*Hatch"))) 
  (setq acsp (vla-ObjectIDToObject adoc (vla-get-OwnerID (vla-item (car css) 0)))) 
  (vlax-for ht (car css) 
    (vla-getboundingbox ht 'pt1 'pt2) 
    (setq pts (mapcar 'vlax-safearray->list (list pt1 pt2)) 
          vpts (mapcar 'vlax-3d-point (list (car pts) (mapcar ' (lambda (x y) 
            (* 0.5 (+ x y))) (car pts) (cadr pts)))) 
          lvpts (if (null lvpts) (list vpts) (cons vpts lvpts))) 
    (vla-select (cadr css) acSelectionSetCrossing (car vpts) (cadr vpts) (car (flt "*Circle")) (cadr (flt "*Circle"))) 
    (vla-erase (cadr css)));vlax-for 
  (vla-erase (car css)) 
  (vla-InitializeUserInput util 128 "Insert Copy") 
  (setq opt (vla-getKeyWord util (strcat "\nSelect Cloning Methode [Insert/Copy] <Copy> :"))) 
  (if (eq "" opt)(setq opt "Copy")) 
  (if (eq opt "Copy") 
    (progn (prompt "\n\t***\tSelect Objects \t*** \n : ") 
      (setvar "osmode" 0) 
      (vla-SelectOnScreen (car css)) 
      (vla-InitializeUserInput util 1) 
      (setq cpt (vla-getpoint util nil "\n\t***\tSelect Refernce Point \t*** \n : ")) 
      (foreach pt lvpts 
        (vlax-for obj (car css)  (vla-move (vla-copy obj) cpt (cadr pt)))));Copy 
    (progn (vla-InitializeUserInput util 128 "Drawing File") 
      (setq kword (vla-getKeyWord util "\nSelect Source Object from [Drawing/File]: ? <Drawing>")) 
      (if (eq "" kword) (setq kword "Drawing")) 
      (if (= kword "Drawing") (progn 
          (setq bname (getstring T "\nEnter New Block's Name or <Enter> to Select: ")) 
          (if (= bname "") (progn (vla-getEntity util 'blk nil) (setq bname (vla-get-name blk))))));if 
      (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list bks bname))) 
        (setq bname (getfiled "Select Source File" "" "dwg" 8)));if 
      (vla-delete (vla-insertBlock acsp (vlax-3d-point '(0.0 0.0 0.0)) bname 1 1 1 0 "X")) 
      (foreach pt lvpts (vla-Insertblock acsp (cadr pt) bname 1 1 1 0))));if 
  (setvar "OSMODE" om) (setvar "CMDECHO" cmd)
  (vla-endundomark adoc) 
  (vla-regen adoc acactiveviewport)
  (princ) 
);end 
(prompt "\n\t***\tEnter FBB to execute\t*** \n : ")

Цитата:

и "набор штриховок - один набор/блок" всёж частный случай, лучше по Смирноффу "замена всего всем"

Всего всем - не бывает, пoтому как неизвесто кого кем и что чем.

У Fatty надо выбирать по системе "один на один". Моя программа предоставит тебе такую возможность, если тебе, конечно, не лень.

Цитата:

а при попытке UNDO CAD2006 завис

Это он по злобЕ. :evil:

{Smirnoff} · 09.12.2005, 09:34

Цитата:

а при попытке UNDO CAD2006 завис

Это он по злобЕ.

Ага, на тебя разозлился

. А я думаю что пользователь прервал выполнение программы и (vla-StartUndoMark осталось без (vla-EndUndoMark, а на это он всегда очень злится :evil: при попытке Undo. Однако в *error* это надо предусматривать.

Dym · 09.12.2005, 17:37

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

в файлике из жизни блоки стоят напротив "значков" которые надо заменить по принципу - выделяется "значок", указывается на экране блок, стирается "значок" и на его место ложится блок. Будь эти значки на отдельном слое я б не парился накопировать поверх своих блоков и "значки" разом стереть, дык они то в "0" то в "стенах" то "ещё где"

[ATTACH]1134139076.dwg[/ATTACH]

Лентяй · 12.12.2005, 12:05

Цитата:

в файлике из жизни блоки стоят напротив "значков" которые надо заменить по принципу - выделяется "значок", указывается на экране блок, стирается "значок" и на его место ложится блок

Ну дык в чем проблема-то :?: Запускаешь прогу и вперед. не забудь только отчитатся о проделанной работе.

Dym · 12.12.2005, 13:57

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

попробуй сделать замены в файлике..

Лентяй · 12.12.2005, 22:25

Цитата:

проблема в том ,что значки разные и блоки разные

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

Цитата:

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

Не понял, кто не обнуляется - набор удаляемых окружностей/штриховок или копируемый набор?

Лентяй · 13.12.2005, 03:13

Расобрался, тепeрь все "обнуляется". И ведь дело-то было всего в одной букве...

Абыдна, да-а-а :?:

Код:

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

(defun *error* (msg) 
  (if (= msg "Function cancelled") (princ msg)(princ));if 
  (setvar "OSMODE" om) (setvar "CMDECHO" cmd) (mapcar 'vla-clear css)  
);*error* 
; 
(defun flt (typ) 
  (list 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0)) 
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list typ))) 
);flt 
; 
(defun C:FBB (/ acsp adoc util bks sss css bname pts vpts lvpts ht cpt opt pt1 pt2) 
  (vl-load-com) 
  (setq om (getvar "OSMODE") cmd (getvar "CMDECHO") 
        adoc (vla-get-activedocument (vlax-get-acad-object)) 
        util (vla-get-utility adoc) 
        bks (vla-get-blocks adoc) 
        sss (vla-get-SelectionSets adoc) 
        css (mapcar '(lambda (x) (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list sss x))) 
         (vla-add sss x) (vla-item sss x))) (list "CSS1" "CSS2"))) 
  (mapcar '(lambda (x) (if (/= (vla-get-count x) 0) (vla-clear x))) css) 
  (vla-endundomark adoc) 
  (vla-startundomark adoc) 
  (setvar "cmdecho" 0) 
  (prompt "\n\t***\tSelect Hatches to Replace \t*** \n : ") 
  (vla-SelectOnScreen (car css) (car (flt "*Hatch")) (cadr (flt "*Hatch"))) 
  (setq acsp (vla-ObjectIDToObject adoc (vla-get-OwnerID (vla-item (car css) 0)))) 
  (vlax-for ht (car css) 
    (vla-getboundingbox ht 'pt1 'pt2) 
    (setq pts (mapcar 'vlax-safearray->list (list pt1 pt2)) 
          vpts (mapcar 'vlax-3d-point (list (car pts) (mapcar ' (lambda (x y) 
            (* 0.5 (+ x y))) (car pts) (cadr pts)))) 
          lvpts (if (null lvpts) (list vpts) (cons vpts lvpts))) 
    (vla-select (cadr css) acSelectionSetCrossing (car vpts) (cadr vpts) (car (flt "*Circle")) (cadr (flt "*Circle"))) 
    (vla-erase (cadr css)));vlax-for 
  (vla-erase (car css)) 
  (vla-InitializeUserInput util 128 "Insert Copy") 
  (setq opt (vla-getKeyWord util (strcat "\nSelect Cloning Methode [Insert/Copy] <Copy> :"))) 
  (if (eq "" opt)(setq opt "Copy")) 
  (if (eq opt "Copy") 
    (progn (prompt "\n\t***\tSelect Objects \t*** \n : ") 
      (setvar "osmode" 0) 
      (vla-SelectOnScreen (car css)) 
      (vla-InitializeUserInput util 1) 
      (setq cpt (vla-getpoint util nil "\n\t***\tSelect Refernce Point \t*** \n : ")) 
      (foreach pt lvpts 
        (vlax-for obj (car css)  (vla-move (vla-copy obj) cpt (cadr pt)))));Copy 
    (progn (vla-InitializeUserInput util 128 "Drawing File") 
      (setq kword (vla-getKeyWord util "\nSelect Source Object from [Drawing/File]: ? <Drawing>")) 
      (if (eq "" kword) (setq kword "Drawing")) 
      (if (= kword "Drawing") (progn 
          (setq bname (getstring T "\nEnter New Block's Name or <Enter> to Select: ")) 
          (if (= bname "") (progn (vla-getEntity util 'blk nil) (setq bname (vla-get-name blk))))));if 
      (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list bks bname))) 
        (setq bname (getfiled "Select Source File" "" "dwg" 8)));if 
      (vla-delete (vla-insertBlock acsp (vlax-3d-point '(0.0 0.0 0.0)) bname 1 1 1 0 "X")) 
      (foreach pt lvpts (vla-Insertblock acsp (cadr pt) bname 1 1 1 0))));if 
  (setvar "OSMODE" om) (setvar "CMDECHO" cmd) 
  (vla-endundomark adoc) 
  (vla-regen adoc acactiveviewport) 
  (princ) 
);end 
(prompt "\n\t***\tEnter FBB to execute\t*** \n : ")

Dym · 13.12.2005, 22:06

Лентяй, я так думаю эта тема была достойна отдельной ветки и суть её в следующем:
1) нередко приходят документы в целях защиты, а скорее из вредности прошедшие команду explode, после чего работать в густом чертеже весьма неудобно
2) Хорошие люди топографы делают подоснову в Микростейшн (в моём случае), после чего присылают в dwg тоже взорванное ( даже полилинии, они не в счёт)
3) Хорошие люди тётки делают свою графическую часть работы как умеют, и винить их за это не хочется, так как саму их работу временами хочется распевать.
В следствии этих примеров оч хочется кнопку быстрой замены блоком группы из любых выделенных простых элементов чертежа на экране. Я так думаю сия чтучка порадует не одного юзера вроде меня и вполне достойна находится в тулбаре. И создателя ея не слышным а дружным за него, благоделателем, выпитого

Лентяй · 13.12.2005, 23:41

Цитата:

1) нередко приходят документы в целях защиты, а скорее из вредности прошедшие команду explode, после чего работать в густом чертеже весьма неудобно
2) Хорошие люди топографы делают подоснову в Микростейшн (в моём случае), после чего присылают в dwg тоже взорванное ( даже полилинии, они не в счёт)

mitjaj, Вы, случайно не в секторе Газа или, скажем, в суннитском треугольнике обретаетесь? :?: А то я смотрю - все-то у вас повзрывали.

Цитата:

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

А ежели серьезно, то не вы никогда не пробовали сварить из аквариума уху? Это очень просто - достаточно поставить аквариум на огонь. А сотворить обратный процесс? :? Тако же и с блоками. Хотя определенные возможности, безусловно есть. Я тут для личного пользования наваял такую прогу, но она трбует наличия/указания блока, вставки которого нужно восстановить.
Если идти немножко дальше, то можно автоматизировать поиск блока-прототипа. Но одно безусловно - блок прототип, безвременно погибший в ходе террористической атаки, должен быть известен.

Dym · 14.12.2005, 00:55

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

Лентяй · 14.12.2005, 04:10

Только что поставил русскую раскладку, терперь наслаждаюсь.

Цитата:

mitjaj: выделенный фрагмент чертежа всёж заменить известным блоком, скажем точкой вставки в "центр массы" фрагмента.

Я, любимый: ...блок прототип, безвременно погибший в ходе террористической атаки, должен быть известен.

Так о чем спич-то? Блок автоматом создаться не может - он должен быть определен заранее. А что касается выделенного фрагмента, то это мы тоже умеем

Вот только доберусь до дома... :twisted:

Лентяй · 14.12.2005, 11:31

mitjaj, лови обещанное и не забывай денно и нощщно сугубо и трегубо возносить благодврствия свои Господу - Подателю Мудрости и мне, любимому, - просто за то, что я есть.

Код:

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

(defun C:FBB (/ acsp adoc util bks ass bname pts ptn ptx lpts ht cpt opt pt1 pt2) 
  (vl-load-com) 
  (setq om (getvar "OSMODE") cmd (getvar "CMDECHO") 
        adoc (vla-get-activedocument (vlax-get-acad-object)) 
        util (vla-get-utility adoc) 
        bks (vla-get-blocks adoc) 
        ass (vla-get-ActiveSelectionSet adoc)
        cnt T)
  (if (/= (vla-get-count ass) 0) (vla-clear ass)) 
  (vla-endundomark adoc)
  (vla-startundomark adoc)
  (setvar "cmdecho" 0)
  (prompt "\nSelect Entity Group(s) to Replace: ")
  (while cnt
    (vla-SelectOnScreen ass)
    (setq csp (vla-ObjectIDToObject adoc (vla-get-OwnerID (vla-item ass 0))))
    (vlax-for it ass
      (vla-getboundingbox it 'pt1 'pt2)
      (setq pts (mapcar '(lambda (x) (reverse (cdr (reverse (vlax-safearray->list x))))) (list pt1 pt2))
            ptn (if (apply 'and (mapcar '(lambda (x y) (<= x y)) (car pts) ptm)) (car pts) ptn)
            ptx (if (apply 'and (mapcar '(lambda (x y) (>= x y)) (cadr pts) ptx)) (cadr pts) ptx)
            lpts (cons (vlax-3d-point (mapcar ' (lambda (x y) (* 0.5 (+ x y))) ptn ptx)) lpts));setq
      (vla-erase ass) (vla-clear ass));vlax-for
    (setq stp (getstring T "\nStop  or <Enter> to Continue: ")
          cnt (if (eq stp "") T nil)));while
  (vla-InitializeUserInput util 128 "Insert Copy") 
  (setq opt (vla-getKeyWord util (strcat "\nSelect Cloning Methode [Insert/Copy] <Copy> :"))) 
  (if (eq "" opt)(setq opt "Copy")) 
  (if (eq opt "Copy")
    (progn (prompt "\n\t***\tSelect Objects \t*** \n : ")
      (setvar "osmode" 0)
      (vla-SelectOnScreen (car css))
      (vla-InitializeUserInput util 1)
      (setq cpt (vla-getpoint util nil "\n\t***\tSelect Refernce Point \t*** \n : ")) 
      (foreach pt lvpts
        (vlax-for obj (car css) (vla-copy obj) (vla-move obj cpt (cadr pt)))));Copy
    (progn (vla-InitializeUserInput util 128 "Drawing File")
      (setq kword (vla-getKeyWord util "\nSelect Source Object from [Drawing/File]: ? <Drawing>")) 
      (if (eq "" kword) (setq kw "Drawing")) 
      (if (= kword "Drawing") (progn
          (setq bname (getstring T "\nEnter New Block's Name or <Enter> to Select: "))
          (if (= bname "") (progn (vla-getEntity util 'blk) (setq bname (vla-get-name blk))))));if
      (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list bks bname)))
        (setq bname (getfiled "Select Source File" "" "dwg" 8)));if
      (vla-delete (vla-insertBlock acsp (vlax-3d-point '(0.0 0.0 0.0)) bname 1 1 1 0 "X"))
      (foreach pt lvpts (vla-Insertblock acsp (cadr pt) bname 1 1 1 0))));if
  (setvar "OSMODE" om) (setvar "CMDECHO" cmd) 
  (vla-endundomark adoc) 
  (vla-regen adoc acActiveViewport) 
(princ) 
);end

Dym · 22.12.2005, 23:55

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

Лентяй · 23.12.2005, 00:46

mitjaj,
В чем конкректно затык имеет место случаться? Какое сообщение появляется при этом? Короче, гони подробности, и коллектив тебе поможет :!:

Dym · 20.04.2006, 14:29

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

Dym · 27.04.2006, 15:55

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

Лентяй · 27.04.2006, 20:16

ExpressTools ->Blocks -> Replace Block with Another Block

Dym · 28.04.2006, 14:44

Цитата:

указать на экране

и анонимные должен понимать

Лентяй · 28.04.2006, 20:12

Код:

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

и анонимные должен понимать

А кофе в койку не желаете?

Dym · 29.04.2006, 11:51

лентяй, ну не грешно так над бедным юзером

Лентяй · 29.04.2006, 23:38

Цитата:

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

лентяй, ну не грешно так над бедным юзером

А вот ни грамма! :twisted: Потому как ИМХО бедный (зарплата чо-ли невелика?) юзер российской, или в вашем случае - латышской, потому как все равно - постсоветской, школы выгодно отличается от такового американско-китайской выучки тем, что понимает что он делает. Потому, что простительно какой-нить Сунь Хунь, опять же - ИМХО, непростительно mitjaj-ю. По сути же - анонимные блоки потому так и прозываются, что не имеют имени, или иначе - у них отсутствует уникальное свойство "Nаме", хотя наличиствует общее свойство "ObjectName", равное "AcDbBlockReference". Поэтому поисковому механизму просто не за что зацепиться. Можно, конечно выделить ВСЕ анонимные блоки на каком-то слое в пределах пространства, но вы не сможете различать в этом наборе различные анонимные блоки между собой.
Да, попробовал было создать анонимный блок в 2005-м. Ни фига! Требует, собака, указывать имя, а инче грит - никак :twisted:

Кулик Алексей aka kpblc · 02.05.2006, 08:56

> Лентяй : Позволю себе не согласиться. Анонимные блоки обладают всеми свойствами обычного блока, в том числе и именем - вида *Uxxx. Просто по быстрому выбору этот блок фиг найдешь, да и по filter он кажись не вызывается...
Насчет создания анонимного блока попробовать можно нечто такое:

Код:

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

(setq blk (vla-add (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (vlax-3d-point '(0.0 0.0 0.0)) "*U")

И будет счастие и благолепие

Dym · 02.05.2006, 14:50

анонимные блоки отлично делает утиль от Лоскутова, причём с минимумом движенийю, http://www.uniip.ru/lib/download/download.html. поисковый механизм работает в коде FRTO by Smirnoff в этой же ветке. а бедный я потому как учусь ещё только и целины этой у меня столько непаханной..

12.10.2005, 19:15		#1
Змена блока на другой блок ilka_t Москва Регистрация: 20.01.2004 Сообщений: 154 Может кто сможнт лиспик написать как в одном чертеже заменить часть блоков (выбрав их) на другой блок. Express не подходит т.к. он иеняет все блоки махом, а мне нужно не все, и заменяемые блоки могут быть с разным именем
Просмотров: 18416