Учим Автокад автоматической расстановки блоков на поверхности чертежа

Автор Тема: Учим Автокад автоматической расстановки блоков на поверхности чертежа  (Прочитано 17618 раз)

0 Пользователей и 1 Гость просматривают эту тему.

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
Продолжаю свою рубрику автоматизации проектирования архитектурного освещения, идея этого макроса пришла, когда на поверхности фасада, согласно светотехнической задачи требовалось расставить несколько сот светильников, которые должны стоять вплотную или совсем рядом! Это выполняет данный макрос. Который отыскивает вспомогательные блоки уровни и вычисляя их длину заполняет линейно заполняет их! Прикладываю файл с выполненным макросом. В предыдущем посте ищу помощи для создания грамотного интерактива в рамках запросов пользователей. Макрос будет претерпевать изменения и я их буду отражать. Будет приятен отклик инженеров, которые увидят дальнейшие пути модификации, отличные от моих.
Код - Auto/Visual Lisp [Выбрать]
  1. (defun c:sv_lamps (/ nabor _len1 _eff_name _block _conduit quantity point counter poinsert _cond )
  2.   (vl-load-com)
  3.   (setq acadd (vlax-get-acad-object))
  4.   (setq active_doc (vla-get-ActiveDocument acadd))
  5.   (setq mspace (vla-get-ModelSpace active_doc))
  6.   (setq L900 9.1)
  7.   (setq L1200 13)
  8.   (setq L600 6)
  9.   (setq xscale 1)
  10.   (setq yscale 1)
  11.   (setq zscale 1)
  12.   (setq rot (/ (getint "Введите угол поворота светильников на карнизах: 0; 180 ") (/ 180 pi)))
  13.   (setq rot1 (/ (getint "Введите угол поворота светильников в дверных проемах: 0; 180 ") (/ 180 pi)))
  14.   (setq nabor (ssget "_X" (list (cons 8 "_АХП_Вспомогательный_слой_не_печать" ) (cons 0 "insert"))))
  15.       (if nabor
  16.                  (progn
  17.                  (princ (strcat "Найдено блоков:" (rtos (sslength nabor) 2 0) "шт."))
  18.                  (terpri)
  19.                    (setq name "L (900 mm)")
  20.                    (setq counter 0)
  21.         (while (< counter (sslength nabor))
  22.                   (setq _block (vlax-ename->vla-object (ssname nabor counter)))
  23.                   (setq point (cdr (assoc 10 (entget (ssname nabor counter)))))
  24.                   (setq x_coord (nth 0 point))
  25.                   (setq y_coord (nth 1 point))
  26.                   (setq z_coord (nth 2 point))
  27.                   (setq _eff_name (vla-get-effectivename _block))
  28.                   (princ _eff_name)
  29.                   (terpri)
  30.         (if
  31.           (wcmatch _eff_name "!Карниз")
  32.           (progn
  33.                   (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  34.           (nth 0 drop)
  35.             (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  36.             (setq quantity (fix (/ _len1 L900)))
  37.             (setq counter1 0)
  38.             (while (< counter1 quantity)
  39.               (setq x_coord` (+ x_coord (/ (+ L900 (/ (- _len1 (* quantity L900)) quantity)) 2) (* 1 counter1 (+ L900 (/ (- _len1 (* quantity L900)) quantity)))))
  40.                                       (setq poinsert (vlax-3d-point x_coord` y_coord z_coord))
  41.              (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot)
  42.                                (setq counter1 (+ 1 counter1)))(princ "ok !Карниз")(terpri))
  43.                              
  44.                   (progn (setq _cond (getint "\n Выберите вариант: 1 - Один блок; 2 - Заполнить проем"))
  45.           (if (= _cond 1) (progn
  46.            (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  47.            (nth 0 drop)
  48.            (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  49.                         (setq x_half (+ x_coord (/ _len1 2)))
  50.                          (setq poinsert (vlax-3d-point  x_half y_coord z_coord))
  51.                 (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot1)
  52.            (princ "ok !Дверной проем")(terpri))
  53.            (progn
  54.              (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  55.            (nth 0 drop)
  56.              (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  57.             (setq quantity (fix (/ _len1 L900)))
  58.             (setq counter1 0)
  59.             (while (< counter1 quantity)
  60.               (setq x_coord` (+ x_coord (/ (+ L900 (/ (- _len1 (* quantity L900)) quantity)) 2) (* 1 counter1 (+ L900 (/ (- _len1 (* quantity L900)) quantity)))))
  61.                 (setq poinsert (vlax-3d-point x_coord` y_coord z_coord))
  62.              (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot1)
  63.                                (setq counter1 (+ 1 counter1))(princ "ok !Дверной проем")(terpri))
  64.             )
  65.                      
  66.      )))
  67.     (princ counter)
  68.                    (setq counter (+ 1 counter))))
  69.                    (progn
  70.                      (alert (princ "\nНет блоков, расположите блоки на фасаде здания"))
  71. (terpri))
  72.         ))
  73.  
  74.            

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Критиковать по частям или как? :)
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
    Пока есть время и мозги еще хоть что-то соображают...
    • (vl-load-com) я бы вынес за пределы команды.
  • Множество строк
Код - Auto/Visual Lisp [Выбрать]
  1. (setq acadd (vlax-get-acad-object))
  2.   (setq active_doc (vla-get-activedocument acadd))
заменить на
Код - Auto/Visual Lisp [Выбрать]
  1. (setq acadd      (vlax-get-acad-object)
  2.         active_doc (vla-get-activedocument acadd)
  3.         )
    [/li]
  • Что будет, если код будет запущен в AutoCAD 2013 Eng без установленного SP?
  • Что будет, если пользователь в ответ на запрос getint нажмет Esc?
  • Что будет, если пользователь в ответ на запрос угла введет не 0 или 180, а 465,656989?
  • Почему набор формируется по заранее определенному слою?
  • Что будет, если код сдуру попытаются запустить в ACAD 2005, где понятия EffectiveName не было?
  • Почему вставка производится именно в пространство модели, хотя блок карниза может запросто находиться в пространстве листа?
  • Почему не используется связка initget - getkword?
  • Что будет, если попадется пользователь, сделавший блок "Карниз" не динамическим?
  • Где метки начала и конца отмены?
Вот как-то так примерно, по первым впечатлениям... Разбираться более подробно пока не хочу :P
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
Спасибо за критику, буду совершенствовать! Лишь отмечу одно, темы относительно старого автокада не рассматриваю, не зачем сидеть с нокией 3310 когда можно купить недорогой iphone, отвечу метафорически примерно так....Алексей от души спасибо, для полета мыслей целое небо предоставил! Выборка по слоям сделал, потому что так нам удобней вводить в чертеж элементы которые не идут на печать, да и блоки найти намного легче (я посмотрел как все ищут динамические блоки, длинновато), мы работаем только в пространстве модели, а листы существуют лишь для печати, отсюда ответ на критику вставки блока в тело модели. По остальному буду думать...

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
Что будет, если попадется пользователь, сделавший блок "Карниз" не динамическим?
Защита от дурака - это блестяще

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
Что будет, если код сдуру попытаются запустить в ACAD 2005, где понятия EffectiveName не было?
Алексей, я не меняя позиции относительно автокадов, но мой пытливый ум сгорает от любопытства, как решить мою задачу с effective name для автокад 2005

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Получаешь OwnerID для выбранного блока, преобразовываешь его в ObjectID (http://autolisp.ru/2014/09/16/objectid_x32x64_cad2015/ + http://autolisp.ru/2011/07/07/x32x64objectid/) - вот тебе и указатель на то, куда вставлять свои блоки.
Что будет, если код будет запущен в AutoCAD 2013 Eng без установленного SP?
Это к вопросу о кириллице в запросе. Лично я давненько уже использую такие функции:
Код - Auto/Visual Lisp [Выбрать]
  1. (defun _kpblc-acad-version ()
  2.                            ;|
  3. *    Определение номера сборки AutoCAD
  4. *    Возвращаемое значение: Число двойной точности. Для AutoCAD 2005 вернет 16.1, для 2006 - 16.2 и т.д.
  5. Примеры вызова:
  6. (_kpblc-acad-version)
  7. |;
  8.   (atof (getvar "acadver"))
  9.   ) ;_ end of defun
  10.  
  11. (defun _kpblc-is-acad-rus ()
  12.                           ;|
  13. *    Проверяет, является ли AutoCAD русским. Для версий AutoCAD до 2012 включительно возвращает t
  14. * независимо от локализации. В версии 2013 обрабатывает язык AutoCAD'a
  15. |;
  16.   (or
  17.     (= (vla-get-localeid (vlax-get-acad-object)) 1049)
  18.     (/= (_kpblc-acad-version) 19.)
  19.     (and (= (_kpblc-acad-version) 19.)
  20.          (vl-registry-descendents
  21.            (strcat
  22.              "HKEY_LOCAL_MACHINE\\"
  23.              (vl-string-trim
  24.                "\\"
  25.                (car (_kpblc-conv-string-to-list (vlax-product-key) ":"))
  26.                ) ;_ end of vl-string-trim
  27.              "\\Service Packs"
  28.              ) ;_ end of strcat
  29.            ) ;_ end of vl-registry-descendents
  30.          ) ;_ end of and
  31.     ) ;_ end of or
  32.   ) ;_ end of defun
Соответственно запрос получается наподобие
Код - Auto/Visual Lisp [Выбрать]
  1. (defun test (/ res)
  2.  
  3.   (if (= (type (setq res (vl-catch-all-apply
  4.                            (function
  5.                              (lambda ()
  6.                                (initget "0 180")
  7.                                (getkword (strcat (if (_kpblc-is-acad-rus)
  8.                                                    "Введите угол "
  9.                                                    "Enter angle value "
  10.                                                    ) ;_ end of if
  11.                                                  "[0/180] <"
  12.                                                  (if (_kpblc-is-acad-rus)
  13.                                                    "Отмена"
  14.                                                    "Cancel"
  15.                                                    ) ;_ end of if
  16.                                                  "> : "
  17.                                                  ) ;_ end of strcat
  18.                                          ) ;_ end of getkword
  19.                                ) ;_ end of lambda
  20.                              ) ;_ end of function
  21.                            ) ;_ end of vl-catch-all-apply
  22.                      ) ;_ end of setq
  23.                ) ;_ end of type
  24.          'str
  25.          ) ;_ end of =
  26.     (princ (strcat "res = " res))
  27.     ) ;_ end of if
  28.   )
темы относительно старого автокада не рассматриваю
А зря... Варианты бывают разные, сильно разные.
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Касаемо старых версий: проверяй доступность свойства EffectiveName. Если его нет - то пробуй получить Name.
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
Про локализацию согласен, тема интересная, а про угол - не использовал initget потому что пользователю разрешается внести любой угол, а 0 и 180 - это предпочитаемые!
Спасибо за помощь
А про старые автокады не пиши "...Зря" пиши почему интересно их изучить, я у себя на работе развернул 2015 и живу хорошо, но раз указываешь, что важно приведи несколько примеров

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Ну, я уже написал причину :) Хорошо, расшифровываю: хотя бы потому, что ты не всю оставшуюся жизнь будешь работать только в сегодняшней конторе. Есть еще и халтуры :) Куда придешь, на какие версии и каких продуктов - тайна, не известная никому. Так что лучше соломку подстелить, благо это вопрос пары минут :)
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
не использовал initget потому что пользователю разрешается внести любой угол, а 0 и 180 - это предпочитаемые
Ок, а что будет, если человеку понадобится вводить угол в 45°16'23''? А какое значение должно быть "по умолчанию" (для клика по Enter)? Может, тогда заменить getint на getangle? А заодно и продумать, от какой точки отмерять этот угол.
ПыСы. Это я еще и про нетекущую систему координат не вспоминаю :) Но это в 90% случаев излишне.
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
Наслушавшись умных советов, добавил интерактива для пользователя, кое-какие вкусности и удобности для него же, но не сделал пока ссылки на проверки версий и.т.д. и вот почему, если обратить внимание, то у меня получилось в коде, для работы одного из условий, точное копирование куска кода, все прекрасно работает, но код не совсем эстетичен, пользователю все равно ибо работает, а вот для меня задача оказалась, странно, нерешаемой по сокращению кода. Уважаемые модераторы, считаю следует объединить эту тему и тему "Как приостановить lisp-макрос, выделить вставленные им блоки, и продолжить его.." ибо в идеале мой макрос будет полностью готовым лишь после того, как я решу все задачи, однако не настаиваю, так как могу вести темы параллельно
Код - Auto/Visual Lisp [Выбрать]
  1. (vl-load-com)
  2. (defun c:sv_lamps (/ nabor _len1 _eff_name _block _conduit quantity point counter poinsert _cond _lenbl x_half x_half y_coord z_coord x_coord` chname chlenbl )
  3.   (setq acadd (vlax-get-acad-object))
  4.   (setq active_doc (vla-get-ActiveDocument acadd))
  5.   (setq mspace (vla-get-ModelSpace active_doc))
  6.   (setq L300 3.1)
  7.   (setq L600 6.1)
  8.   (setq L900 9.1)
  9.   (setq L1000 11)
  10.   (setq L1200 13)
  11.   (setq xscale 1)
  12.   (setq yscale 1)
  13.   (setq zscale 1)
  14.   (setq rot (/ (getint "Введите угол поворота светильников на карнизах: 0; 180 ") (/ 180 pi)))
  15.   (setq rot1 (/ (getint "Введите угол поворота светильников в дверных проемах: 0; 180 ") (/ 180 pi)))
  16.   (setq nabor (ssget "_X" (list (cons 8 "_АХП_Вспомогательный_слой_не_печать" ) (cons 0 "insert"))))
  17.       (if nabor
  18.                  (progn
  19.                  (princ (strcat "Найдено блоков:" (rtos (sslength nabor) 2 0) "шт."))
  20.                  (terpri)
  21.                    (initget 1 "Да Нет")
  22.                     (setq cond_bl (getkword "Использовать выбранный блок для всего чертежа? [Да/Нет]: "))
  23.                         (if (wcmatch cond_bl "Да") (progn
  24.                                                     (setq name (getstring T "Введите имя блока светильника (см. палитру): "))
  25.                                                     (setq counter 0)
  26.       (while (< counter (sslength nabor))
  27.         (setq _block  (vlax-ename->vla-object (ssname nabor counter)))
  28.                      (setq chlenbl
  29.                          (cond
  30.                     ((wcmatch name "L (300 mm)") (setq _lenbl L300))
  31.                     ((wcmatch name "L (600 mm)") (setq _lenbl L600))
  32.                     ((wcmatch name "L (900 mm)") (setq _lenbl L900))
  33.                     ((wcmatch name "L (1000 mm)") (setq _lenbl L1000))
  34.                     ((wcmatch name "L (1200 mm)") (setq _lenbl L1200))))
  35.                   (setq point (cdr (assoc 10 (entget (ssname nabor counter)))))
  36.                   (setq x_coord (nth 0 point))
  37.                   (setq y_coord (nth 1 point))
  38.                   (setq z_coord (nth 2 point))
  39.                   (setq _eff_name (vla-get-effectivename _block))
  40.                   (princ _eff_name)
  41.                   (terpri)
  42.         (if
  43.           (wcmatch _eff_name "!Карниз")
  44.           (progn
  45.                   (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  46.           (nth 0 drop)
  47.             (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  48.             (setq quantity (fix (/ _len1 _lenbl)))
  49.             (setq counter1 0)
  50.             (while (< counter1 quantity)
  51.               (setq x_coord` (+ x_coord (/ (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)) 2) (* 1 counter1 (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)))))
  52.                                       (setq poinsert (vlax-3d-point x_coord` y_coord z_coord))
  53.              (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot)
  54.                                (setq counter1 (+ 1 counter1)))(princ "ok !Карниз")(terpri))
  55.                              
  56.                   (progn (setq _cond (getint "\n Выберите вариант: 1 - Один блок; 2 - Заполнить проем"))
  57.           (if (= _cond 1) (progn
  58.            (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  59.            (nth 0 drop)
  60.            (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  61.                         (setq x_half (+ x_coord (/ _len1 2)))
  62.                          (setq poinsert (vlax-3d-point  x_half y_coord z_coord))
  63.                 (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot1)
  64.            (princ "ok !Дверной проем")(terpri))
  65.            (progn
  66.              (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  67.            (nth 0 drop)
  68.              (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  69.             (setq quantity (fix (/ _len1 _lenbl)))
  70.             (setq counter1 0)
  71.             (while (< counter1 quantity)
  72.               (setq x_coord` (+ x_coord (/ (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)) 2) (* 1 counter1 (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)))))
  73.                 (setq poinsert (vlax-3d-point x_coord` y_coord z_coord))
  74.              (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot1)
  75.                                (setq counter1 (+ 1 counter1))(princ "ok !Дверной проем")(terpri))
  76.             )        
  77.      )))
  78.     (terpri)(princ counter)
  79.                   (setq counter (+ 1 counter))(terpri)(princ "Расстановка выполнена"))
  80.                                                     )
  81.                                                   (progn
  82.                             (setq counter 0)
  83.       (while (< counter (sslength nabor))
  84.         (setq _block  (vlax-ename->vla-object (ssname nabor counter)))
  85.         (vla-highlight _block :vlax-true)
  86.                              (setq name (getstring T "Введите имя блока светильника (см. палитру): "))
  87.                      (setq chlenbl
  88.                          (cond
  89.                     ((wcmatch name "L (300 mm)") (setq _lenbl L300))
  90.                     ((wcmatch name "L (600 mm)") (setq _lenbl L600))
  91.                     ((wcmatch name "L (900 mm)") (setq _lenbl L900))
  92.                     ((wcmatch name "L (1000 mm)") (setq _lenbl L1000))
  93.                     ((wcmatch name "L (1200 mm)") (setq _lenbl L1200))))
  94.                   (setq point (cdr (assoc 10 (entget (ssname nabor counter)))))
  95.                   (setq x_coord (nth 0 point))
  96.                   (setq y_coord (nth 1 point))
  97.                   (setq z_coord (nth 2 point))
  98.                   (setq _eff_name (vla-get-effectivename _block))
  99.                   (princ _eff_name)
  100.                   (terpri)
  101.         (if
  102.           (wcmatch _eff_name "!Карниз")
  103.           (progn
  104.                   (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  105.           (nth 0 drop)
  106.             (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  107.             (setq quantity (fix (/ _len1 _lenbl)))
  108.             (setq counter1 0)
  109.             (while (< counter1 quantity)
  110.               (setq x_coord` (+ x_coord (/ (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)) 2) (* 1 counter1 (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)))))
  111.                                       (setq poinsert (vlax-3d-point x_coord` y_coord z_coord))
  112.              (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot)
  113.                                (setq counter1 (+ 1 counter1)))(princ "ok !Карниз")(terpri))
  114.                              
  115.                   (progn (setq _cond (getint "\n Выберите вариант: 1 - Один блок; 2 - Заполнить проем"))
  116.           (if (= _cond 1) (progn
  117.            (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  118.            (nth 0 drop)
  119.            (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  120.                         (setq x_half (+ x_coord (/ _len1 2)))
  121.                          (setq poinsert (vlax-3d-point  x_half y_coord z_coord))
  122.                 (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot1)
  123.            (princ "ok !Дверной проем")(terpri))
  124.            (progn
  125.              (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  126.            (nth 0 drop)
  127.              (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  128.             (setq quantity (fix (/ _len1 _lenbl)))
  129.             (setq counter1 0)
  130.             (while (< counter1 quantity)
  131.               (setq x_coord` (+ x_coord (/ (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)) 2) (* 1 counter1 (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)))))
  132.                 (setq poinsert (vlax-3d-point x_coord` y_coord z_coord))
  133.              (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot1)
  134.                                (setq counter1 (+ 1 counter1))(princ "ok !Дверной проем")(terpri))
  135.             )
  136.                      
  137.      )))
  138.     (princ counter)
  139.           (vla-highlight _block :vlax-false)
  140.           (setq counter (+ 1 counter))(terpri)(princ "Расстановка выполнена"))
  141.                  )))
  142.                    (progn
  143.                      (alert (princ "\nНет блоков, расположите блоки на фасаде здания"))
  144. (terpri))
  145.         )
  146.   (princ))
Традиционно прикладываю файл с описанием блоков для прогонки макроса тем, кому интересно

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
"Я опять насчет стрельца"...
Дураказащиты опять нет. ИМХО многовато переменных (и не все они локализованы). Откуда я буду знать имя блока (который "см.палитру")? Может, проще будет выполнить "проход" по допустимым именам блоков и предлагать их через getkword (например)?
Если честно, я бы подумал о создании dcl-диалога и прописывании в нем всех необходимых параметров - это было бы удобнее пользователям. Да и в некоторых случаях с диалогом проще работать.
Сугубо ИМХО: если добавить дураказащиту, код удлинится. Если просто убрать лишние шаги - укоротится. Что делать будем? :)
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Добавлю: я бы все-таки запросы внутри цикла, наверное, убрал.
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
Может, проще будет выполнить "проход" по допустимым именам блоков и предлагать их через getkword (например)?
Не поверишь, сегодня с утра бегал, именно об этом пришла мысль в голову! Конечно буду делать так, чтобы пользователь ничего лапками не вводил, и соглашусь с тем, что пора расти до меню, построенном на dcl-диалоге

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
Последняя версия! осталось добавить лишь защиту от дурака, но за этим дело не станет! Однако при выполнении появляется ошибка,приложена на рисунке, возникает после того, как первый раз в цикле устанавливается "пауза", затем, как ни странно, после того как я два раза нажимаю "Enter" ошибка уходит. Прикладываю файл, скриншот и код.
Код - Auto/Visual Lisp [Выбрать]
  1. ;;; Макрос заполняет блоками определенное пространство модели, работет интерактивно с пользователем, будет полезно инженерам-светотехникам
  2. (vl-load-com)
  3. ;(command "_.-insert" "\\\\192.168.1.201\\projects\\!ШАБЛОНЫ\\Сетевые настройки Autocad\\Блоки_только_светильники.dwg" "1" "1" "1" "0")
  4. (defun c:sv_lamps (/ nabor _len1 _eff_name _block _conduit quantity point counter poinsert _cond _lenbl x_half x_half y_coord z_coord x_coord` chname chlenbl )
  5.   (setq acadd (vlax-get-acad-object))
  6.   (setq active_doc (vla-get-ActiveDocument acadd))
  7.   (setq mspace (vla-get-ModelSpace active_doc))
  8.   (setq L300 3.1)
  9.   (setq L600 6.1)
  10.   (setq L900 9.1)
  11.   (setq L1000 11)
  12.   (setq L1200 13)
  13.   (setq xscale 1)
  14.   (setq yscale 1)
  15.   (setq zscale 1)
  16.     (setq nabor (ssget "_X" (list (cons 8 "_АХП_Вспомогательный_слой_не_печать" ) (cons 0 "insert"))))
  17.       (if nabor
  18.                  (progn
  19.                    (setq rot (/ (getint "Введите угол поворота светильников на карнизах: 0; 180 ") (/ 180 pi)))
  20.   (setq rot1 (/ (getint "Введите угол поворота светильников в дверных проемах: 0; 180 ") (/ 180 pi)))
  21.                  (princ (strcat "Найдено блоков:" (rtos (sslength nabor) 2 0) "шт."))
  22.                  (terpri)
  23.                    (initget 1 "Да Нет")
  24.                     (setq cond_bl (getkword "Использовать выбранный блок для всего чертежа? [Да/Нет]: "))
  25.                         (if (wcmatch cond_bl "Да") (progn
  26.                                                      (initget 1 "L(300mm) L(550mm) L(600mm) L(900mm) L(1000mm) L(1200mm)")
  27.                                                     (setq name (getkword "Введите имя блока светильника [L(300mm)/L(550mm)/L(600mm)/L(900mm)/L(1000mm)/L(1200mm)]: "))
  28.                                                     (setq counter 0)
  29.       (while (< counter (sslength nabor))
  30.         (setq _block  (vlax-ename->vla-object (ssname nabor counter)))
  31.                      (setq chlenbl
  32.                          (cond
  33.                     ((wcmatch name "L(300mm)") (setq _lenbl L300))
  34.                     ((wcmatch name "L(600mm)") (setq _lenbl L600))
  35.                     ((wcmatch name "L(900mm)") (setq _lenbl L900))
  36.                     ((wcmatch name "L(1000mm)") (setq _lenbl L1000))
  37.                     ((wcmatch name "L(1200mm)") (setq _lenbl L1200))))
  38.                   (setq point (cdr (assoc 10 (entget (ssname nabor counter)))))
  39.                   (setq x_coord (nth 0 point))
  40.                   (setq y_coord (nth 1 point))
  41.                   (setq z_coord (nth 2 point))
  42.                   (setq _eff_name (vla-get-effectivename _block))
  43.                   (princ _eff_name)
  44.                   (terpri)
  45.         (if
  46.           (wcmatch _eff_name "!Карниз")
  47.           (progn
  48.                   (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  49.           (nth 0 drop)
  50.             (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  51.             (setq quantity (fix (/ _len1 _lenbl)))
  52.             (setq counter1 0)
  53.             (setq ss1 (ssadd))
  54.             (while (< counter1 quantity)
  55.               (setq x_coord` (+ x_coord (/ (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)) 2) (* 1 counter1 (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)))))
  56.                                       (setq poinsert (vlax-3d-point x_coord` y_coord z_coord))
  57.              (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot)
  58.               (ssadd (entlast) ss1)
  59.                                                                (setq counter1 (+ 1 counter1))) (princ "ok !Карниз")(terpri)
  60.                  
  61.             )
  62.                                                           (progn (setq _cond (getint "\n Выберите вариант: 1 - Один блок; 2 - Заполнить проем"))
  63.           (if (= _cond 1) (progn
  64.                             (setq ss1 (ssadd))
  65.            (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  66.            (nth 0 drop)
  67.                       (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  68.                         (setq x_half (+ x_coord (/ _len1 2)))
  69.                          (setq poinsert (vlax-3d-point  x_half y_coord z_coord))
  70.                 (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot1)
  71.                             (ssadd (entlast) ss1)
  72.            (princ "ok !Дверной проем")(terpri))
  73.            (progn
  74.              (setq ss1 (ssadd))
  75.              (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  76.            (nth 0 drop)
  77.              (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  78.             (setq quantity (fix (/ _len1 _lenbl)))
  79.             (setq counter1 0)
  80.             (while (< counter1 quantity)
  81.               (setq x_coord` (+ x_coord (/ (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)) 2) (* 1 counter1 (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)))))
  82.                 (setq poinsert (vlax-3d-point x_coord` y_coord z_coord))
  83.              (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot1)
  84.               (ssadd (entlast) ss1)
  85.                                                (setq counter1 (+ 1 counter1))(princ "ok !Дверной проем")(terpri))
  86.             )        
  87.      )))
  88.     (terpri)(princ counter)
  89.  
  90. (terpri)(princ (strcat "Добавлено блоков:" (rtos (sslength ss1) 2 0) "шт."))
  91.           (sssetfirst nil ss1)
  92.             (command pause)
  93.        
  94.                   (setq counter (+ 1 counter))
  95.         (sssetfirst nil nil)
  96.        
  97.         )
  98. (terpri)(princ "Расстановка выполнена")
  99.          
  100.         )
  101.                                  
  102.                                                   (progn
  103.                             (setq counter 0)
  104.       (while (< counter (sslength nabor))
  105.         (setq _block  (vlax-ename->vla-object (ssname nabor counter)))
  106.         (vla-highlight _block :vlax-true)
  107.         (initget 1 "L(300mm) L(550mm) L(600mm) L(900mm) L(1000mm) L(1200mm)")
  108.                                                     (setq name (getkword "Введите имя блока светильника [L(300mm)/L(550mm)/L(600mm)/L(900mm)/L(1000mm)/L(1200mm)]: "))
  109.                            
  110.                      (setq chlenbl
  111.                          (cond
  112.                     ((wcmatch name "L(300mm)") (setq _lenbl L300))
  113.                     ((wcmatch name "L(600mm)") (setq _lenbl L600))
  114.                     ((wcmatch name "L(900mm)") (setq _lenbl L900))
  115.                     ((wcmatch name "L(1000mm)") (setq _lenbl L1000))
  116.                     ((wcmatch name "L(1200mm)") (setq _lenbl L1200))))
  117.                   (setq point (cdr (assoc 10 (entget (ssname nabor counter)))))
  118.                   (setq x_coord (nth 0 point))
  119.                   (setq y_coord (nth 1 point))
  120.                   (setq z_coord (nth 2 point))
  121.                   (setq _eff_name (vla-get-effectivename _block))
  122.                   (princ _eff_name)
  123.                   (terpri)
  124.         (if
  125.           (wcmatch _eff_name "!Карниз")
  126.           (progn
  127.                   (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  128.           (nth 0 drop)
  129.             (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  130.             (setq quantity (fix (/ _len1 _lenbl)))
  131.             (setq counter1 0)
  132.             (setq ss1 (ssadd))
  133.             (while (< counter1 quantity)
  134.               (setq x_coord` (+ x_coord (/ (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)) 2) (* 1 counter1 (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)))))
  135.                                       (setq poinsert (vlax-3d-point x_coord` y_coord z_coord))
  136.              (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot)
  137.              (ssadd (entlast) ss1)
  138.                                        (setq counter1 (+ 1 counter1)))(princ "ok !Карниз")(terpri))
  139.                              
  140.                   (progn (setq _cond (getint "\n Выберите вариант: 1 - Один блок; 2 - Заполнить проем"))
  141.           (if (= _cond 1) (progn
  142.                             (setq ss1 (ssadd))
  143.            (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  144.            (nth 0 drop)
  145.            (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  146.                         (setq x_half (+ x_coord (/ _len1 2)))
  147.                          (setq poinsert (vlax-3d-point  x_half y_coord z_coord))
  148.                 (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot1)
  149.                             (ssadd (entlast) ss1)
  150.            (princ "ok !Дверной проем")(terpri))
  151.            (progn
  152.              (setq ss1 (ssadd))
  153.              (setq drop (vlax-invoke _block 'getdynamicblockproperties ))
  154.            (nth 0 drop)
  155.              (setq _len1 (vlax-variant-value  (vla-get-value (nth 0 drop) )))
  156.             (setq quantity (fix (/ _len1 _lenbl)))
  157.             (setq counter1 0)
  158.             (while (< counter1 quantity)
  159.               (setq x_coord` (+ x_coord (/ (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)) 2) (* 1 counter1 (+ _lenbl (/ (- _len1 (* quantity _lenbl)) quantity)))))
  160.                 (setq poinsert (vlax-3d-point x_coord` y_coord z_coord))
  161.              (vla-InsertBlock mspace poinsert  name xscale yscale zscale rot1)
  162.               (ssadd (entlast) ss1)
  163.                                (setq counter1 (+ 1 counter1))(princ "ok !Дверной проем")(terpri))
  164.             )
  165.                      
  166.      )))
  167.     (princ counter)
  168.           (vla-highlight _block :vlax-false)
  169. (terpri)(princ (strcat "Добавлено блоков:" (rtos (sslength ss1) 2 0) "шт."))
  170.           (sssetfirst nil ss1)
  171.             (command pause)
  172.        
  173.           (setq counter (+ 1 counter))
  174.         (sssetfirst nil nil)
  175.         (terpri)(princ "Расстановка выполнена"))
  176.  
  177.                             )))
  178.                    (progn
  179.                      (alert (princ "\nНет блоков, расположите блоки на фасаде здания"))
  180. (terpri))
  181.         )
  182.   (princ))
  183.  

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
1. getint - человек жмет ESC. Ошибка?
2. Я не уверен, что строка (initget 1 "L(300mm) L(550mm) L(600mm) L(900mm) L(1000mm) L(1200mm)") будет работать абсолютно корректно. Это одна из причин, по которой я рекомендовал разрабатывать dcl
3. Результаты vla-insertblock объединяй в список - я почти уверен, что это решит проблему последующей обработки вставленных блоков


Это навскидку...
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
Лёша, ответь, что за ошибка, замечание 3 не совсем понял?

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Я предпочитаю подобные запросы оборачивать в vl-catch-* функции и потом анализировать результат
По п.3: вместо обычного vla-insertblock используй нечто типа
(setq res (cons (vla-insertblock <...>) res)
В конце в res у тебя будет список vla-указателей на вставленные блоки. А уж что с ним делать - зависит от задачи.
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Попробуй такое погонять (масса вещей у меня надергана из библиотеки, так что имена функций соответствующие; вдобавок от некоторых из них можно избавиться)
Код - Auto/Visual Lisp [Выбрать]
  1. (vl-load-com)
  2.  
  3. (defun c:light-point (/                     _kpblc-conv-vla-to-list                     _kpblc-get-ent-name
  4.                _kpblc-property-get   _kpblc-conv-ent-to-vla                      _kpblc-conv-ent-to-ename
  5.                _kpblc-list-add-or-subst                    loc:dcl-create        loc:dcl-callback
  6.                loc:dcl-execute       selset                adoc                  dist
  7.                dynprop               res                   step                  name
  8.                )
  9.  
  10.   (defun _kpblc-conv-vla-to-list (value / res)
  11.                                  ;|
  12. *    Преобразовывает vlax-variant или vlax-safearray в список.
  13. |;
  14.     (cond
  15.       ((listp value)
  16.        (mapcar (function _kpblc-conv-vla-to-list) value)
  17.        )
  18.       ((= (type value) 'variant)
  19.        (_kpblc-conv-vla-to-list (vlax-variant-value value))
  20.        )
  21.       ((= (type value) 'safearray)
  22.        (if (>= (vlax-safearray-get-u-bound value 1) 0)
  23.          (_kpblc-conv-vla-to-list (vlax-safearray->list value))
  24.          ) ;_ end of if
  25.        )
  26.       ((and (member (type value) (list 'ename 'str 'vla-object))
  27.             (= (type (_kpblc-conv-ent-to-vla value)) 'vla-object)
  28.             (vlax-property-available-p (_kpblc-conv-ent-to-vla value) 'count)
  29.             ) ;_ end of and
  30.        (vlax-for sub (_kpblc-conv-ent-to-vla value)
  31.          (setq res (cons sub res))
  32.          ) ;_ end of vlax-for
  33.        )
  34.       (t value)
  35.       ) ;_ end of cond
  36.     ) ;_ end of defun
  37.  
  38.   (defun _kpblc-get-ent-name (ent /)
  39.                              ;|
  40. *    Получение свойства name указанного примитива
  41. *    Параметры вызова:
  42.   ent  указатель на обрабатываемый примитив
  43.     допускаются значения
  44.     ename
  45.     vla-object
  46.     string (хендл объекта текущего файла)
  47. |;
  48.     (cond ((= (type ent) 'str) ent)
  49.           ((_kpblc-property-get ent 'effectivename))
  50.           ((_kpblc-property-get ent 'name))
  51.           ) ;_ end of cond
  52.     ) ;_ end of defun
  53.  
  54.   (defun _kpblc-property-get (obj property / res)
  55.                              ;|
  56. *    Получение значения свойства объекта
  57. |;
  58.     (vl-catch-all-apply
  59.       (function
  60.         (lambda ()
  61.           (if (and obj
  62.                    (vlax-property-available-p
  63.                      (setq obj (_kpblc-conv-ent-to-vla obj))
  64.                      property
  65.                      ) ;_ end of vlax-property-available-p
  66.                    ) ;_ end of and
  67.             (setq res (vlax-get-property obj property))
  68.             ) ;_ end of if
  69.           ) ;_ end of lambda
  70.         ) ;_ end of function
  71.       ) ;_ end of vl-catch-all-apply
  72.     res
  73.     ) ;_ end of defun
  74.  
  75.   (defun _kpblc-conv-ent-to-vla (ent_value / res)
  76.                                 ;|
  77. *    Функция преобразования полученного значения в vla-указатель.
  78. *    Параметры вызова:
  79. *  ent_value  значение, которое надо преобразовать в указатель. Может
  80. *      быть именем примитива, vla-указателем или просто
  81. *      списком.
  82. *      Если не принадлежит ни одному из указанных типов,
  83. *      возвращается nil
  84. *    Примеры вызова:
  85. (_kpblc-conv-ent-to-vla (entlast))
  86. (_kpblc-conv-ent-to-vla (vlax-ename->vla-object (entlast)))
  87. |;
  88.     (cond
  89.       ((= (type ent_value) 'vla-object) ent_value)
  90.       ((= (type ent_value) 'ename) (vlax-ename->vla-object ent_value))
  91.       ((setq res (_kpblc-conv-ent-to-ename ent_value))
  92.        (vlax-ename->vla-object res)
  93.        )
  94.       ) ;_ end of cond
  95.     ) ;_ end of defun
  96.  
  97.   (defun _kpblc-conv-ent-to-ename (ent_value / _lst)
  98.                                   ;|
  99. *    Функция преобразования полученного значения в ename
  100. *    Параметры вызова:
  101. *  ent_value  значение, которое надо преобразовать в примитив. Может
  102. *      быть именем примитива, vla-указателем или просто
  103. *      списком.
  104. *      Если не принадлежит ни одному из указанных типов,
  105. *      возвращается nil
  106. *    Примеры вызова:
  107. (_kpblc-conv-ent-to-ename (entlast))
  108. (_kpblc-conv-ent-to-ename (vlax-ename->vla-object (entlast)))
  109. |;
  110.     (cond
  111.       ((= (type ent_value) 'vla-object)
  112.        (vlax-vla-object->ename ent_value)
  113.        )
  114.       ((= (type ent_value) 'ename) ent_value)
  115.       ((and (= (type ent_value) 'str) (handent ent_value) (entget (handent ent_value)))
  116.        (handent ent_value)
  117.        )
  118.       ((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "style" ent_value))
  119.        (tblobjname "style" ent_value)
  120.        )
  121.       ((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "dimstyle" ent_value))
  122.        (tblobjname "dimstyle" ent_value)
  123.        )
  124.       ((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "block" ent_value))
  125.        (tblobjname "block" ent_value)
  126.        )
  127.       ((and (= (type ent_value) 'list) (cdr (assoc -1 ent_value))) (cdr (assoc -1 ent_value)))
  128.       (t nil)
  129.       ) ;_ end of cond
  130.     ) ;_ end of defun
  131.  
  132.   (defun _kpblc-list-add-or-subst (lst key value)
  133.                                   ;|
  134. *    Производит замену или дополнение элемента списка новым
  135. *    Параметры вызова:
  136.   lst      обрабатываемый список
  137.   key      ключ
  138.   value    устанавливаемое значение
  139. |;
  140.     (if (not value)
  141.       (vl-remove-if (function (lambda (x) (= (car x) key))) lst)
  142.       (if (cdr (assoc key lst))
  143.         (subst (cons key value) (assoc key lst) lst)
  144.         (cons (cons key value)
  145.               (vl-remove-if
  146.                 (function
  147.                   (lambda (x)
  148.                     (= (car x) key)
  149.                     ) ;_ end of lambda
  150.                   ) ;_ end of function
  151.                 lst
  152.                 ) ;_ end of vl-remove-if
  153.               ) ;_ end of cons
  154.         ) ;_ end of if
  155.       ) ;_ end of if
  156.     ) ;_ end of defun
  157.  
  158.   (defun loc:dcl-create (/ file handle)
  159.     (setq file   (strcat (vl-string-right-trim "\\" (getenv "TEMP")) "\\dlg.dcl")
  160.           handle (open file "w")
  161.           ) ;_ end of setq
  162.     (foreach item '("dlg:dialog{label=\"ADN-CIS.ORG\";width=\"60\";"
  163.                     "   :column{label=\"Угол поворота\";"
  164.                     "           :edit_box{key=\"rot_cornice\";label=\"На карнизах\";}"
  165.                     "           :edit_box{key=\"rot_space\";label=\"В дверных проемах\";}"
  166.                     "           }"
  167.                     "   :toggle{key=\"use_block\";label=\"Использовать выбранный блок\";}"
  168.                     "   :toggle{key=\"fill\";label=\"Заполнять проем\";}"
  169.                     "   :popup_list{key=\"lst_light_block\";label=\"Имя блока светильника\";}"
  170.           ;  "  :row{children_fixed_width=true;"
  171.           ;  "          :text{key=\"txt_layer\";label=\"Имя слоя определяющего блока\";}"
  172.           ;  "          :popup_list{key=\"lst_layers\";width=\"35\";}"
  173.           ;  "          }"
  174.                     "   ok_cancel;"
  175.                     "   }"
  176.                     )
  177.       (write-line item handle)
  178.       ) ;_ end of foreach
  179.     (close handle)
  180.     file
  181.     ) ;_ end of defun
  182.  
  183.   (defun loc:dcl-callback (key value ref)
  184.     (set ref (_kpblc-list-add-or-subst (eval ref) key value))
  185.     ) ;_ end of defun
  186.  
  187.   (defun loc:dcl-execute (/ dcl_file dcl_id dcl_lst dcl_res)
  188.     (setq dcl_id (load_dialog (loc:dcl-create)))
  189.     (new_dialog "dlg" dcl_id "(loc:dcl-callback $key $value 'dcl_lst)")
  190.     (start_list "lst_layers" 3)
  191.     (mapcar
  192.       (function add_list)
  193.       (cdr
  194.         (assoc "layers"
  195.                (setq dcl_lst (_kpblc-list-add-or-subst
  196.                                dcl_lst
  197.                                "layers"
  198.                                ((lambda (/ _res)
  199.                                   (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
  200.                                     (if (not (wcmatch (vla-get-name item) "*|*"))
  201.                                       (setq _res (cons (vla-get-name item) _res))
  202.                                       ) ;_ end of if
  203.                                     ) ;_ end of vlax-for
  204.                                   (vl-sort _res '<)
  205.                                   ) ;_ end of lambda
  206.                                 )
  207.                                ) ;_ end of _kpblc-list-add-or-subst
  208.                      ) ;_ end of setq
  209.                ) ;_ end of assoc
  210.         ) ;_ end of cdr
  211.       ) ;_ end of mapcar
  212.     (end_list)
  213.     (start_list "lst_light_block" 3)
  214.     (mapcar
  215.       (function add_list)
  216.       (mapcar
  217.         (function car)
  218.         (cdr
  219.           (assoc "blocks"
  220.                  (setq dcl_lst (_kpblc-list-add-or-subst
  221.                                  dcl_lst
  222.                                  "blocks"
  223.                                  (vl-remove nil
  224.                                             (mapcar
  225.                                               (function
  226.                                                 (lambda (x / tmp)
  227.                                                   (if (tblobjname "block" (setq tmp (strcat "L(" (itoa (car x)) "mm)")))
  228.                                                     (cons tmp (cdr x))
  229.                                                     ) ;_ end of if
  230.                                                   ) ;_ end of lambda
  231.                                                 ) ;_ end of function
  232.                                               '((300 . 3.1)
  233.                                                 (600 . 6.1)
  234.                                                 (900 . 9.1)
  235.                                                 (1000 . 11.)
  236.                                                 (1200 . 13.)
  237.                                                 )
  238.                                               ) ;_ end of mapcar
  239.                                             ) ;_ end of vl-remove
  240.                                  ) ;_ end of _kpblc-list-add-or-subst
  241.                        ) ;_ end of setq
  242.                  ) ;_ end of assoc
  243.           ) ;_ end of cdr
  244.         ) ;_ end of mapcar
  245.       ) ;_ end of mapcar
  246.     (end_list)
  247.     (foreach item (list '("rot_cornice" . "0")
  248.                         '("rot_space" . "0")
  249.                         '("use_block" . "1")
  250.                         '("fill" . "1")
  251.                         '("lst_light_block" . "0")
  252.                         (cons "lst_layers"
  253.                               ((lambda (/ item)
  254.                                  (itoa (cond
  255.                                          ((setq item (car (vl-remove-if-not
  256.                                                             (function
  257.                                                               (lambda (x)
  258.                                                                 (= (strcase x) "_АХП_ВСПОМОГАТЕЛЬНЫЙ_СЛОЙ_НЕ_ПЕЧАТЬ")
  259.                                                                 ) ;_ end of lambda
  260.                                                               ) ;_ end of function
  261.                                                             (cdr (assoc "layers" dcl_lst))
  262.                                                             ) ;_ end of vl-remove-if-not
  263.                                                           ) ;_ end of car
  264.                                                 ) ;_ end of setq
  265.                                           (- (length (cdr (assoc "layers" dcl_lst)))
  266.                                              (length (member item (cdr (assoc "layers" dcl_lst))))
  267.                                              ) ;_ end of -
  268.                                           )
  269.                                          (t 0)
  270.                                          ) ;_ end of cond
  271.                                        ) ;_ end of itoa
  272.                                  ) ;_ end of lambda
  273.                                )
  274.                               ) ;_ end of cons
  275.                         ) ;_ end of list
  276.       (set_tile (car item) (cdr item))
  277.       (loc:dcl-callback (car item) (cdr item) 'dcl_lst)
  278.       ) ;_ end of foreach
  279.  
  280.     (action_tile "accept" "(done_dialog 1)")
  281.     (action_tile "cancel" "(done_dialog 0)")
  282.     (setq dcl_res (start_dialog))
  283.     (unload_dialog dcl_id)
  284.     (if (= dcl_res 1)
  285.       dcl_lst
  286.       ) ;_ end of if
  287.     ) ;_ end of defun
  288.  
  289.   (if (and (setq lst (loc:dcl-execute))
  290.            (setq selset (ssget "_X"
  291.                                (list '(0 . "INSERT")
  292.                                      (cons 8 (nth (atoi (cdr (assoc "lst_layers" lst))) (cdr (assoc "layers" lst))))
  293.                                      ) ;_ end of list
  294.                                ) ;_ end of ssget
  295.                  ) ;_ end of setq
  296.            (setq selset ((lambda (/ tab item)
  297.                            (repeat (setq tab  nil
  298.                                          item (sslength selset)
  299.                                          ) ;_ end setq
  300.                              (setq tab (cons (ssname selset (setq item (1- item))) tab))
  301.                              ) ;_ end of repeat
  302.                            ) ;_ end of lambda
  303.                          )
  304.                  ) ;_ end of setq
  305.            ) ;_ end of and
  306.     (progn
  307.       (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  308.       (foreach blk selset
  309.         (setq dynprop (vlax-variant-value
  310.                         (_kpblc-property-get
  311.                           (car (vl-remove-if-not
  312.                                  (function
  313.                                    (lambda (x)
  314.                                      (= (strcase (_kpblc-property-get x 'propertyname))
  315.                                         "РАССТОЯНИЕ1"
  316.                                         ) ;_ end of =
  317.                                      ) ;_ end of lambda
  318.                                    ) ;_ end of function
  319.                                  (_kpblc-conv-vla-to-list (vla-getdynamicblockproperties (vlax-ename->vla-object blk)))
  320.                                  ) ;_ end of vl-remove-if-not
  321.                                ) ;_ end of car
  322.                           'value
  323.                           ) ;_ end of _kpblc-property-get
  324.                         ) ;_ end of vlax-variant-value
  325.               name    (nth (atoi (cdr (assoc "lst_light_block" lst)))
  326.                            (cdr (assoc "blocks" lst))
  327.                            ) ;_ end of nth
  328.               step    (if (or (= (cdr (assoc "fill" lst)) "1")
  329.                               (wcmatch (strcase (_kpblc-get-ent-name blk)) "!КАРНИЗ")
  330.                               ) ;_ end of or
  331.                         (cdr name)
  332.                         (/ dynprop 2.)
  333.                         ) ;_ end of if
  334.               name    (car name)
  335.               dist    (if (or (= (cdr (assoc "fill" lst)) "1")
  336.                               (wcmatch (strcase (_kpblc-get-ent-name blk)) "!КАРНИЗ")
  337.                               ) ;_ end of or
  338.                         (/ (+ (- dynprop (* step (fix (/ dynprop step)))) step) 2.)
  339.                         (/ dynprop 2.)
  340.                         ) ;_ end of if
  341.               ) ;_ end of setq
  342.         (while (< dist dynprop)
  343.           (setq res  (cons (vla-insertblock
  344.                              (vla-get-modelspace adoc)
  345.                              (vlax-3d-point (polar (cdr (assoc 10 (entget blk)))
  346.                                                    (cdr (assoc 50 (entget blk)))
  347.                                                    dist
  348.                                                    ) ;_ end of polar
  349.                                             ) ;_ end of vlax-3d-point
  350.                              name
  351.                              1.
  352.                              1.
  353.                              1.
  354.                              (cdr (assoc 50 (entget blk)))
  355.                              ) ;_ end of vla-InsertBlock
  356.                            res
  357.                            ) ;_ end of cons
  358.                 dist (+ dist step)
  359.                 ) ;_ end of setq
  360.           ) ;_ end of while
  361.         ) ;_ end of foreach
  362.       (princ (strcat "\nДобавлено блоков " name " : " (rtos (length res) 2 0) " шт."))
  363.       (vla-endundomark adoc)
  364.       ) ;_ end of progn
  365.     ) ;_ end of if
  366.   (princ)
  367.   ) ;_ end of defun

Уже опубликовав, увидел, что оставил следы идеи "выбирать с учетом слоя". Если это дело убрать совсем, то код становится немного проще и короче:
Код - Auto/Visual Lisp [Выбрать]
  1. (vl-load-com)
  2.  
  3. (defun c:light-point (/                     _kpblc-conv-vla-to-list                     _kpblc-get-ent-name
  4.                       _kpblc-property-get   _kpblc-conv-ent-to-vla                      _kpblc-conv-ent-to-ename
  5.                       _kpblc-list-add-or-subst                    loc:dcl-create        loc:dcl-callback
  6.                       loc:dcl-execute       selset                adoc                  dist
  7.                       dynprop               res                   step                  name
  8.                       )
  9.  
  10.   (defun _kpblc-conv-vla-to-list (value / res)
  11.                                  ;|
  12. *    Преобразовывает vlax-variant или vlax-safearray в список.
  13. |;
  14.     (cond
  15.       ((listp value)
  16.        (mapcar (function _kpblc-conv-vla-to-list) value)
  17.        )
  18.       ((= (type value) 'variant)
  19.        (_kpblc-conv-vla-to-list (vlax-variant-value value))
  20.        )
  21.       ((= (type value) 'safearray)
  22.        (if (>= (vlax-safearray-get-u-bound value 1) 0)
  23.          (_kpblc-conv-vla-to-list (vlax-safearray->list value))
  24.          ) ;_ end of if
  25.        )
  26.       ((and (member (type value) (list 'ename 'str 'vla-object))
  27.             (= (type (_kpblc-conv-ent-to-vla value)) 'vla-object)
  28.             (vlax-property-available-p (_kpblc-conv-ent-to-vla value) 'count)
  29.             ) ;_ end of and
  30.        (vlax-for sub (_kpblc-conv-ent-to-vla value)
  31.          (setq res (cons sub res))
  32.          ) ;_ end of vlax-for
  33.        )
  34.       (t value)
  35.       ) ;_ end of cond
  36.     ) ;_ end of defun
  37.  
  38.   (defun _kpblc-get-ent-name (ent /)
  39.                              ;|
  40. *    Получение свойства name указанного примитива
  41. *    Параметры вызова:
  42.   ent  указатель на обрабатываемый примитив
  43.     допускаются значения
  44.     ename
  45.     vla-object
  46.     string (хендл объекта текущего файла)
  47. |;
  48.     (cond ((= (type ent) 'str) ent)
  49.           ((_kpblc-property-get ent 'effectivename))
  50.           ((_kpblc-property-get ent 'name))
  51.           ) ;_ end of cond
  52.     ) ;_ end of defun
  53.  
  54.   (defun _kpblc-property-get (obj property / res)
  55.                              ;|
  56. *    Получение значения свойства объекта
  57. |;
  58.     (vl-catch-all-apply
  59.       (function
  60.         (lambda ()
  61.           (if (and obj
  62.                    (vlax-property-available-p
  63.                      (setq obj (_kpblc-conv-ent-to-vla obj))
  64.                      property
  65.                      ) ;_ end of vlax-property-available-p
  66.                    ) ;_ end of and
  67.             (setq res (vlax-get-property obj property))
  68.             ) ;_ end of if
  69.           ) ;_ end of lambda
  70.         ) ;_ end of function
  71.       ) ;_ end of vl-catch-all-apply
  72.     res
  73.     ) ;_ end of defun
  74.  
  75.   (defun _kpblc-conv-ent-to-vla (ent_value / res)
  76.                                 ;|
  77. *    Функция преобразования полученного значения в vla-указатель.
  78. *    Параметры вызова:
  79. *  ent_value  значение, которое надо преобразовать в указатель. Может
  80. *      быть именем примитива, vla-указателем или просто
  81. *      списком.
  82. *      Если не принадлежит ни одному из указанных типов,
  83. *      возвращается nil
  84. *    Примеры вызова:
  85. (_kpblc-conv-ent-to-vla (entlast))
  86. (_kpblc-conv-ent-to-vla (vlax-ename->vla-object (entlast)))
  87. |;
  88.     (cond
  89.       ((= (type ent_value) 'vla-object) ent_value)
  90.       ((= (type ent_value) 'ename) (vlax-ename->vla-object ent_value))
  91.       ((setq res (_kpblc-conv-ent-to-ename ent_value))
  92.        (vlax-ename->vla-object res)
  93.        )
  94.       ) ;_ end of cond
  95.     ) ;_ end of defun
  96.  
  97.   (defun _kpblc-conv-ent-to-ename (ent_value / _lst)
  98.                                   ;|
  99. *    Функция преобразования полученного значения в ename
  100. *    Параметры вызова:
  101. *  ent_value  значение, которое надо преобразовать в примитив. Может
  102. *      быть именем примитива, vla-указателем или просто
  103. *      списком.
  104. *      Если не принадлежит ни одному из указанных типов,
  105. *      возвращается nil
  106. *    Примеры вызова:
  107. (_kpblc-conv-ent-to-ename (entlast))
  108. (_kpblc-conv-ent-to-ename (vlax-ename->vla-object (entlast)))
  109. |;
  110.     (cond
  111.       ((= (type ent_value) 'vla-object)
  112.        (vlax-vla-object->ename ent_value)
  113.        )
  114.       ((= (type ent_value) 'ename) ent_value)
  115.       ((and (= (type ent_value) 'str) (handent ent_value) (entget (handent ent_value)))
  116.        (handent ent_value)
  117.        )
  118.       ((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "style" ent_value))
  119.        (tblobjname "style" ent_value)
  120.        )
  121.       ((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "dimstyle" ent_value))
  122.        (tblobjname "dimstyle" ent_value)
  123.        )
  124.       ((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "block" ent_value))
  125.        (tblobjname "block" ent_value)
  126.        )
  127.       ((and (= (type ent_value) 'list) (cdr (assoc -1 ent_value))) (cdr (assoc -1 ent_value)))
  128.       (t nil)
  129.       ) ;_ end of cond
  130.     ) ;_ end of defun
  131.  
  132.   (defun _kpblc-list-add-or-subst (lst key value)
  133.                                   ;|
  134. *    Производит замену или дополнение элемента списка новым
  135. *    Параметры вызова:
  136.   lst      обрабатываемый список
  137.   key      ключ
  138.   value    устанавливаемое значение
  139. |;
  140.     (if (not value)
  141.       (vl-remove-if (function (lambda (x) (= (car x) key))) lst)
  142.       (if (cdr (assoc key lst))
  143.         (subst (cons key value) (assoc key lst) lst)
  144.         (cons (cons key value)
  145.               (vl-remove-if
  146.                 (function
  147.                   (lambda (x)
  148.                     (= (car x) key)
  149.                     ) ;_ end of lambda
  150.                   ) ;_ end of function
  151.                 lst
  152.                 ) ;_ end of vl-remove-if
  153.               ) ;_ end of cons
  154.         ) ;_ end of if
  155.       ) ;_ end of if
  156.     ) ;_ end of defun
  157.  
  158.   (defun loc:dcl-create (/ file handle)
  159.     (setq file   (strcat (vl-string-right-trim "\\" (getenv "TEMP")) "\\dlg.dcl")
  160.           handle (open file "w")
  161.           ) ;_ end of setq
  162.     (foreach item '("dlg:dialog{label=\"ADN-CIS.ORG\";width=\"60\";"
  163.                     "   :column{label=\"Угол поворота\";"
  164.                     "           :edit_box{key=\"rot_cornice\";label=\"На карнизах\";}"
  165.                     "           :edit_box{key=\"rot_space\";label=\"В дверных проемах\";}"
  166.                     "           }"
  167.                     "   :toggle{key=\"use_block\";label=\"Использовать выбранный блок\";}"
  168.                     "   :toggle{key=\"fill\";label=\"Заполнять проем\";}"
  169.                     "   :popup_list{key=\"lst_light_block\";label=\"Имя блока светильника\";}"
  170.                     "   ok_cancel;"
  171.                     "   }"
  172.                     )
  173.       (write-line item handle)
  174.       ) ;_ end of foreach
  175.     (close handle)
  176.     file
  177.     ) ;_ end of defun
  178.  
  179.   (defun loc:dcl-callback (key value ref)
  180.     (set ref (_kpblc-list-add-or-subst (eval ref) key value))
  181.     ) ;_ end of defun
  182.  
  183.   (defun loc:dcl-execute (/ dcl_file dcl_id dcl_lst dcl_res)
  184.     (setq dcl_id (load_dialog (loc:dcl-create)))
  185.     (new_dialog "dlg" dcl_id "(loc:dcl-callback $key $value 'dcl_lst)")
  186.     (start_list "lst_light_block" 3)
  187.     (mapcar
  188.       (function add_list)
  189.       (mapcar
  190.         (function car)
  191.         (cdr
  192.           (assoc "blocks"
  193.                  (setq dcl_lst (_kpblc-list-add-or-subst
  194.                                  dcl_lst
  195.                                  "blocks"
  196.                                  (vl-remove nil
  197.                                             (mapcar
  198.                                               (function
  199.                                                 (lambda (x / tmp)
  200.                                                   (if (tblobjname "block" (setq tmp (strcat "L(" (itoa (car x)) "mm)")))
  201.                                                     (cons tmp (cdr x))
  202.                                                     ) ;_ end of if
  203.                                                   ) ;_ end of lambda
  204.                                                 ) ;_ end of function
  205.                                               '((300 . 3.1)
  206.                                                 (600 . 6.1)
  207.                                                 (900 . 9.1)
  208.                                                 (1000 . 11.)
  209.                                                 (1200 . 13.)
  210.                                                 )
  211.                                               ) ;_ end of mapcar
  212.                                             ) ;_ end of vl-remove
  213.                                  ) ;_ end of _kpblc-list-add-or-subst
  214.                        ) ;_ end of setq
  215.                  ) ;_ end of assoc
  216.           ) ;_ end of cdr
  217.         ) ;_ end of mapcar
  218.       ) ;_ end of mapcar
  219.     (end_list)
  220.     (foreach item (list '("rot_cornice" . "0") '("rot_space" . "0") '("use_block" . "1") '("fill" . "1") '("lst_light_block" . "0")) ;_ end of list
  221.  ;_ end of list
  222.       (set_tile (car item) (cdr item))
  223.       (loc:dcl-callback (car item) (cdr item) 'dcl_lst)
  224.       ) ;_ end of foreach
  225.  
  226.     (action_tile "accept" "(done_dialog 1)")
  227.     (action_tile "cancel" "(done_dialog 0)")
  228.     (setq dcl_res (start_dialog))
  229.     (unload_dialog dcl_id)
  230.     (if (= dcl_res 1)
  231.       dcl_lst
  232.       ) ;_ end of if
  233.     ) ;_ end of defun
  234.  
  235.   (if (and (setq lst (loc:dcl-execute))
  236.            (setq selset (ssget "_X" . ((0 . "INSERT") (8 . "_АХП_Вспомогательный_слой_не_печать"))))
  237.            (setq selset ((lambda (/ tab item)
  238.                            (repeat (setq tab  nil
  239.                                          item (sslength selset)
  240.                                          ) ;_ end setq
  241.                              (setq tab (cons (ssname selset (setq item (1- item))) tab))
  242.                              ) ;_ end of repeat
  243.                            ) ;_ end of lambda
  244.                          )
  245.                  ) ;_ end of setq
  246.            ) ;_ end of and
  247.     (progn
  248.       (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  249.       (foreach blk selset
  250.         (setq dynprop (vlax-variant-value
  251.                         (_kpblc-property-get
  252.                           (car (vl-remove-if-not
  253.                                  (function
  254.                                    (lambda (x)
  255.                                      (= (strcase (_kpblc-property-get x 'propertyname))
  256.                                         "РАССТОЯНИЕ1"
  257.                                         ) ;_ end of =
  258.                                      ) ;_ end of lambda
  259.                                    ) ;_ end of function
  260.                                  (_kpblc-conv-vla-to-list (vla-getdynamicblockproperties (vlax-ename->vla-object blk)))
  261.                                  ) ;_ end of vl-remove-if-not
  262.                                ) ;_ end of car
  263.                           'value
  264.                           ) ;_ end of _kpblc-property-get
  265.                         ) ;_ end of vlax-variant-value
  266.               name    (nth (atoi (cdr (assoc "lst_light_block" lst)))
  267.                            (cdr (assoc "blocks" lst))
  268.                            ) ;_ end of nth
  269.               step    (if (or (= (cdr (assoc "fill" lst)) "1")
  270.                               (wcmatch (strcase (_kpblc-get-ent-name blk)) "!КАРНИЗ")
  271.                               ) ;_ end of or
  272.                         (cdr name)
  273.                         (/ dynprop 2.)
  274.                         ) ;_ end of if
  275.               name    (car name)
  276.               dist    (if (or (= (cdr (assoc "fill" lst)) "1")
  277.                               (wcmatch (strcase (_kpblc-get-ent-name blk)) "!КАРНИЗ")
  278.                               ) ;_ end of or
  279.                         (/ (+ (- dynprop (* step (fix (/ dynprop step)))) step) 2.)
  280.                         (/ dynprop 2.)
  281.                         ) ;_ end of if
  282.               ) ;_ end of setq
  283.         (while (< dist dynprop)
  284.           (setq res  (cons (vla-insertblock
  285.                              (vla-get-modelspace adoc)
  286.                              (vlax-3d-point (polar (cdr (assoc 10 (entget blk)))
  287.                                                    (cdr (assoc 50 (entget blk)))
  288.                                                    dist
  289.                                                    ) ;_ end of polar
  290.                                             ) ;_ end of vlax-3d-point
  291.                              name
  292.                              1.
  293.                              1.
  294.                              1.
  295.                              (cdr (assoc 50 (entget blk)))
  296.                              ) ;_ end of vla-InsertBlock
  297.                            res
  298.                            ) ;_ end of cons
  299.                 dist (+ dist step)
  300.                 ) ;_ end of setq
  301.           ) ;_ end of while
  302.         ) ;_ end of foreach
  303.       (princ (strcat "\nДобавлено блоков " name " : " (rtos (length res) 2 0) " шт."))
  304.       (vla-endundomark adoc)
  305.       ) ;_ end of progn
  306.     ) ;_ end of if
  307.   (princ)
  308.   ) ;_ end of defun
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
из библиотеки
Расскажи мне о том, что такое библиотека, как ее создать
_kpblc-conv-vla-to-list
Много раз  видел твои ссылки на твои собственные программки а как ты их внедряешь в код, вероятно вопрос неадекватен, но я только учусь)

Оффлайн Peacemaker_kissАвтор темы

  • ADN OPEN
  • **
  • Сообщений: 76
  • Карма: 0
  • Воспитываю из него программиста
Да, спасибо большое, конечно

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
а как ты их внедряешь в код
Дык ета... В работе - загрузил соответствующие lsp, вот и все. Это здесь я их вставил как локальные функции, так-то они у меня глобальны.
--
P.S. Код-то работает как надо или косячит на ровном месте?
« Последнее редактирование: 13-11-2014, 11:16:44 от Алексей Кулик »
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн ARAKS

  • ADN OPEN
  • Сообщений: 4
  • Карма: 0
Подскажите, пожалуйста, что нужно сделать чтобы заработала программа light-point? Загружаю, пишет, что неизвестная команда, также при нажатие F2  выдают "Команда: 'VLIDE неверный синтаксис обращения к функции: (0 . "INSERT")"??

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
При загрузке никакие ошибки не выводились? Может быть, код скопирован был вместе с номерами строк?
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн ARAKS

  • ADN OPEN
  • Сообщений: 4
  • Карма: 0


При загрузке активного окна редактора в консоли никаких сообщений не отображается, только в автокаде появляется сообщение неверный синтаксис обращения к функции: (0 . "INSERT")

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Странная ошибка - непонятно когда нарисовалась. Попробуй так:
Код - Auto/Visual Lisp [Выбрать]
  1. (vl-load-com)
  2.  
  3. (defun c:light-point (/                     _kpblc-conv-vla-to-list                     _kpblc-get-ent-name   _kpblc-property-get   _kpblc-conv-ent-to-vla                      _kpblc-conv-ent-to-ename
  4.                       _kpblc-list-add-or-subst                    loc:dcl-create        loc:dcl-callback      loc:dcl-execute       selset                adoc                  dist
  5.                       dynprop               res                   step                  name
  6.                       )
  7.   (defun _kpblc-conv-vla-to-list (value / res) ;|
  8.     *    Преобразовывает vlax-variant или vlax-safearray в список.
  9.     |;
  10.     (cond ((listp value) (mapcar (function _kpblc-conv-vla-to-list) value))
  11.           ((= (type value) 'variant) (_kpblc-conv-vla-to-list (vlax-variant-value value)))
  12.           ((= (type value) 'safearray)
  13.            (if (>= (vlax-safearray-get-u-bound value 1) 0)
  14.              (_kpblc-conv-vla-to-list (vlax-safearray->list value))
  15.              ) ;_ end of if
  16.            )
  17.           ((and (member (type value) (list 'ename 'str 'vla-object))
  18.                 (= (type (_kpblc-conv-ent-to-vla value)) 'vla-object)
  19.                 (vlax-property-available-p (_kpblc-conv-ent-to-vla value) 'count)
  20.                 ) ;_ end of and
  21.            (vlax-for sub (_kpblc-conv-ent-to-vla value) (setq res (cons sub res))) ;_ end of vlax-for
  22.            )
  23.           (t value)
  24.           ) ;_ end of cond
  25.     ) ;_ end of defun
  26.   (defun _kpblc-get-ent-name (ent /)
  27.                              ;|
  28.     *    Получение свойства name указанного примитива
  29.     *    Параметры вызова:
  30.       ent  указатель на обрабатываемый примитив
  31.         допускаются значения
  32.         ename
  33.         vla-object
  34.         string (хендл объекта текущего файла)
  35.     |;
  36.     (cond ((= (type ent) 'str) ent)
  37.           ((_kpblc-property-get ent 'effectivename))
  38.           ((_kpblc-property-get ent 'name))
  39.           ) ;_ end of cond
  40.     ) ;_ end of defun
  41.   (defun _kpblc-property-get (obj property / res) ;|
  42.     *    Получение значения свойства объекта
  43.     |;
  44.     (vl-catch-all-apply
  45.       (function (lambda ()
  46.                   (if (and obj
  47.                            (vlax-property-available-p (setq obj (_kpblc-conv-ent-to-vla obj)) property) ;_ end of vlax-property-available-p
  48.                            ) ;_ end of and
  49.                     (setq res (vlax-get-property obj property))
  50.                     ) ;_ end of if
  51.                   ) ;_ end of lambda
  52.                 ) ;_ end of function
  53.       ) ;_ end of vl-catch-all-apply
  54.     res
  55.     ) ;_ end of defun
  56.   (defun _kpblc-conv-ent-to-vla (ent_value / res)
  57.                                 ;|
  58.     *    Функция преобразования полученного значения в vla-указатель.
  59.     *    Параметры вызова:
  60.     *  ent_value  значение, которое надо преобразовать в указатель. Может
  61.     *      быть именем примитива, vla-указателем или просто
  62.     *      списком.
  63.     *      Если не принадлежит ни одному из указанных типов,
  64.     *      возвращается nil
  65.     *    Примеры вызова:
  66.     (_kpblc-conv-ent-to-vla (entlast))
  67.     (_kpblc-conv-ent-to-vla (vlax-ename->vla-object (entlast)))
  68.     |;
  69.     (cond ((= (type ent_value) 'vla-object) ent_value)
  70.           ((= (type ent_value) 'ename) (vlax-ename->vla-object ent_value))
  71.           ((setq res (_kpblc-conv-ent-to-ename ent_value)) (vlax-ename->vla-object res))
  72.           ) ;_ end of cond
  73.     ) ;_ end of defun
  74.   (defun _kpblc-conv-ent-to-ename (ent_value / _lst)
  75.                                   ;|
  76.     *    Функция преобразования полученного значения в ename
  77.     *    Параметры вызова:
  78.     *  ent_value  значение, которое надо преобразовать в примитив. Может
  79.     *      быть именем примитива, vla-указателем или просто
  80.     *      списком.
  81.     *      Если не принадлежит ни одному из указанных типов,
  82.     *      возвращается nil
  83.     *    Примеры вызова:
  84.     (_kpblc-conv-ent-to-ename (entlast))
  85.     (_kpblc-conv-ent-to-ename (vlax-ename->vla-object (entlast)))
  86.     |;
  87.     (cond ((= (type ent_value) 'vla-object) (vlax-vla-object->ename ent_value))
  88.           ((= (type ent_value) 'ename) ent_value)
  89.           ((and (= (type ent_value) 'str) (handent ent_value) (entget (handent ent_value)))
  90.            (handent ent_value)
  91.            )
  92.           ((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "style" ent_value))
  93.            (tblobjname "style" ent_value)
  94.            )
  95.           ((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "dimstyle" ent_value))
  96.            (tblobjname "dimstyle" ent_value)
  97.            )
  98.           ((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "block" ent_value))
  99.            (tblobjname "block" ent_value)
  100.            )
  101.           ((and (= (type ent_value) 'list) (cdr (assoc -1 ent_value))) (cdr (assoc -1 ent_value)))
  102.           (t nil)
  103.           ) ;_ end of cond
  104.     ) ;_ end of defun
  105.   (defun _kpblc-list-add-or-subst (lst key value)
  106.                                   ;|
  107.     *    Производит замену или дополнение элемента списка новым
  108.     *    Параметры вызова:
  109.       lst      обрабатываемый список
  110.       key      ключ
  111.       value    устанавливаемое значение
  112.     |;
  113.     (if (not value)
  114.       (vl-remove-if (function (lambda (x) (= (car x) key))) lst)
  115.       (if (cdr (assoc key lst))
  116.         (subst (cons key value) (assoc key lst) lst)
  117.         (cons (cons key value)
  118.               (vl-remove-if
  119.                 (function (lambda (x) (= (car x) key)) ;_ end of lambda
  120.                           ) ;_ end of function
  121.                 lst
  122.                 ) ;_ end of vl-remove-if
  123.               ) ;_ end of cons
  124.         ) ;_ end of if
  125.       ) ;_ end of if
  126.     ) ;_ end of defun
  127.   (defun loc:dcl-create (/ file handle)
  128.     (setq file   (strcat (vl-string-right-trim "\\" (getenv "TEMP")) "\\dlg.dcl")
  129.           handle (open file "w")
  130.           ) ;_ end of setq
  131.     (foreach item '("dlg:dialog{label=\"ADN-CIS.ORG\";width=\"60\";"                          "   :column{label=\"Угол поворота\";"
  132.                     "           :edit_box{key=\"rot_cornice\";label=\"На карнизах\";}"        "           :edit_box{key=\"rot_space\";label=\"В дверных проемах\";}"
  133.                     "           }"                                                            "   :toggle{key=\"use_block\";label=\"Использовать выбранный блок\";}"
  134.                     "   :toggle{key=\"fill\";label=\"Заполнять проем\";}"                     "   :popup_list{key=\"lst_light_block\";label=\"Имя блока светильника\";}"
  135.                     "   ok_cancel;"                                                           "   }"
  136.                     )
  137.       (write-line item handle)
  138.       ) ;_ end of foreach
  139.     (close handle)
  140.     file
  141.     ) ;_ end of defun
  142.   (defun loc:dcl-callback (key value ref) (set ref (_kpblc-list-add-or-subst (eval ref) key value))) ;_ end of defun
  143.   (defun loc:dcl-execute (/ dcl_file dcl_id dcl_lst dcl_res)
  144.     (setq dcl_id (load_dialog (loc:dcl-create)))
  145.     (new_dialog "dlg" dcl_id "(loc:dcl-callback $key $value 'dcl_lst)")
  146.     (start_list "lst_light_block" 3)
  147.     (mapcar (function add_list)
  148.             (mapcar (function car)
  149.                     (cdr
  150.                       (assoc "blocks"
  151.                              (setq dcl_lst (_kpblc-list-add-or-subst
  152.                                              dcl_lst
  153.                                              "blocks"
  154.                                              (vl-remove nil
  155.                                                         (mapcar (function (lambda (x / tmp)
  156.                                                                             (if (tblobjname "block" (setq tmp (strcat "L(" (itoa (car x)) "mm)")))
  157.                                                                               (cons tmp (cdr x))
  158.                                                                               ) ;_ end of if
  159.                                                                             ) ;_ end of lambda
  160.                                                                           ) ;_ end of function
  161.                                                                 '((300 . 3.1) (600 . 6.1) (900 . 9.1) (1000 . 11.) (1200 . 13.))
  162.                                                                 ) ;_ end of mapcar
  163.                                                         ) ;_ end of vl-remove
  164.                                              ) ;_ end of _kpblc-list-add-or-subst
  165.                                    ) ;_ end of setq
  166.                              ) ;_ end of assoc
  167.                       ) ;_ end of cdr
  168.                     ) ;_ end of mapcar
  169.             ) ;_ end of mapcar
  170.     (end_list)
  171.     (foreach item (list '("rot_cornice" . "0") '("rot_space" . "0") '("use_block" . "1") '("fill" . "1") '("lst_light_block" . "0"))
  172.       (set_tile (car item) (cdr item))
  173.       (loc:dcl-callback (car item) (cdr item) 'dcl_lst)
  174.       ) ;_ end of foreach
  175.     (action_tile "accept" "(done_dialog 1)")
  176.     (action_tile "cancel" "(done_dialog 0)")
  177.     (setq dcl_res (start_dialog))
  178.     (unload_dialog dcl_id)
  179.     (if (= dcl_res 1)
  180.       dcl_lst
  181.       ) ;_ end of if
  182.     ) ;_ end of defun
  183.   (if (and (setq lst (loc:dcl-execute))
  184.            (setq selset (ssget "_X" '((0 . "INSERT") (8 . "_АХП_Вспомогательный_слой_не_печать"))))
  185.            (setq selset ((lambda (/ tab item)
  186.                            (repeat (setq tab  nil
  187.                                          item (sslength selset)
  188.                                          ) ;_ end setq
  189.                              (setq tab (cons (ssname selset (setq item (1- item))) tab))
  190.                              ) ;_ end of repeat
  191.                            ) ;_ end of lambda
  192.                          )
  193.                  ) ;_ end of setq
  194.            ) ;_ end of and
  195.     (progn (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  196.            (foreach blk selset
  197.              (setq dynprop (vlax-variant-value
  198.                              (_kpblc-property-get
  199.                                (car (vl-remove-if-not
  200.                                       (function (lambda (x)
  201.                                                   (= (strcase (_kpblc-property-get x 'propertyname)) "РАССТОЯНИЕ1") ;_ end of =
  202.                                                   ) ;_ end of lambda
  203.                                                 ) ;_ end of function
  204.                                       (_kpblc-conv-vla-to-list (vla-getdynamicblockproperties (vlax-ename->vla-object blk)))
  205.                                       ) ;_ end of vl-remove-if-not
  206.                                     ) ;_ end of car
  207.                                'value
  208.                                ) ;_ end of _kpblc-property-get
  209.                              ) ;_ end of vlax-variant-value
  210.                    name    (nth (atoi (cdr (assoc "lst_light_block" lst))) (cdr (assoc "blocks" lst))) ;_ end of nth
  211.                    step    (if (or (= (cdr (assoc "fill" lst)) "1") (wcmatch (strcase (_kpblc-get-ent-name blk)) "!КАРНИЗ")) ;_ end of or
  212.                              (cdr name)
  213.                              (/ dynprop 2.)
  214.                              ) ;_ end of if
  215.                    name    (car name)
  216.                    dist    (if (or (= (cdr (assoc "fill" lst)) "1") (wcmatch (strcase (_kpblc-get-ent-name blk)) "!КАРНИЗ")) ;_ end of or
  217.                              (/ (+ (- dynprop (* step (fix (/ dynprop step)))) step) 2.)
  218.                              (/ dynprop 2.)
  219.                              ) ;_ end of if
  220.                    ) ;_ end of setq
  221.              (while (< dist dynprop)
  222.                (setq res  (cons (vla-insertblock
  223.                                   (vla-get-modelspace adoc)
  224.                                   (vlax-3d-point
  225.                                     (polar (cdr (assoc 10 (entget blk))) (cdr (assoc 50 (entget blk))) dist) ;_ end of polar
  226.                                     ) ;_ end of vlax-3d-point
  227.                                   name
  228.                                   1.
  229.                                   1.
  230.                                   1.
  231.                                   (cdr (assoc 50 (entget blk)))
  232.                                   ) ;_ end of vla-InsertBlock
  233.                                 res
  234.                                 ) ;_ end of cons
  235.                      dist (+ dist step)
  236.                      ) ;_ end of setq
  237.                ) ;_ end of while
  238.              ) ;_ end of foreach
  239.            (princ (strcat "\nДобавлено блоков " name " : " (rtos (length res) 2 0) " шт."))
  240.            (vla-endundomark adoc)
  241.            ) ;_ end of progn
  242.     ) ;_ end of if
  243.   (princ)
  244.   ) ;_ end of defun
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн ARAKS

  • ADN OPEN
  • Сообщений: 4
  • Карма: 0
Сейчас заработала, благодарю! Подскажите еще как она работает, я не могу разобраться, имя блока в диалоговом окне у меня не выбирается.  Выбирает блоки светильников с определенным названием и расставляет их по динамическому блоку с названием "!Карниз" ?

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Эээээ... Если бы я помнил, что там было 2,5 года назад! :)
Возьми любой dwg-файл из тех, что были в теме, и попробуй прогнать код с пошаговой отладкой.
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн ARAKS

  • ADN OPEN
  • Сообщений: 4
  • Карма: 0