Тема от Денис Флюстиков (изменено: Денис Флюстиков, 5 января 2010г. 22:36:36)

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Тема: LISP. Изменение базовой точки блока

;|=============================================

Изменение базовой точки блока

Программа Дениса Флюстикова "bBlock_Den"

Макрос для кнопки:
^C^C^P(load "bBlock_Den");bBlock_Den

Замечания и предложения по адресу fd-@mail.ru
===============================================|;

(defun C:bBlock_Den (/ aa0 aa1 aa2 aa3 aa4 aa5 aa6)

(setq aa4 nil)

(while (null aa4)

(if (setq aa1 (entsel "\nВыберите блок:"))(progn
(setq aa1 (car aa1)
      aa2 (entget aa1))

(if (= (cdr (assoc 0 aa2)) "INS ERT")
(if (wcmatch (setq aa3 (cdr (assoc 2 aa2))) "`**")
(princ "\nПрограмма не работает с неименованными блоками")
(setq aa6 (list (cdr (assoc 41 aa2))
        (cdr (assoc 42 aa2))
        (cdr (assoc 43 aa2)))
      aa4 (cdr (assoc 50 aa2))
      aa2 (cdr (assoc 10 aa2)))
)
(princ "\nБлок не выбран")
)
))
)

(if aa3 (progn
(setq aa0 (getpoint "\nНовая базовая точка:")
      aa4 (- (angle aa0 aa2) aa4)
      aa2 (polar '(0 0 0) aa4 (distance aa2 aa0))
      aa2 (mapcar '/ aa2 aa6))

(setvar "CMDECHO" 0)
(command "_.undo" "_g"
     "_.-bedit" aa3
     "_.move" (ssget "_A") "" '(0 0 0) aa2
     "_.bclose" "_s")

(setq aa1 (ssget "_A" (list (cons 0 "INS ERT")(cons 2 aa3))))

(repeat (setq aa3 (sslength aa1))

(setq aa3 (1- aa3)
      aa4 (ssname aa1 aa3)
      aa6 (entget aa4)
      aa0 (list (cdr (assoc 41 aa6))
        (cdr (assoc 42 aa6))
        (cdr (assoc 43 aa6)))
      aa5 (cdr (assoc 50 aa6))
      aa6 (cdr (assoc 8 aa6))
      aa0 (mapcar '* aa0 aa2)
      aa5 (+ (angle aa0 '(0 0 0)) aa5)
      aa5 (polar '(0 0 0) aa5 (distance aa0 '(0 0 0))))

(if (= (cdr (assoc 70 (tblsearch "Layer" aa6))) 4)
(command "_.'layer" "_u" aa6 "")
(se tq aa6 nil)
)

(command "_.move" aa4 "" '(0 0 0) aa5)

(if aa6
(command "_.'layer" "_lo" aa6 "")
)

)

(command "_.undo" "_e")
(se tvar "CMDECHO" 1)

))

(princ)
)
Спасибо сказали: Valery Brelovsky1

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

Нормально не удалось вставить код, несколько попыток отредактировать не помогло.
Так и  осталось:
"INS ERT"        вместо     "INS ERT",
(se tvar "CMDECHO" 1)     вместо     (setvar "CMDECHO" 1),
(se tq aa6 nil)        вместо     (se tq aa6 nil)

Поэтому продублировал код на форуме

  • Откуда: Свердловская / Екатеринбург
  • На форуме с 1 апреля 2008г.
  • Сообщений: 18
  • Спасибо: 0

Re: LISP. Изменение базовой точки блока

Денис, спасибо за программу!
А можно добавить в нее обновление атрибутов.

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

kheylan,
Пришли, пожалуйста, DWG-файлик с примером мне на fd-@mail.ru
Попытаюсь учесть этот момент с программе.

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

kheylan пишет:

Денис, спасибо за программу!
А можно добавить в нее обновление атрибутов.

Файл получил, программу обновил (код продублирую на форуме, т.к. ошибки при копировании здесь остались)

;|====================================================

Изменение базовой точки блока

Программа Дениса Флюстикова "bBlock_Den" от 09.01.10:
обновление атрибутов после преобразования блока

Макрос для кнопки:
^C^C^P(load "bBlock_Den");bBlock_Den

Замечания и предложения по адресу fd-@mail.ru
====================================================|;

(defun C:bBlock_Den (/ aa0 aa1 aa2 aa3 aa4 aa5 aa6)

(if (setq aa1 (ssget "_I" '((0 . "INS ERT"))))
(if (= (sslength aa1) 1)
(setq aa1 (ssname aa1 0)
      aa2 (entget aa1))
(setq aa1 nil)
))
(sssetfirst nil)

(while (null aa1)

(if (setq aa1 (entsel "\nВыберите блок:"))(progn
(setq aa1 (car aa1)
      aa2 (entget aa1))

(if (/= (cdr (assoc 0 aa2)) "INS ERT")(progn
(princ "\nБлок не выбран")
(setq aa1 nil)
))
))
)

(if (wcmatch (setq aa3 (cdr (assoc 2 aa2))) "`**")
(princ "\nПрограмма не работает с неименованными блоками")(progn

(setq aa6 (list (cdr (assoc 41 aa2))
        (cdr (assoc 42 aa2))
        (cdr (assoc 43 aa2)))
      aa4 (cdr (assoc 50 aa2))
      aa2 (cdr (assoc 10 aa2))
      aa2 (trans aa2 0 1)
      aa0 (getpoint "\nНовая базовая точка:")
      aa4 (- (angle aa0 aa2) aa4)
      aa2 (polar '(0 0 0) aa4 (distance aa2 aa0))
      aa2 (mapcar '/ aa2 aa6))

(setvar "CMDECHO" 0)
(command "_.undo" "_g"
     "_.-bedit" aa3
     "_.move" (ssget "_A") "" "_none" '(0 0 0) "_none" aa2
     "_.bclose" "_s")

(setq aa1 (ssget "_A" (list (cons 0 "INS ERT")(cons 2 aa3))))

(repeat (setq aa3 (sslength aa1))

(se tq aa3 (1- aa3)
      aa6 (entget (ssname aa1 aa3))
      aa0 (list (cdr (assoc 41 aa6))
        (cdr (assoc 42 aa6))
        (cdr (assoc 43 aa6)))
      aa5 (cdr (assoc 50 aa6))
      aa4 (assoc 10 aa6)
      aa0 (mapcar '* aa0 aa2)
      aa5 (+ (angle aa0 '(0 0 0)) aa5)
      aa5 (polar (cdr aa4) aa5 (distance aa0 '(0 0 0)))
      aa6 (subst (cons 10 aa5) aa4 aa6)
      aa4 (cdr (assoc 8 aa6)))

(if (= (cdr (assoc 70 (tblsearch "Layer" aa4))) 4)
(command "_.'layer" "_u" aa4 "")
(se tq aa4 nil)
)

(entmod aa6)

(if aa4 (command "_.'layer" "_lo" aa4 ""))

)

(if (= (cdr (assoc 66 aa6)) 1)
(command "_.attsync" "_n" (cdr (assoc 2 aa6))))

(command "_.undo" "_e")
(se tvar "CMDECHO" 1)

))
(princ)
)

  • Откуда: Свердловская / Екатеринбург
  • На форуме с 1 апреля 2008г.
  • Сообщений: 18
  • Спасибо: 0

Re: LISP. Изменение базовой точки блока

Денис,еще раз спасибо!
Но, Программа не работает с неименованными блоками, типа *U8, которые создает программа прокат и др.
С этим можно, что-нибудь сделать?!

  • VVA
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 29 марта 2006г.
  • Сообщений: 1,859
  • Спасибо: 25

Re: LISP. Изменение базовой точки блока

kheylan пишет:

Денис,еще раз спасибо!
Но, Программа не работает с неименованными блоками, типа *U8, которые создает программа прокат и др.
С этим можно, что-нибудь сделать?!

Можно.
U2B - конвертирует анонимные (*U) блоки в обычные

  • Откуда: Израиль / Север Израиля / Кирь
  • На форуме с 3 июня 2005г.
  • Сообщений: 2,359
  • Спасибо: 19

Re: LISP. Изменение базовой точки блока

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

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

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

  • Откуда: Израиль / Север Израиля / Кирь
  • На форуме с 3 июня 2005г.
  • Сообщений: 2,359
  • Спасибо: 19

Re: LISP. Изменение базовой точки блока

Денис Флюстиков,
Наверное стоит попробовать. Со своими блоками проблемы нет, а вот с чужими бываю проблемы. Сделают точку от фонаря что и на экран не попадает и работа теряет комфорт. :)

Ответ от Денис Флюстиков (изменено: Денис Флюстиков, 7 марта 2010г. 11:31:25)

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

Valery Brelovsky,
Большая просьба выслать мне на fd-@mail.ru файлик с "чужими" блоками, может и получится сделать работу без потери комфорта.

  • Откуда: Израиль / Север Израиля / Кирь
  • На форуме с 3 июня 2005г.
  • Сообщений: 2,359
  • Спасибо: 19

Re: LISP. Изменение базовой точки блока

Денис Флюстиков, Собственно говоря как раз Ваша программа и позволяет решить вопрос комфорта. Жаль что не работает в 2000. :(
Блоки они не из других программа. Просто сделаны другими исполнителями. А я работаю в основном со своими. Если конечно хотите есть у меня где то пару таких блоков до которых руки не дошли переделать. :)

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

;|====================================================

Изменение базовой точки блока

Программа Дениса Флюстикова "bBlock_Den" от 24.06.10:
новое: возможность переименования блоков

Макрос для кнопки:
^C^C^P(load "bBlock_Den");bBlock_Den

Замечания и предложения по адресу fd-@mail.ru
====================================================|;

(defun C:bBlock_Den (/ aa0 aa1 aa2 aa3 aa4 aa5 aa6)

(if (setq aa1 (ssget "_I" '((0 . "INS ERT"))))
(if (= (sslength aa1) 1)
(setq aa1 (ssname aa1 0)
      aa2 (entget aa1))
(setq aa1 nil)
))
(sssetfirst nil)

(while (null aa1)

(if (setq aa1 (entsel "\nВыберите блок:"))(progn
(setq aa1 (car aa1)
      aa2 (entget aa1))

(if (/= (cdr (assoc 0 aa2)) "INS ERT")(progn
(princ "\nБлок не выбран")
(setq aa1 nil)
))
))
)

(if (wcmatch (setq aa3 (cdr (assoc 2 aa2))) "`**")
(princ "\nПрограмма не работает с неименованными блоками")(progn

(setq aa6 (list (cdr (assoc 41 aa2))
        (cdr (assoc 42 aa2))
        (cdr (assoc 43 aa2)))
      aa4 (cdr (assoc 50 aa2))
      aa2 (cdr (assoc 10 aa2))
      aa2 (trans aa2 0 1)
      aa0 (getpoint "\nНовая базовая точка или <Новое имя>:"))

(if aa0 (progn
(setq aa4 (- (angle aa0 aa2) aa4)
      aa2 (polar '(0 0 0) aa4 (distance aa2 aa0))
      aa2 (mapcar '/ aa2 aa6))

(setvar "CMDECHO" 0)
(command "_.undo" "_g"
     "_.-bedit" aa3
     "_.move" (ssget "_A") "" "_none" '(0 0 0) "_none" aa2
     "_.bclose" "_s")

(setq aa1 (ssget "_A" (list (cons 0 "INS ERT")(cons 2 aa3))))

(repeat (setq aa3 (sslength aa1))

(setq aa3 (1- aa3)
      aa6 (entget (ssname aa1 aa3))
      aa0 (list (cdr (assoc 41 aa6))
        (cdr (assoc 42 aa6))
        (cdr (assoc 43 aa6)))
      aa5 (cdr (assoc 50 aa6))
      aa4 (assoc 10 aa6)
      aa0 (mapcar '* aa0 aa2)
      aa5 (+ (angle aa0 '(0 0 0)) aa5)
      aa5 (polar (cdr aa4) aa5 (distance aa0 '(0 0 0)))
      aa6 (subst (cons 10 aa5) aa4 aa6)
      aa4 (cdr (assoc 8 aa6)))

(if (= (cdr (assoc 70 (tblsearch "Layer" aa4))) 4)
(command "_.'layer" "_u" aa4 "")
(setq aa4 nil)
)

(entmod aa6)

(if aa4 (command "_.'layer" "_lo" aa4 ""))

)

(if (= (cdr (assoc 66 aa6)) 1)
(command "_.attsync" "_n" (cdr (assoc 2 aa6))))

(command "_.undo" "_e")
(setvar "CMDECHO" 1)

)(progn

(setq aa4 (getvar "VIEWCTR")
      aa5 (cadr (grread 1 1))
      aa6 (angle aa4 aa5)
      aa1 (distance aa4 aa5)
      aa4 (getvar "SCREENSIZE")
      aa5 (/ (cadr aa4)(getvar "VIEWSIZE"))
      aa4 (mapcar '/ aa4 '(2 2))
      aa5 (polar aa4 (- aa6) (* aa1 aa5))
      aa5 (mapcar '(lambda (q) (fix q)) aa5)
      aa1 (strcat (getvar "SAVEFILEPATH") "\\bBlock_Den.dcl"))

(while aa4

(setq aa2 (open aa1 "w"))

(write-line
  "bBlock_Den : dialog {
  label = \"Новое имя блока:\";
  :edit_box { key = \"aa\"; allow_accept = true; }
  ok_cancel;
  }" aa2)

(close aa2)

(setq aa2 (load_dialog aa1)
      aa4 1)

(if (null (new_dialog "bBlock_Den" aa2 "" aa5))(exit))

(set_tile  "aa" aa3)

(action_tile "aa" "(setq aa0 $value)")
(mode_tile "aa" 2)
(action_tile "accept" "(done_dialog)(se tq ok_button T)")
(action_tile "cancel" "(done_dialog)(se tq ok_button nil aa0 \"\")")

(start_dialog)
(unload_dialog aa2)

(vl-file-delete aa1)

(foreach aa6 '(34 42 44 47 58 59 60 62 63 92 96 124)
(if (member aa6 (vl-string->list aa0))(se tq aa4 (* aa4 0)))
)

(if (or (zerop aa4)
    (member aa0 '("DIRECT" "LIGHT" "AVE_RENDER" "RM_SDB" "SH_SPOT" "OVERHEAD")))
(princ "\nНедопустимое имя блока")
(if (and (tblsearch "BLOCK" aa0)(/= aa0 aa3))
(princ (strcat "\nБлок с именем " aa0 " уже существует"))
(se tq aa4 nil)
))
(princ)
)

(if (/= (vl-string-trim " " aa0) "")(progn

(se tvar "CMDECHO" 0)
(vl-cmdf "_.rename"  "_b" aa3 aa0)

(while (= (getvar 'cmdactive) 1)
(princ "\nНедопустимое имя блока
       \nНовое имя блока:")
(vl-cmdf pause)
)

(se tvar "CMDECHO" 1)

))
))))
(princ)
)

Ответ от Alan (изменено: Alan aka Александр Назаров, 25 июня 2010г. 17:02:05)

  • Alan
  • Активный участник
  • Откуда: Украина / Киев
  • На форуме с 2 апреля 2002г.
  • Сообщений: 1,345
  • Спасибо: 15

Re: LISP. Изменение базовой точки блока

Денис, я немного не понял.
.........Убрал лишнее, чтобы не отвлекать....
Решил я попробовать переименовать блок. В ответ на вопрос
(getpoint "\nНовая базовая точка или <Новое имя>:") ответил 123.
И завис Акад...
М.б. я не разобрался?

Ответ от Alan (изменено: Alan aka Александр Назаров, 25 июня 2010г. 17:01:18)

  • Alan
  • Активный участник
  • Откуда: Украина / Киев
  • На форуме с 2 апреля 2002г.
  • Сообщений: 1,345
  • Спасибо: 15

Re: LISP. Изменение базовой точки блока

:oops:  Ну первой часть разобрался, и убрал.
Ну а этот остался.
Решил я попробовать переименовать блок. В ответ на вопрос
(getpoint "\nНовая базовая точка или <Новое имя>:") ответил 123.
И завис Акад...

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

Опять ошибки при заливке кода в сообщение.
Поэтому после создания файла bBlock_Den.lsp со скопированным кодом необходимо убрать пробелы в словах:
INS ERT
se tvar
se tq

А для переименования выбранного блока, во время сообщения
"Новая базовая точка или <Новое имя>:"
правый клик или пробел

Удачи!

  • Откуда: Израиль / Север Израиля / Кирь
  • На форуме с 3 июня 2005г.
  • Сообщений: 2,359
  • Спасибо: 19

Re: LISP. Изменение базовой точки блока

Денис Флюстиков пишет:

Valery Brelovsky, 
Большая просьба выслать мне на fd-@mail.ru файлик с "чужими" блоками, может и получится сделать работу без потери комфорта.

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

  • Откуда: Израиль / Север Израиля / Кирь
  • На форуме с 3 июня 2005г.
  • Сообщений: 2,359
  • Спасибо: 19

Re: LISP. Изменение базовой точки блока

Денис Флюстиков,
Фирма стала переходить на новую версию Автокада и теперь можно воспользоваться Вашей программой. :) Спасибо Вам.

Ответ от Денис Флюстиков (изменено: Денис Флюстиков, 9 ноября 2011г. 12:09:24)

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

;|====================================================

Изменение базовой точки, переименование блока или добавление в него новых объектов

Программа Дениса Флюстикова "bBlock_Den" от 07.11.11исправл.

Функции программы:
1. Изменение базовой точки блока.
2. Добавление объектов в блок.
3. Переименование всех блоков с именем как у образца.
4. Переименование только указанного блока.
   Алгоритм от Эдуарда из Insert_rename:
   http://forum.dwg.ru/showpost.php?p=62364&postcount=17

Внимание:
Полилинии расчленяются при добавлении их в блок с разными масштабами.

Макрос для кнопки:
^C^C^P(load "bBlock_Den");bBlock_Den

Замечания и предложения по адресу fd-@mail.ru
====================================================|;

(defun C:bBlock_Den (/ aa0 aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8)

(if (setq aa1 (ssget "_I" '((0 . "INSERT"))))
(if (= (sslength aa1) 1)
(setq aa1 (ssname aa1 0)
      aa2 (entget aa1))
(setq aa1 nil)
))
(sssetfirst nil)

(while (null aa1)

(if (setq aa1 (entsel "\nВыберите блок:"))(progn
(setq aa1 (car aa1)
      aa2 (entget aa1))

(if (/= (cdr (assoc 0 aa2)) "INSERT")(progn
(princ "\nБлок не выбран")
(setq aa1 nil)
))
))
)

(if (wcmatch (setq aa3 (cdr (assoc 2 aa2))) "`**")
(princ "\nПрограмма не работает с неименованными блоками")(progn

(setq aa6 (list (cdr (assoc 41 aa2))
        (cdr (assoc 42 aa2))
        (cdr (assoc 43 aa2)))
      aa4 (cdr (assoc 50 aa2))
      aa2 (cdr (assoc 10 aa2))
      aa2 (trans aa2 0 1)
      aa7 "\nНовая базовая точка или [Новое имя блоков/только Указанного/Добавить объекты]:")

(initget 6 "Н У Д")
(if (null (setq aa0 (getpoint aa7)))
(setq aa0 "Н")
)

(if (= (type aa0) 'STR)
(if (= aa0 "Д")(progn

(setq aa0 (ssget)
      aa0 (ssdel aa1 aa0)
      aa1 "temp"
      aa5 (getvar "EXPLMODE")
      aa6 (mapcar '/ '(1 1 1) aa6)
      aa7 (getvar "OSMODE"))

(if (> (sslength aa0) 0)(progn

(while (/= (tblsearch "block" aa1) nil)
(setq aa1 (strcat aa1 "1")))

(setvar "CMDECHO" 0)
(command "_.undo" "_g")
(setvar "OSMODE" 0)
(command "_.rotate" aa0 "" aa2 (* -180 (/ aa4 pi))
     "_.block" aa1 aa2 aa0 ""
     "_.-bedit" aa3
     "_.insert" aa1 "_x" (car aa6) "_y" (cadr aa6) "_z" (caddr aa6) '(0 0 0))

(while (= (getvar 'cmdactive) 1)(command ""))

(setvar "EXPLMODE" 1)
(command "_.explode" (entlast)
     "_.bclose" "_s"
     "_.-purge" "_b" aa1 "_n")

(setvar "EXPLMODE" aa5)
(setvar "OSMODE" aa7)
(command "_.undo" "_e")
(setvar "CMDECHO" 1)
))
)(progn

(setq aa4 (getvar "VIEWCTR")
      aa5 (cadr (grread 1 1))
      aa6 (angle aa4 aa5)
      aa8 (distance aa4 aa5)
      aa4 (getvar "SCREENSIZE")
      aa5 (/ (cadr aa4)(getvar "VIEWSIZE"))
      aa4 (mapcar '/ aa4 '(2 2))
      aa5 (polar aa4 (- aa6) (* aa8 aa5))
      aa5 (mapcar '(lambda (q) (fix q)) aa5)
      aa8 (vl-filename-directory (findfile "bBlock_Den.lsp"))
      aa8 (strcat aa8 "\\bBlock_Den.dcl"))

(while aa4

(setq aa2 (open aa8 "w"))

(write-line
  "bBlock_Den : dialog {
  label = \"Новое имя блока:\";
  :edit_box { key = \"aa\"; allow_accept = true; }
  ok_cancel;
  }" aa2)

(close aa2)

(setq aa2 (load_dialog aa8)
      aa4 1)

(if (null (new_dialog "bBlock_Den" aa2 "" aa5))(exit))

(set_tile  "aa" aa3)

(action_tile "aa" "(setq aa7 $value)")
(mode_tile "aa" 2)
(action_tile "accept" "(done_dialog)")
(action_tile "cancel" "(done_dialog)(setq aa4 nil aa1 nil)")

(start_dialog)
(unload_dialog aa2)

(vl-file-delete aa8)

(foreach aa6 '(34 42 44 47 58 59 60 62 63 92 96 124)
(if (member aa6 (vl-string->list aa7))(setq aa4 (* aa4 0)))
)

(if aa1
(if (or (zerop aa4)
    (not (snvalid aa7))
    (member aa7 '("DIRECT" "LIGHT" "AVE_RENDER" "RM_SDB" "SH_SPOT" "OVERHEAD")))
(princ "\nНедопустимое имя блока")
(if (and (tblsearch "BLOCK" aa7)(/= aa7 aa3))
(princ (strcat "\nБлок с именем " aa7 " уже существует"))
(setq aa4 nil)
)))
(princ)
)

(if aa1
(if (/= (vl-string-trim " " aa7) "")
(if (= aa0 "Н")(progn

(setvar "CMDECHO" 0)
(vl-cmdf "_.rename" "_b" aa3 aa7)

(while (= (getvar 'cmdactive) 1)
(princ "\nНедопустимое имя блока
       \nНовое имя блока:")
(vl-cmdf pause)
)

(setvar "CMDECHO" 1)

)(progn

; Код от Эдуарда из Insert_rename:
; http://forum.dwg.ru/showpost.php?p=62364&postcount=17
(vl-load-com)

(setq aa0 (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
      aa8 (vla-item aa0 (cdr (assoc 2 (entget aa1)))))

(vlax-for aa3 aa8 (setq aa4 (cons aa3 aa4)))

(setq aa2 (vlax-make-safearray vlax-vbobject (cons 0 (1- (length aa4)))))

(vlax-safearray-fill aa2 aa4)

(setq aa5 (vla-add aa0 (vlax-3d-point '(0 0 0)) aa7))

(vla-CopyObjects (vla-get-ActiveDocument (vlax-get-acad-object)) aa2 aa5)
(vla-put-name (vlax-ename->vla-object aa1) aa7)

))
))
))
(progn
(setq aa4 (- (angle aa0 aa2) aa4)
      aa2 (polar '(0 0 0) aa4 (distance aa2 aa0))
      aa2 (mapcar '/ aa2 aa6))

(setvar "CMDECHO" 0)
(command "_.undo" "_g"
     "_.-bedit" aa3
     "_.move" (ssget "_A") "" "_none" '(0 0 0) "_none" aa2
     "_.bclose" "_s")

(setq aa1 (ssget "_A" (list (cons 0 "INSERT")(cons 2 aa3))))

(repeat (setq aa3 (sslength aa1))

(setq aa3 (1- aa3)
      aa6 (entget (ssname aa1 aa3))
      aa0 (list (cdr (assoc 41 aa6))
        (cdr (assoc 42 aa6))
        (cdr (assoc 43 aa6)))
      aa5 (cdr (assoc 50 aa6))
      aa4 (assoc 10 aa6)
      aa0 (mapcar '* aa0 aa2)
      aa5 (+ (angle aa0 '(0 0 0)) aa5)
      aa5 (polar (cdr aa4) aa5 (distance aa0 '(0 0 0)))
      aa6 (subst (cons 10 aa5) aa4 aa6)
      aa4 (cdr (assoc 8 aa6)))

(if (= (cdr (assoc 70 (tblsearch "Layer" aa4))) 4)
(command "_.'layer" "_u" aa4 "")
(setq aa4 nil)
)

(entmod aa6)

(if aa4 (command "_.'layer" "_lo" aa4 ""))

)

(if (= (cdr (assoc 66 aa6)) 1)
(command "_.attsync" "_n" (cdr (assoc 2 aa6))))

(command "_.undo" "_e")
(setvar "CMDECHO" 1)

))))
(princ)
)

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

;|==================================================­==

Дополнительные функции для работы с блоками

Программа Дениса Флюстикова "bBlock_Den" от 05.12.11, новое:
замена всех блоков с указанным именем на выбранный или выборочно.

Функции программы:
1. Изменение базовой точки блока.
2. Добавление объектов в блок.
3. Переименование всех блоков с именем как у образца.
4. Переименование только указанного блока.
   Алгоритм от Эдуарда из Insert_rename:
   http://forum.dwg.ru/showpost.php?p=62364&postcount=17
5. Замена всех блоков с указанным именем на выбранный или выборочно
   (ESC - откат замен).

Внимание: 
Полилинии расчленяются при добавлении их в блок с разными масштабами.

Макрос для кнопки: 
^C^C^P(load "bBlock_Den");bBlock_Den 

Замечания и предложения по адресу fd-@mail.ru 
==================================================­==|; 

(defun C:bBlock_Den (/ aa0 aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8)

(if (setq aa1 (ssget "_I" '((0 . "INSERT"))))
(if (= (sslength aa1) 1)
(setq aa1 (ssname aa1 0)
      aa2 (entget aa1))
(setq aa1 nil)
))
(sssetfirst nil)

(while (null aa1)

(if (setq aa1 (entsel "\nВыберите блок:"))(progn
(setq aa1 (car aa1)
      aa2 (entget aa1))

(if (/= (cdr (assoc 0 aa2)) "INSERT")(progn
(princ "\nБлок не выбран")
(setq aa1 nil)
))
))
)

(if (wcmatch (setq aa3 (cdr (assoc 2 aa2))) "`**")
(princ "\nПрограмма не работает с неименованными блоками")(progn

(setq aa6 (list (cdr (assoc 41 aa2))
        (cdr (assoc 42 aa2))
        (cdr (assoc 43 aa2)))
      aa4 (cdr (assoc 50 aa2))
      aa2 (cdr (assoc 10 aa2))
      aa2 (trans aa2 0 1)
      aa7 "\nНовая базовая точка или [Новое имя блоков/только Указанного/Заменить блоки/Добавить объекты]:")

(initget 6 "Н У З Д")
(if (null (setq aa0 (getpoint aa7)))
(setq aa0 "Н")
)
(vl-load-com)
(cond
((/= (type aa0) 'STR)

(setq aa4 (- (angle aa0 aa2) aa4)
      aa2 (polar '(0 0 0) aa4 (distance aa2 aa0))
      aa2 (mapcar '/ aa2 aa6))

(setvar "CMDECHO" 0)
(command "_.undo" "_g"
     "_.-bedit" aa3
     "_.move" (ssget "_A") "" "_none" '(0 0 0) "_none" aa2
     "_.bclose" "_s")

(setq aa1 (ssget "_A" (list (cons 0 "INSERT")(cons 2 aa3))))

(repeat (setq aa3 (sslength aa1))

(setq aa3 (1- aa3)
      aa6 (entget (ssname aa1 aa3))
      aa0 (list (cdr (assoc 41 aa6))
        (cdr (assoc 42 aa6))
        (cdr (assoc 43 aa6)))
      aa5 (cdr (assoc 50 aa6))
      aa4 (assoc 10 aa6)
      aa0 (mapcar '* aa0 aa2)
      aa5 (+ (angle aa0 '(0 0 0)) aa5)
      aa5 (polar (cdr aa4) aa5 (distance aa0 '(0 0 0)))
      aa6 (subst (cons 10 aa5) aa4 aa6)
      aa4 (cdr (assoc 8 aa6)))

(if (= (cdr (assoc 70 (tblsearch "Layer" aa4))) 4)
(command "_.'layer" "_u" aa4 "")
(setq aa4 nil)
)

(entmod aa6)

(if aa4 (command "_.'layer" "_lo" aa4 ""))

)

(if (= (cdr (assoc 66 aa6)) 1)
(command "_.attsync" "_n" (cdr (assoc 2 aa6))))

(command "_.undo" "_e")
(setvar "CMDECHO" 1)
)
((= aa0 "Д")

(setq aa0 (ssget)
      aa0 (ssdel aa1 aa0)
      aa1 "temp"
      aa5 (getvar "EXPLMODE")
      aa6 (mapcar '/ '(1 1 1) aa6)
      aa7 (getvar "OSMODE"))      

(if (> (sslength aa0) 0)(progn

(while (/= (tblsearch "block" aa1) nil)
(setq aa1 (strcat aa1 "1")))

(setvar "CMDECHO" 0)
(command "_.undo" "_g")
(setvar "OSMODE" 0)
(command "_.rotate" aa0 "" aa2 (* -180 (/ aa4 pi))
     "_.block" aa1 aa2 aa0 ""
     "_.-bedit" aa3
     "_.insert" aa1 "_x" (car aa6) "_y" (cadr aa6) "_z" (caddr aa6) '(0 0 0))

(while (= (getvar 'cmdactive) 1)(command ""))

(setvar "EXPLMODE" 1)
(command "_.explode" (entlast)
     "_.bclose" "_s"
     "_.-purge" "_b" aa1 "_n")

(setvar "EXPLMODE" aa5)
(setvar "OSMODE" aa7)
(command "_.undo" "_e")
(setvar "CMDECHO" 1)
))
)
((or (= aa0 "Н")(= aa0 "У"))

(setq aa4 (getvar "VIEWCTR")
      aa5 (cadr (grread 1 1))
      aa6 (angle aa4 aa5)
      aa8 (distance aa4 aa5)
      aa4 (getvar "SCREENSIZE")
      aa5 (/ (cadr aa4)(getvar "VIEWSIZE"))
      aa4 (mapcar '/ aa4 '(2 2))
      aa5 (polar aa4 (- aa6) (* aa8 aa5))
      aa5 (mapcar '(lambda (q) (fix q)) aa5)
      aa8 (strcat (getvar "DWGPREFIX") "bBlock_Den.dcl"))

(while aa4

(setq aa2 (open aa8 "w"))

(write-line
  "bBlock_Den : dialog {
  label = \"Новое имя блока:\";
  :edit_box { key = \"aa\"; allow_accept = true; }
  ok_cancel;
  }" aa2)

(close aa2)

(setq aa2 (load_dialog aa8)
      aa4 1)

(if (null (new_dialog "bBlock_Den" aa2 "" aa5))(exit))

(set_tile  "aa" aa3)

(action_tile "aa" "(setq aa7 $value)")
(mode_tile "aa" 2)
(action_tile "accept" "(done_dialog)")
(action_tile "cancel" "(done_dialog)(setq aa4 nil aa1 nil)")

(start_dialog)
(unload_dialog aa2)

(vl-file-delete aa8)

(foreach aa6 '(34 42 44 47 58 59 60 62 63 92 96 124)
(if (member aa6 (vl-string->list aa7))(setq aa4 (* aa4 0)))
)

(if aa1
(if (or (zerop aa4)
    (not (snvalid aa7))
    (member aa7 '("DIRECT" "LIGHT" "AVE_RENDER" "RM_SDB" "SH_SPOT" "OVERHEAD")))
(princ "\nНедопустимое имя блока")
(if (and (tblsearch "BLOCK" aa7)(/= aa7 aa3))
(princ (strcat "\nБлок с именем " aa7 " уже существует"))
(setq aa4 nil)
)))
(princ)
)

(if aa1
(if (/= (vl-string-trim " " aa7) "")
(if (= aa0 "Н")(progn

(setvar "CMDECHO" 0)
(vl-cmdf "_.rename" "_b" aa3 aa7)

(while (= (getvar 'cmdactive) 1)
(princ "\nНедопустимое имя блока
       \nНовое имя блока:")
(vl-cmdf pause)
)

(setvar "CMDECHO" 1)

)(progn

 ; Код от Эдуарда из Insert_rename:
 ; http://forum.dwg.ru/showpost.php?p=62364&postcount=17

(setq aa0 (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
      aa8 (vla-item aa0 (cdr (assoc 2 (entget aa1)))))

(vlax-for aa3 aa8 (setq aa4 (cons aa3 aa4)))

(setq aa2 (vlax-make-safearray vlax-vbobject (cons 0 (1- (length aa4)))))

(vlax-safearray-fill aa2 aa4)

(setq aa5 (vla-add aa0 (vlax-3d-point '(0 0 0)) aa7))

(vla-CopyObjects (vla-get-ActiveDocument (vlax-get-acad-object)) aa2 aa5)
(vla-put-name (vlax-ename->vla-object aa1) aa7)

))
))
)
((= aa0 "З")

(defun bBlock_Den1 ()
(setq aa6 (1+ aa6))
(command "_.undo" "_m")
(repeat (setq aa1 (sslength aa5))
(setq aa1 (1- aa1)
      aa4 (entget (ssname aa5 aa1))
      aa4 (subst aa3 (assoc 2 aa4) aa4))
(entmod aa4)
)
)

(princ (strcat "\nВыберите блоки для замены на блок "
           aa3
           " <Все блоки с выбранным именем>:"))

(setq aa2 (grread nil 12 2)
      aa3 (cons 2 aa3)
      aa6 0)

(if (or (and (= (car aa2) 2)(= (cadr aa2) 32))    ; пробел
    (and (= (car aa2) 2)(= (cadr aa2) 13))    ; ENTER
    (= (car aa2) 25))(progn             ; правый клик

(while aa2

(if (setq aa1 (strcat "\nВыберите блок для замены всех блоков с данным именем на блок "
              (cdr aa3) ":" )
      aa1 (entsel aa1))(progn
(setq aa1 (car aa1)
      aa4 (entget aa1))

(if (= (cdr (assoc 0 aa4)) "INSERT")
(setq aa2 nil)
(princ "\nБлок не выбран")
)
))
)

(setq aa5 (ssget "_A" (list (cons 0 "INSERT") (assoc 2 aa4))))

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)
(bBlock_Den1)
(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))

)(progn

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "CMDECHO" 0)

(if (setq aa2 (cadr aa2)
      aa5 (ssget aa2 '((0 . "INSERT"))))
(bBlock_Den1)
)

(princ (strcat "\nВыберите блоки для замены на блок "
           (cdr aa3)
           " <Прервать>:"))

(while aa3
(if aa5 (progn
(setq aa2 (vl-catch-all-apply 'grread (list nil 12 2)))
(if (= (type aa2) 'LIST)
(if (or (and (= (car aa2) 2)(= (cadr aa2) 32))
    (and (= (car aa2) 2)(= (cadr aa2) 13))
    (= (car aa2) 25))
(setq aa3 nil)
(if (setq aa2 (cadr aa2)
      aa5 (ssget aa2 '((0 . "INSERT"))))
(bBlock_Den1)
))
(if (> aa6 0)(progn
(command "_.undo" "_b")
(setq aa6 (1- aa6))
)
(setq aa3 nil)
)
)
)
(if (setq aa4 (vl-catch-all-apply 'getcorner (list aa2)))
(if (= (type aa4) 'LIST)(progn
(setq aa5 (ssget (if (< (car aa2)(car aa4)) "_W" "_C") aa4 aa2 '((0 . "INSERT"))))
(if aa5
(bBlock_Den1)
(setq aa5 T)
)
)
(if (> aa6 0)(progn
(command "_.undo" "_b")
(setq aa6 (1- aa6))
)
(setq aa3 nil)
)
)
(setq aa3 nil)
)
)
)
(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
))
)
)
))
(princ)
)

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

Со временем код программы по объему стал большим, решил выложить файлом на dwg.ru

"bBlock_Den" от 11.04.12, новое:
Удаление объектов из блока

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

"bBlock_Den" от 21.04.12, новое:
1. Поворот блоков относительно базовой точки.
2. Масштабирование блоков относительно базовой точки.

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

"bBlock_Den" от 03.09.12:
Исправлена работа масштабирования и поворота блоков с атрибутами.

  • Откуда: Израиль / Север Израиля / Кирь
  • На форуме с 3 июня 2005г.
  • Сообщений: 2,359
  • Спасибо: 19

Re: LISP. Изменение базовой точки блока

Денис Флюстиков пишет:

"bBlock_Den" от 21.04.12, новое:

1. Поворот блоков относительно базовой точки.

2. Масштабирование блоков относительно базовой точки.

Я не знаю в какой версии работаю. Думаю что не в последней. Но программой доволен. Потрежнему не уделяет должного внимания базовой точке блока. Если базавоя точка далеко от блока, с блоком работать не удобно. Ваша программа только и спасает. Хотел поинтересоваться в чём заключается действие поворот и масштабирование блоков вокруг базовой точки. Это речь идёт о блоке в котором меняется базовая точка или выбраных нескольких блоков. Немного не понятен этот момент.

  • На форуме с 12 октября 2005г.
  • Сообщений: 374
  • Спасибо: 10

Re: LISP. Изменение базовой точки блока

Функциями "поворот" и "масштабирование" сам не пользуюсь, ввел в программу эти возможности по просьбе kirsumy (см. http://dwg.ru/dnl/10891 ). Программа за один запуск отрабатывает одну функцию, поэтому если нужно изменить базовую точку и повернуть блок, то лучше сначала изменить базовую точку, затем пробел (повторный вызов программы) и поворот указанного блока, далее идет запрос на выбор для поворота блоков с именем образца. Закончить выбор правым кликом или "Enter", если "ESC", то откат преобразований.