| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > LISP'ик бы...

LISP'ик бы...

Ответ
Поиск в этой теме
Непрочитано 02.04.2004, 05:25
LISP'ик бы...
Vova
 
Engineer
 
New-York
Регистрация: 05.09.2003
Сообщений: 10,288

ЛИСПИК бы для таких случаев:
Есть несколько строк однострочного текста, расстояния между строк выбраны на глаз и не отличаются точностью. Начала строк (или середины...) не лежат на одной прямой. Вообщем, глаз не алмаз. Надо:
кликнуть на базовую строку, затем на соседнюю, и она бы подвинулась, создав правильный промежуток. При этом одновременно строки выровнялись бы по линии с их Justification. Первый клик мог бы назначить эту линию, или для этого применить последний клик в конце, когда строки уже раздвинуты. Это должно работать как по Х, так и по У и не зависеть от поворота UCS. А может, два разных LISP'а, один для строк, другой для выравнивания
Просмотров: 16041
 
Непрочитано 14.09.2007, 12:12
#21
Лентяй

Project Engineer
 
Регистрация: 05.01.2005
Лос Анджелес
Сообщений: 1,392


А лениво мне ! Впрочем, если вы такой зануда, дпржите update с блокировками. А вот насчет заморозок... Если его не видно, то на хрена ж красить :P :P ?
Код:
[Выделить все]
(defun req (wrd / kw)
  (vla-InitializeUserInput util 128 "Да Нет")
  (or (= (setq kw (vla-getKeyWord util (strcat "\n" wrd "?: [Да/Нет]: <Да>?"))) "Да")
      (= kw "")));defun
