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

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

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

Оффлайн 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