;
(defun pnt (bk1 / col)
  (if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
                                (setq col (vla-getInteger util "\nА какого колору угодно-с? "))))))
    (progn (vlax-for ent bk1 (vla-put-color ent col))
      (vla-regen adoc acAllViewports));progn
    (progn (alert "Номер цвета вводи, дубина! Понял!!") (quit)))
  (if (null (req "Ну что, понравилось")) (pnt bk1)
    (print "Ну и ладушки!"));if
  (princ)
);defun
;
(defun C:Blk_Pntr ( / adoc util bks lyrs blk bk1 lyr llc)
  (vl-load-com)
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (mapcar '(lambda (x y) (set x (vlax-get-property adoc y))) '(util bks lyrs)
	    '(Utility Blocks Layers))
  (if (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
                                (vla-getEntity util 'blk nil "Выбрать блок: "))))
    (progn (alert "Это - не блок! \nА ты - кретин") (princ))
    (if (req "ОбсерЯть бум")
      (progn (vlax-for bk bks
             (if (apply '= (mapcar 'vla-get-name (list blk bk)))
               (progn (setq bk1 bk)
                 (vlax-for ent bk
                   (setq lyr (vla-item lyrs (vla-get-layer ent)))
                   (if (and (= (vla-get-lock lyr) :vlax-true) (not (member lyr llc)))
                     (progn (setq llc (cons lyr llc))
                       (vla-put-lock lyr :vlax-false)))
                   (vla-put-color ent 9))));if
        (vla-regen adoc acAllViewports))));if
    );if
  (if (req "Красить бум") (pnt bk1) (princ))
  (foreach l llc (vla-put-lock l :vlax-true))
);end
Лентяй вне форума  
 
Непрочитано 14.09.2007, 12:21
#22
Alaspher


 
Регистрация: 11.10.2004
e•burg
Сообщений: 755


Цитата:
Сообщение от Лентяй
А лениво мне ! Впрочем, если вы такой зануда, дпржите update с блокировками. А вот насчет заморозок... Если его не видно, то на хрена ж красить :P :P ?
Я гораздо бОльший зануда, чем это можно представить - замороженным может оказаться слой, на котором находится ЧАСТЬ примитивов входящих в блок...

Ну и если лениво, так может и не перенапрягаться?
Alaspher вне форума  
 
Непрочитано 14.09.2007, 12:55
#23
Елпанов Евгений

программист
 
Регистрация: 20.12.2005
Москва
Сообщений: 1,439
Отправить сообщение для Елпанов Евгений с помощью Skype™


>Alaspher
>Лентяй
Поясните мне пожалуйста, зачем в этом коде нужен обработчик заблокированных или замороженных слоев?
Вы же работаете с описанием блоков, те. вам не страшны замороженные слои и при изменении цвета всех элементов блока, они все перекрасятся, не зависимо от состояния слоев!
Ведь состояние слоев, это атрибуты вставок блоков, но не описаний...
Елпанов Евгений вне форума  
 
Непрочитано 14.09.2007, 13:06
#24
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Не совсем. Попробуй сделать так:
Код:
[Выделить все]
(defun test (/ adoc blk blk_name ent layer layer_name)
  (vl-load-com)
  (setq adoc       (vla-get-activedocument (vlax-get-acad-object))
        layer_name "qwert"
        blk_name   "block"
        layer      (if (tblobjname "layer" layer_name)
                     (vla-item (vla-get-layers adoc) layer_name)
                     (vla-add (vla-get-layers adoc) layer_name)
                     ) ;_ end of if
        blk        (if (tblobjname "block" blk_name)
                     (vla-item (vla-get-blocks adoc) blk_name)
                     (vla-add (vla-get-blocks adoc) (vlax-3d-point '(0. 0. 0.)) blk_name)
                     ) ;_ end of if
        ent        (vla-addline
                     blk
                     (vlax-3d-point '(-10. 0. 0.))
                     (vlax-3d-point '(10. 0. 0.))
                     ) ;_ end of vla-addline
        ) ;_ end of setq
  (vla-put-layer ent layer_name)
  (vla-put-lock layer :vlax-true)
  (vla-insertblock
    (vla-get-modelspace adoc)
    (vlax-3d-point (getpoint "\nТочка вставки : "))
    blk_name
    1.
    1.
    1.
    0.
    ) ;_ end of vla-InsertBlock
  ) ;_ end of defun
А потом попробуй перекрасить примитивы блока. Для "чистоты" эксперимента попробуй выполнять при активном слое "0".
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 14.09.2007, 13:11
#25
Alaspher


 
Регистрация: 11.10.2004
e•burg
Сообщений: 755


Вообще, теоретически влиять не должно, но у меня не раз вылезала ошибка именно при обработке примитивов блоков на замороженных/заблокированных слоях. С тех пор взял за правило размораживать и разблокировать перед "употреблением"
Alaspher вне форума  
 
Непрочитано 14.09.2007, 13:21
#26
Елпанов Евгений

программист
 
Регистрация: 20.12.2005
Москва
Сообщений: 1,439
Отправить сообщение для Елпанов Евгений с помощью Skype™


так и есть, замороженные слои, нормально обрабатываются, а заблокированные вызывают ошибку...
Елпанов Евгений вне форума  
 
Непрочитано 14.09.2007, 13:34
#27
Alaspher


 
Регистрация: 11.10.2004
e•burg
Сообщений: 755


Цитата:
Сообщение от Елпанов Евгений
так и есть, замороженные слои, нормально обрабатываются, а заблокированные вызывают ошибку...
Не удивлюсь, если разные версии АКАДа ведут себя по разному в этом отношении.
Alaspher вне форума  
 
Автор темы   Непрочитано 15.09.2007, 19:59
#28
Vova

Engineer
 
Регистрация: 05.09.2003
New-York
Сообщений: 10,288


Код от Alaspher
работает хорошо, но есть один существенный недостаток: не делается Undo. Можно ли исправить?
Коду от Лентяя я предложил блок из всего чертежа, и он стал его регенерировать минут 5. Ничего не покрасил. Тогда я сделал рядом маленький блок и ткнул в него. И опять весь чертеж стал регенерироваться много раз. Вынес маленький блок на отдельный чертеж, На этот раз регенерации не было, но не покрасилось
Vova вне форума  
 
Непрочитано 15.09.2007, 22:16
#29
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


> Vova : странно. По коду метки есть.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 16.09.2007, 02:15
#30
PL


 
Регистрация: 23.11.2006
California
Сообщений: 4,750


Цитата:
Сообщение от Vova
И при этом тычок добирается до самого внутреннего блока, если он вложенный.
Нужны-ли кому, кроме меня, такие фантазии?
вероятно эти большие блоки получились из xref?
Перекраска меня очень интересует, но глобальная , А могут эти коды красить обьекты из ADT?
PL вне форума  
 
Непрочитано 17.09.2007, 09:50
#31
Alaspher


 
Регистрация: 11.10.2004
e•burg
Сообщений: 755


Цитата:
Сообщение от Vova
Код от Alaspher
работает хорошо, но есть один существенный недостаток: не делается Undo. Можно ли исправить?
Откат, на самом деле работает, но поскольку откатывается редактирование блока, то, для того, чтобы увидеть это, реген, после отката, надо делать руками в явном виде.

Цитата:
Сообщение от PL
А могут эти коды красить обьекты из ADT?
Нет, элементы АДТ вообще не работают адекватно со свойством - Color! Кстати, очень хорошо, что спросил об этом - изменил код, что бы он не вылетал на таких элементах.
Alaspher вне форума  
 
Автор темы   Непрочитано 23.09.2007, 17:05
#32
Vova

Engineer
 
Регистрация: 05.09.2003
New-York
Сообщений: 10,288


Спасибо Alaspher за очень хороший лисп. РЕГЕН работает. Но, как всегда, хочется улучшить.Функция BLCC перекрашивает блок одним махом, оставляя без изменения слои и их цвета и веса и типы линий. Функция ENCC может покрасить отдельные элементы блока, включая вложенные. Было бы просто замечательно, если бы программа спросила: что хочешь красить, весь блок или вложенный блок тычком на его элемент, и исполняла желание. Или весь блок сначала перекрасить, а затем уже подкрашивать либо элементы, либо вложенный блок. Правда, могут быть многочисленные вложения, и задача может не иметь решения. Но хотя-бы она сделала это с блоками второго уровня.
ЗЫ: лисп был-бы незаменим для тех, кто делает подосновы из чужих чертежей
Vova вне форума  
 
Автор темы   Непрочитано 24.09.2007, 05:58
#33
Vova

Engineer
 
Регистрация: 05.09.2003
New-York
Сообщений: 10,288


Кто помнит, здесь пробегал лисп, который может поменять начало и конец отрезка. Дело в том, что имеются типы линий с буквами, и надо чтобы они не были вверх ногами. А рисовать иногда приходиться с неправильного конца, а потом переворачивать
Vova вне форума  
 
Непрочитано 24.09.2007, 06:45
#34
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,825


Vova
http://dwg.ru/dnl/607
Krieger вне форума  
 
Непрочитано 24.09.2007, 07:07
#35
ShaggyDoc

Thượng Tá Quân Đội Nhân Dân Việt Nam
 
Регистрация: 14.03.2005
44d32'44"С, 33d26'51"В
Сообщений: 13,381


Цитата:
Сообщение от Vova
Кто помнит, здесь пробегал лисп, который может поменять начало и конец отрезка. Дело в том, что имеются типы линий с буквами, и надо чтобы они не были вверх ногами. А рисовать иногда приходиться с неправильного конца, а потом переворачивать
Вот реверс "LWPOLYLINE" "LINE" "SPLINE". Обрабатывает и дуговые сегменты.
Вытаскивал из ruCAD в отсутствии Автокада, поэтому мог какую-нибудь функции и выпустить. Не хватит - добавлю. Код старый, предложения по улучшению приветствуются.


Код:
[Выделить все]
;;; библиотечные функции
;;;----------------------------------------------
(defun ru-error-catch
       (protected_expression on_error_expression / catch_error_result)
  (setq catch_error_result
         (vl-catch-all-apply protected_expression)
  ) ;_ end of setq
  (if (and (vl-catch-all-error-p catch_error_result)
           on_error_expression
      ) ;_ end of and
    (apply on_error_expression
           (list (vl-catch-all-error-message catch_error_result))
    ) ;_ end of apply
    catch_error_result
  ) ;_ end of if
)
;;;----------------------------------------------
(defun _ru-get-ent-default (message       default_str   quoted_get_func esc_enabled
                            /             result        question
                            lst_params    key_str
                           )
  (if default_str
    (setq
      question (strcat "\n" message " <" default_str ">: ")
    ) ;_ end of setq
    (setq
      question (strcat "\n" message ": ")
    ) ;_ end of setq
  ) ;_ end of if
  (setq lst_params (list question)
   end nil     
        )
   (while
   (not end)

   (ru-error-catch
    (function (lambda ()
        (cond ((and initget_param keywords)
               (initget initget_param (strcat keywords alt_key_str))
              )
              ((not (null initget_param))
               (initget initget_param)
              )
              ((not (null keywords))
               (initget (strcat keywords alt_key_str))
              )
        ) ;_ end of cond

        (setq result (vl-catch-all-apply quoted_get_func lst_params)
              end T)
          result      
                      
              ) ;_ end of lambda
    ) ;_ end of function
    ;;Это выполняется при ошибке
      (function
       (lambda (msg)
        (if esc_enabled
         (setq result nil
               end t
         ) ;_ end of setq
         (progn 
         (princ "\nЗдесь прерывание по ESC недопустимо!")
          (setq ;;result nil
               end NIL
         )
         )
        ) ;_ end of if
        (princ)
       ) ;_ end of lambda
      ) ;_ end of function
 
   ) ;_ end of ru-error-catch
 ) ;_ end of while
  result
) ;_ end of defun
;;;----------------------------------------------
(defun ru-get-entsel (message)
  ;; (ru-get-entsel "Выбери объект, но не промахнись!")
  ;; Применять при отсутствии требований к блокирове и типам
  ;; примитивов
  ;; Возвращает примитив и точку указания
  (_ru-get-ent-default message "Выход" '_ru-get-entsel-no-error T)
)
;;;----------------------------------------------
(defun _ru-get-entsel-no-error (message / ent)
  ;; (_ru-get-entsel-no-error "Выбери объект, но не промахнись!")
  (setvar "errno" 0)
  (while
    (and
      (not (setq ent (entsel (strcat "\n" message))) ;)
      ) ;_ end of not
      (equal 7 (getvar "errno"))
      ;;Ошибка указания при выборе
      ;; блокированный слой?
    ) ;_ end of and
     (setvar "errno" 0)
  ) ;_ end of while
  (cond
    ((equal (getvar "errno") 52)
     ;; пустой ответ
     nil
    )
    (t
     (list (car ent) (trans (cadr ent) 1 0))
    )
  ) ;_ end of cond
) 
;;;----------------------------------------------
(defun ru-get-entsel-by-type
                             (message     msg_err_types
                              list_types  no_locked   /
                              ent         ent_type    bad_type
                              locked      do
                             )
                             ;|
Выбор примитива с воможностью задать допустимые типы и выбор на не блокированном слое
с возможностью выхода и с блокировкой ESC
Параметры:
message - сообщение
msg_err_types - сообщение о неверном типе если задан список типов, иначе ""
list_types - список допустимх типов или NIL
no_locked  - выбор на не блокированном слое -T, на любом -NIL
 (ru-get-entsel-by-type "Выбери отрезок или полилинию" "Это не ОТРЕЗОК и не ПОЛИЛИНИЯ" (list "LINE" "LWPOLYLINE") T)
 (ru-get-entsel-by-type "Выбери объект на неблокированном слое" "" nil  T)
 (ru-get-entsel-by-type "Выбери отрезок или полилинию - можно на блокированном" "Это не ОТРЕЗОК и не ПОЛИЛИНИЯ" (list "LINE" "LWPOLYLINE") nil)
Возвращает имя примитива и точку указания или nil при отказе
 |;

  (setq do t)
  (while do
    (setq bad_type t
          locked t
    ) ;_ end of setq
    (if (setq ent (ru-get-entsel message))
      (progn
        (setq ent_type (cdr (assoc 0 (entget (car ent)))))
        (if (and list_types
                 (not (member ent_type list_types))
            ) ;_ end of and
          (princ (strcat "\nОШИБКА: Указан объект типа '"
                         ent_type
                         "'. "
                         msg_err_types
                 ) ;_ end of strcat
          ) ;_ end of princ
          (setq bad_type nil)
        ) ;_ end of if
        (if (and no_locked
                 (ru-layer-is-lock (cdr (assoc 8 (entget (car ent)))))
            ) ;_ end of and
          (princ "\nОШИБКА: Объект на заблокированном слое!")
          (setq locked nil)
        ) ;_ end of if
        (setq do (or bad_type locked))
      ) ;_ end of progn
      (setq do nil)
    ) ;_ end of if
  ) ;_ end of while
  ent
) ;_ end of defun
;;;----------------------------------------------
(defun ru-layer-get-ent-data (name code / lst res)
  ;; возвращает данные с кодом CODE для слоя NAME
  ;; если слой не существует - NIL
  (if (setq Lst (tblsearch "LAYER" name))
    (cdr (assoc code lst))
    nil
  ) ;_ end of if
)
;;;----------------------------------------------
(defun ru-match-is-bit-in-flag (val flag)
    ;; (ru-match-bit-list 127)  => (64 32 16 8 4 2 1)  
    ;; (ru-match-is-bit-in-flag  8 127) => T   
    ;; (ru-match-is-bit-in-flag  128 127) => nil   
    (= (logand val flag) val)
)
;;;----------------------------------------------
(defun ru-layer-is-lock (name / layer_data)
  ;; (ru-layer-is-lock "0") 
  ;; (ru-layer-is-lock "Layer1")
  ;;А несуществующий слой вернет Т
  (if (setq layer_data (ru-layer-get-ent-data name 70))
    (ru-match-is-bit-in-flag 4 layer_data)
    nil
  ) ;_ end of if
)
;;;----------------------------------------------
(defun ru-ent-dxf-code-data (dxf_code lst)
    (cdr (assoc dxf_code lst))
  ) ;_ end of defun
;;;----------------------------------------------
(defun ru-ent-mod (ent value bit / ent_list old_dxf new_dxf)
  (setq ent_list (entget ent)
        new_dxf  (cons bit
                       (if (and (= bit 62) (= (type value) 'str))
                         (if (= (strcase value) "BYLAYER")
                           256
                           0
                         ) ;_ end of if
                         value
                       ) ;_ end of if
                 ) ;_ end of cons
  ) ;_ end of setq
  (if (/= new_dxf (setq old_dxf (assoc bit ent_list)))
    (progn (entmod (if old_dxf
                     (subst new_dxf old_dxf ent_list)
                     (append ent_list (list new_dxf))
                   ) ;_ end of if
           ) ;_ end of entmod
           (entupd ent)
           (redraw ent)
    ) ;_ end of progn
  ) ;_ end of if
  ent
) ;_ end of defun
;;;----------------------------------------------

(defun ru-list-massoc (key alist)
(mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist))
) ;_ end of defun

;;;----------------------------------------------
(defun ru-ent-dxf-code-clear-list (lst list_dxf_codes is_stay_value)
    (cond
        ((null lst) NIL)
        ((/= is_stay_value (= (type (member (caar lst) list_dxf_codes)) 'list))
         (ru-ent-dxf-code-clear-list (cdr lst) list_dxf_codes is_stay_value)
        )
        (t (cons (car lst) (ru-ent-dxf-code-clear-list (cdr lst) list_dxf_codes is_stay_value)))
    ) ;_ end of cond
)
;;;----------------------------------------------
(defun c:revpoly (/                bulge_list       end_width_list
                  list_vertex_data num_vertex       num_width
                  ent_data         ent_name         start_width_list
                  vertex_count     vertex_list      ent_type
                 )
  (if (setq ent_name
             (ru-get-entsel-by-type
               "Выбери полилинию, отрезок или сплайн для реверса"
               "Примитив недопустимого типа"
               (list "LWPOLYLINE" "LINE" "SPLINE")
               t
             ) ;_ end of ru-get-entsel-by-type
      ) ;_ end of setq
    (progn
      (setq ent_name (car ent_name)
            ent_data (entget ent_name)
            ent_type (ru-ent-dxf-code-data 0 ent_data)
      ) ;_ end of setq
      (cond
        ((= ent_type "SPLINE")
         ;; Для реверса сплайна имеется метод
         (vla-reverse (vlax-ename->vla-object ent_name))
        )
        ((= ent_type "LINE")
         ;;Для отрезка достаточно поменять местами координаты вершин
         (ru-ent-mod ent_name (cdr (assoc 11 ent_data)) 10)
         (ru-ent-mod ent_name (cdr (assoc 10 ent_data)) 11)
        )
        ((= ent_type "LWPOLYLINE")
         (setq
           vertex_list      (reverse (ru-list-massoc 10 ent_data))
           bulge_list       (mapcar
                              '(lambda (x) (- 0 x))
                              (reverse (ru-list-massoc 42 ent_data))
                            ) ;_ end of mapcar
           start_width_list
                            (ru-list-massoc 40 ent_data)
           end_width_list
                            (ru-list-massoc 41 ent_data)
           vertex_count     (length vertex_list)
           num_vertex       0
           num_width        (1- vertex_count)
         ) ;_ end of setq
         (repeat vertex_count
           (setq list_vertex_data
                  (append
                    (list (cons 10 (nth num_vertex vertex_list)))
;;; ------------- Именно в таком порядке -------------------
                    (list (cons 41 (nth num_width start_width_list)))
                    (list (cons 40 (nth num_width end_width_list)))
;;; ------------- Именно в таком порядке -------------------
                    (list (cons 42 (nth num_vertex bulge_list)))
                    list_vertex_data
                  ) ;_ end of append
                 num_vertex
                  (1+ num_vertex)
                 num_width (1- num_width)
           ) ;_ end of setq
         ) ;_ end of repeat
         ;|
Чтобы не возиться по отдельности со свойствами, особенно с такими, которые
могут отстутствовать в списках, очищаем список данных от координат, ширины и bulge
и модифицируем примитив
|;
         (entmod (append (ru-ent-dxf-code-clear-list
                           ent_data
                           (list 10 40 41 42)
                           nil
                         ) ;_ end of ru-ent-dxf-code-clear-list
                         (reverse list_vertex_data)
                 ) ;_ end of append
         ) ;_ end of entmod
         (entupd ent_name)
         (redraw ent_name)
        ) ;_ end of cond
      ) ;_ end of cond
    ) ;_ end of progn
  ) ;_ end of if
  (princ)
) ;_ end of defun

После загрузки вызывать команду REVPOLY любым способом.
ShaggyDoc вне форума  
 
Автор темы   Непрочитано 18.10.2017, 19:07
#36
Vova

Engineer
 
Регистрация: 05.09.2003
New-York
Сообщений: 10,288


Был бы полезен такой лиспик:
кликнув на рамку впорт-а в пространстве листа, получить его контур в пространстве модели. И чтобы он оказался в непечатаемом слое, скажем, с именем X-VPORT-GUIDE То есть отражение контура. Неброский цвет, скажем, н-р 30 будет неплох. "Х" в имени слоя это приставка, у каждой конторы может быть своя. И чтобы можно было работать и с полигональными, а может и с круглыми в-портами
Vova вне форума  
 
Непрочитано 18.10.2017, 19:17
#37
Nike

Шаражпроектхалтурмонтаж
 
Регистрация: 29.10.2004
Талды-Париж
Сообщений: 5,989


Не помню откуда

Код:
[Выделить все]
 (defun C:VPL (/ ss1 ss2 ss3 zzz PolObj PntArr VptObj XofSet YofSet VptCen PntArr)

  (setq ss1 (ssget '((0 . "VIEWPORT"))))
  (setq ss2 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1))))

  (foreach vp ss2
    (progn
      (vl-cmdf "_.MSPACE")
      (vla-put-activepviewport
        (vla-get-activedocument (vlax-get-acad-object))
        (vlax-ename->vla-object Vp)
      ) ;_ end of vla-put-ActivePViewport
      (vl-cmdf "_.PSPACE")
      (if
        (assoc 340 (entget vp))
         (progn
           (setq zzz nil)
           (setq ss3 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (cdr (assoc 340 (entget vp)))))))
           (foreach pt ss3 (setq zzz (append zzz (trans pt 3 2))))
           (setq PntArr (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length zzz)))))
           (vlax-safearray-fill PntArr zzz)
           (setq PolObj (vla-addpolyline
                          (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
                          PntArr
                        ) ;_ end of vla-AddPolyline
                 PolObj (vla-put-closed PolObj :vlax-true)

           ) ;_ end of setq
         ) ;_ end_of_progn

         (progn
           (setq VptObj (vlax-ename->vla-object Vp)
                 XofSet (/ (vla-get-width VptObj) 2.0)
                 YofSet (/ (vla-get-height VptObj) 2.0)
                 VptCen (vlax-get VptObj 'Center)
                 PntArr (vlax-make-safearray vlax-vbdouble '(0 . 11))
           ) ;_ end_of_setq

           (vlax-safearray-fill
             PntArr
             (append
               (trans (list (- (car VptCen) XofSet) (- (cadr VptCen) YofSet)) 3 2)
               (trans (list (+ (car VptCen) XofSet) (- (cadr VptCen) YofSet)) 3 2)
               (trans (list (+ (car VptCen) XofSet) (+ (cadr VptCen) YofSet)) 3 2)
               (trans (list (- (car VptCen) XofSet) (+ (cadr VptCen) YofSet)) 3 2)
             ) ;_ end of append
           ) ;_ end of vlax-safearray-fill
           (setq PolObj (vla-addpolyline
                          (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
                          PntArr
                        ) ;_ end of vla-AddPolyline
                 PolObj (vla-put-closed PolObj :vlax-true)
           ) ;_ end of setq
           (vlax-release-object VptObj)
         ) ;_ end_of_progn
      ) ;_ end_of_if
    ) ;_ end of progn
  ) ;_ end_of_foreach
  (princ)
) ;_end_of_defun

еще http://www.lee-mac.com/vpoutline.html

Код:
[Выделить все]
 ;;-----------------------=={ Viewport Outline }==-----------------------;;
;;                                                                      ;;
;;  This program allows the user to automatically generate a polyline   ;;
;;  in modelspace representing the outline of a selected paperspace     ;;
;;  viewport.                                                           ;;
;;                                                                      ;;
;;  The command is only available in paperspace (that is, when a        ;;
;;  layout tab other than the Model tab is the current layout, and no   ;;
;;  viewports are active).                                              ;;
;;                                                                      ;;
;;  Upon issuing the command syntax 'VPO' at the AutoCAD command-line,  ;;
;;  the user is prompted to select a viewport for which to construct    ;;
;;  the viewport outline in modelspace.                                 ;;
;;                                                                      ;;
;;  Following a valid selection, the boundary of the selected viewport  ;;
;;  is transformed appropriately to account for the position, scale,    ;;
;;  rotation, & orientation of the modelspace view displayed through    ;;
;;  the selected viewport, and a 2D polyline (LWPolyline) representing  ;;
;;  this transformed boundary is constructed in modelspace.             ;;
;;                                                                      ;;
;;  The program is compatible for use with all Rectangular, Polygonal & ;;
;;  Clipped Viewports (including those with Arc segments), and with all ;;
;;  views & construction planes.                                        ;;
;;                                                                      ;;
;;  The program also offers the ability to optionally offset the        ;;
;;  polyline outline to the interior of the viewport boundary by a      ;;
;;  predetermined number of paperspace units specified in the           ;;
;;  'Program Parameters' section of the program source code.            ;;
;;                                                                      ;;
;;  The program may also be configured to automatically apply a         ;;
;;  predefined set of properties (e.g. layer, colour, linetype, etc.)   ;;
;;  to the resulting polyline outline - these properties are also       ;;
;;  listed within the 'Program Parameters' section of the source code.  ;;
;;                                                                      ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2015  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.0    -    2015-01-02                                      ;;
;;                                                                      ;;
;;  - First release.                                                    ;;
;;----------------------------------------------------------------------;;
;;  Version 1.1    -    2016-08-11                                      ;;
;;                                                                      ;;
;;  - Program modified to account for polygonal viewports represented   ;;
;;    by 2D (Heavy) Polylines.                                          ;;
;;----------------------------------------------------------------------;;
;;  Version 1.2    -    2017-09-03                                      ;;
;;                                                                      ;;
;;  - Added the ability to specify an optional interior offset          ;;
;;    (relative to Paperspace Viewport dimensions).                     ;;
;;  - Added default polyline properties.                                ;;
;;----------------------------------------------------------------------;;

(defun c:vpo ( / *error* cen dpr ent lst ocs ofe off tmp vpe vpt )

    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

    (setq

;;----------------------------------------------------------------------;;
;;                          Program Parameters                          ;;
;;----------------------------------------------------------------------;;

        ;; Optional Interior Offset
        ;; Set this parameter to nil or 0.0 for no offset
        off 0.0

        ;; Default Polyline Properties
        ;; Omitted properties will use current settings when the program is run
        dpr
       '(
            (006 . "BYLAYER")   ;; Linetype (must be loaded)
           ;(008 . "VPOutline") ;; Layer (automatically created if not present in drawing)
            (039 . 0.0)         ;; Thickness
            (048 . 1.0)         ;; Linetype Scale
            (062 . 256)         ;; Colour (0 = ByBlock, 256 = ByLayer)
            (370 . -1)          ;; Lineweight (-1 = ByLayer, -2 = ByBlock, -3 = Default, 0.3 = 30 etc.)
        )
        
;;----------------------------------------------------------------------;;

    )
    
    (LM:startundo (LM:acdoc))
    (cond
        (   (/= 1 (getvar 'cvport))
            (princ "\nCommand not available in Modelspace.")
        )
        (   (setq vpt (LM:ssget "\nSelect viewport: " '("_+.:E:S" ((0 . "VIEWPORT")))))
            (setq vpt (entget (ssname vpt 0)))
            (if (setq ent (cdr (assoc 340 vpt)))
                (setq lst (vpo:polyvertices ent))
                (setq cen (mapcar 'list (cdr (assoc 10 vpt))
                              (list
                                  (/ (cdr (assoc 40 vpt)) 2.0)
                                  (/ (cdr (assoc 41 vpt)) 2.0)
                              )
                          )
                      lst (mapcar
                             '(lambda ( a ) (cons (mapcar 'apply a cen) '(42 . 0.0)))
                             '((- -) (+ -) (+ +) (- +))
                          )
                )
            )
            (if (not (LM:listclockwise-p (mapcar 'car lst)))
                (setq lst (reverse (mapcar '(lambda ( a b ) (cons (car a) (cons 42 (- (cddr b))))) lst (cons (last lst) lst))))
            )
            (if (and (numberp off) (not (equal 0.0 off 1e-8)))
                (cond
                    (   (null
                            (setq tmp
                                (entmakex
                                    (append
                                        (list
                                           '(000 . "LWPOLYLINE")
                                           '(100 . "AcDbEntity")
                                           '(100 . "AcDbPolyline")
                                            (cons 90 (length lst))
                                           '(070 . 1)
                                        )
                                        (apply 'append (mapcar '(lambda ( x ) (list (cons 10 (car x)) (cdr x))) lst))
                                    )
                                )
                            )
                        )
                        (princ "\nUnable to generate Paperspace outline for offset.")
                    )
                    (   (vl-catch-all-error-p (setq ofe (vl-catch-all-apply 'vlax-invoke (list (vlax-ename->vla-object tmp) 'offset off))))
                        (princ (strcat "\nViewport dimensions too small to offset outline by " (rtos off) " units."))
                        (entdel tmp)
                    )
                    (   (setq ofe (vlax-vla-object->ename (car ofe))
                              lst (vpo:polyvertices ofe)
                        )
                        (entdel ofe)
                        (entdel tmp)
                    )
            	)
            )
            (setq vpe (cdr (assoc -1 vpt))
                  ocs (cdr (assoc 16 vpt))
            )
            (entmakex
                (append
                    (list
                       '(000 . "LWPOLYLINE")
                       '(100 . "AcDbEntity")
                       '(100 . "AcDbPolyline")
                        (cons 90 (length lst))
                       '(070 . 1)
                       '(410 . "Model")
                    )
                    (if (and (setq ltp (assoc 6 dpr)) (not (tblsearch "ltype" (cdr ltp))))
                        (progn
                            (princ  (strcat "\n\"" (cdr ltp) "\" linetype not loaded - linetype set to \"ByLayer\"."))
                            (subst '(6 . "BYLAYER") ltp dpr)
                        )
                        dpr
                    )
                    (apply 'append (mapcar '(lambda ( x ) (list (cons 10 (trans (pcs2wcs (car x) vpe) 0 ocs)) (cdr x))) lst))
                    (list (cons 210 ocs))
                )
            )
        )
    )
    (LM:endundo (LM:acdoc))
    (princ)
)

(defun vpo:polyvertices ( ent )
    (apply '(lambda ( foo bar ) (foo bar))
        (if (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
            (list
                (lambda ( enx )
                    (if (setq enx (member (assoc 10 enx) enx))
                        (cons (cons  (cdr (assoc 10 enx)) (assoc 42 enx)) (foo (cdr enx)))
                    )
                )
                (entget ent)
            )
            (list
                (lambda ( ent / enx )
                    (if (= "VERTEX" (cdr (assoc 0 (setq enx (entget ent)))))
                        (cons (cons (cdr (assoc 10 enx)) (assoc 42 enx)) (foo (entnext ent)))
                    )
            	)
                (entnext ent)
            )
        )
    )
)

;; List Clockwise-p  -  Lee Mac
;; Returns T if the point list is clockwise oriented

(defun LM:listclockwise-p ( lst )
    (minusp
        (apply '+
            (mapcar
                (function
                    (lambda ( a b )
                        (- (* (car b) (cadr a)) (* (car a) (cadr b)))
                    )
                )
                lst (cons (last lst) lst)
            )
        )
    )
)

;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)

;; PCS2WCS (gile)
;; Translates a PCS point to WCS based on the supplied Viewport
;; (PCS2WCS pt vp) is the same as (trans (trans pt 3 2) 2 0) when vp is active
;; pnt : PCS point
;; ent : Viewport ename

(defun PCS2WCS ( pnt ent / ang enx mat nor scl )
    (setq pnt (trans pnt 0 0)
          enx (entget ent)
          ang (- (cdr (assoc 51 enx)))
          nor (cdr (assoc 16 enx))
          scl (/ (cdr (assoc 45 enx)) (cdr (assoc 41 enx)))
          mat (mxm
                  (mapcar (function (lambda ( v ) (trans v 0 nor t)))
                     '(   (1.0 0.0 0.0)
                          (0.0 1.0 0.0)
                          (0.0 0.0 1.0)
                      )
                  )
                  (list
                      (list (cos ang) (- (sin ang)) 0.0)
                      (list (sin ang)    (cos ang)  0.0)
                     '(0.0 0.0 1.0)
                  )
              )
    )
    (mapcar '+
        (mxv mat
            (mapcar '+
                (vxs pnt scl)
                (vxs (cdr (assoc 10 enx)) (- scl))
                (cdr (assoc 12 enx))
            )
        )
        (cdr (assoc 17 enx))
    )
)

;; Matrix Transpose  -  Doug Wilson
;; Args: m - nxn matrix

(defun trp ( m )
    (apply 'mapcar (cons 'list m))
)

;; Matrix x Matrix  -  Vladimir Nesterovsky
;; Args: m,n - nxn matrices

(defun mxm ( m n )
    ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)

;; Matrix x Vector  -  Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n

(defun mxv ( m v )
    (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

;; Vector x Scalar  -  Lee Mac
;; Args: v - vector in R^n, s - real scalar

(defun vxs ( v s )
    (mapcar '(lambda ( n ) (* n s)) v)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)

;;----------------------------------------------------------------------;;

(princ
    (strcat
        "\n:: VPOutline.lsp | Version 1.2 | \\U+00A9 Lee Mac "
        (menucmd "m=$(edtime,0,yyyy)")
        " www.lee-mac.com ::"
        "\n:: Type \"vpo\" to Invoke ::"
    )
)
(princ)

;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;
еще http://jtbworld.com/autocad-vp-outline-lsp

Этот с круглыми работает

Код:
[Выделить все]
 ;;; vp-outline.lsp
;;;
;;; Creates a polyline in modelspace that
;;; has the outline of the selected viewport.
;;; Supports clipped viewports. polyline is supported
;;; ellipse, spline, region and circle not supported at this point
;;; If vp-outline is called when in mspace it detects
;;; the active viewport.
;;;
;;; c:vp-outline
;;;
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2013 JTB World, All Rights Reserved
;;; Website: www.jtbworld.com
;;; E-mail: [email protected]
;;;
;;; 2000-04-10
;;; 2003-11-19 Added support for drawing the outline in other ucs/view than world/current
;;;
;;; 2006-04-06 Added support for twisted views Tom Beauford
;;; 2013-06-08 Added support for circular viewports
;;;
;;; Should work on AutoCAD 2000 and newer
(vl-load-com)

(defun dxf (n ed) (cdr (assoc n ed)))

(defun ax:List->VariantArray (lst)
  (vlax-Make-Variant
    (vlax-SafeArray-Fill
      (vlax-Make-SafeArray
	vlax-vbDouble
	(cons 0 (- (length lst) 1))
      )
      lst
    )
  )
)

(defun c:vp-outline (/ ad ss ent pl plist xy n vpbl vpur msbl msur ven vpno ok
		     circ)
  (setq ad (vla-get-activedocument (vlax-get-acad-object)))
  (if (= (getvar "tilemode") 0)
    (progn
      (if (= (getvar "cvport") 1)
	(progn
	  (if (setq ss (ssget ":E:S" '((0 . "VIEWPORT"))))
	    (progn (setq ent (ssname ss 0))
		   (setq vpno (dxf 69 (entget ent)))
		   (vla-Display (vlax-ename->vla-object ent) :vlax-true)
		   (vla-put-mspace ad :vlax-true) ; equal (command "._mspace")
 ; this to ensure trans later is working on correct viewport
		   (setvar "cvport" vpno)
 ;              (vla-put-mspace ad :vlax-false) ; equal (command "._pspace")
		   (setq ok T)
		   (setq ss nil)
	    )
	  )
	)
	(setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))
	      ok  T
	)
      )
      (if ok
	(progn (setq circle nil)
	       (setq ven (vlax-ename->vla-object ent))
	       (if (/= 1 (logand 1 (dxf 90 (entget ent)))) ; detect perspective
		 (progn	(if (= (vla-get-clipped ven) :vlax-false)
			  (progn ; not clipped
			    (vla-getboundingbox ven 'vpbl 'vpur)
			    (setq vpbl	(trans (vlax-safearray->list vpbl) 3 2)
				  msbl	(trans vpbl 2 1)
				  msbl	(trans msbl 1 0)
				  vpur	(trans (vlax-safearray->list vpur) 3 2)
				  msur	(trans vpur 2 1)
				  msur	(trans msur 1 0)
				  vpbr	(list (car vpur) (cadr vpbl) 0)
				  msbr	(trans vpbr 2 1)
				  msbr	(trans msbr 1 0)
				  vpul	(list (car vpbl) (cadr vpur) 0)
				  msul	(trans vpul 2 1)
				  msul	(trans msul 1 0)
				  plist	(list (car msbl)
					      (cadr msbl)
					      (car msbr)
					      (cadr msbr)
					      (car msur)
					      (cadr msur)
					      (car msul)
					      (cadr msul)
					)
			    )
			  )
			  (progn ; clipped
			    (setq pl (entget (dxf 340 (entget ent))))
			    (if	(= (dxf 0 pl) "CIRCLE")
			      (setq circle T)
			      (progn (setq plist (vla-get-coordinates
						   (vlax-ename->vla-object (dxf -1 pl))
						 )
					   plist (vlax-safearray->list (vlax-variant-value plist))
					   n	 0
					   pl	 nil
				     )
				     (repeat (/ (length plist) 2)
				       (setq xy	(trans (list (nth n plist) (nth (1+ n) plist)) 3 2)
					     xy	(trans xy 2 1)
					     xy	(trans xy 1 0)
					     pl	(cons (car xy) pl)
					     pl	(cons (cadr xy) pl)
					     n	(+ n 2)
				       )
				     )
				     (setq plist (reverse pl))
			      )
			    )
			  )
			)
			(if circle
			  (vla-AddCircle
			    (vla-get-ModelSpace ad)
			    (ax:List->VariantArray
			      (trans (trans (trans (dxf 10 pl) 1 0) 2 1) 3 2)
			    )
			    (/ (dxf 40 pl) (caddr (trans '(0 0 1) 2 3)))
			  )
			  (vla-Put-Closed
			    (vla-AddLightWeightPolyline
			      (vla-get-ModelSpace ad)
			      (ax:List->VariantArray plist)
			    )
			    :vlax-True
			  )
			)
		 )
	       )
	)
      )
    )
  )
  (if ss
    (vla-put-mspace ad :vlax-false)
  ) ; equal (command "._pspace"))
  (princ)
)

Последний раз редактировалось Nike, 18.10.2017 в 19:32.
Nike вне форума  
 
Автор темы   Непрочитано 19.10.2017, 23:42
#38
Vova

Engineer
 
Регистрация: 05.09.2003
New-York
Сообщений: 10,288


Попробовал 3 лиспа от Nike
VPL не работает с дуговыми элементами рамки вид. экрана, а только с полигональными и прямоуг. Зато может последовательно проецировать в пространство модели несколько разных вид. экранов за одно взятие команды.
------------------
VPO Работает как с прямыми так и с дуговыми элементами вид. экранов. По-очередно.
----------------
VP-outline Видимо, лисп создан для спец. случаев: после клика на вид. экран оставляет его открытым. Не работает с дугами
Таким образом, для себя выбираю два первых

Nike, пребольшое спасибо
Vova вне форума  
 
Непрочитано 20.10.2017, 10:04
#39
CRISTOFF

расчёты
 
Регистрация: 04.07.2009
Воронеж
Сообщений: 908


Offtop:
Цитата:
Сообщение от Vova Посмотреть сообщение
кликнув на рамку впорт-а в пространстве листа, получить его контур в пространстве модели
а в каких случаях в работе этот контур нужен? Что с ним потом делаете?
__________________
"Сделай первый шаг - и ты поймёшь, что не всё так страшно." (Сенека, древнеримский философ).
CRISTOFF вне форума  
 
Автор темы   Непрочитано 20.10.2017, 15:15
#40
Vova

Engineer
 
Регистрация: 05.09.2003
New-York
Сообщений: 10,288


Цитата:
Сообщение от CRISTOFF Посмотреть сообщение
а в каких случаях в работе этот контур нужен? Что с ним потом делаете?
Просто чтобы знать какой участок в пространстве модели попал во Vport. Работаем ведь мы в моделе а чертеж выводится в простр. листа. Бывает, надо уточнить границы видового экрана чтобы не обрезать лишнего или добавить чего. Например, сейчас я работаю над разбивкой электрического плана жилого этажа по отдельным квартирам, чтобы на стройке могли работать несколько бригад поквартирно. Контуры квартир довольно сложные, они внедряются друг в друга. Полигональные рамки в-портов, спроецированные в пространство модели, хорошо помогают ориентироваться.
У нас на работе есть подобный лисп, но он работает только с прямоугольными экранами. Но зато он переводит полученную в модели рамку экрана в особый непечатаемый слой который можно не удалять. Могут ли наши умельцы подправить VPL и VPO чтобы контур попал во вновь образованный непечатный слой, как я просил в н-р 36?
Vova вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > LISP'ик бы...

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск