[Vova]

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

Зачем lisp :idea:
Есть текстовый редактор MtmdEdit! Он это делает! См. http://www.alx.ncn.ru Запускается командой _te

Автор не я. Но я его знаю

[kos]

Сообщение от Vova ЛИСПИК бы ...

А макрос?... [sm101]

[Pilot]

Может это и не совсем то.
Этот "Лиспик" позволяет выбрать объекты, отсортировывает из них текст (пока только однострочный), а потом выстраивает его в колонку по вертикали, присваивая строкам одинаковый стиль и высоту, беря за образец самую верхнюю строку.
У верхней строки стиль должен быть с высотой 0.

Код:

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

(defun C:Stext ( / a2 c1 g1 g2 h1 h2 j2 l1 l2 p1 p2 s1 t1 y1 y2)
(while (not s1)
   (princ "\nSelect text.")
   (setq s1 (ssget (list (cons 0 "TEXT")))));while
(setq s1 (SortXY (SortXY s1 'x) 'y)
      y1 (getvar "clayer")
      h1 (getvar "textsize")
      g1 (getvar "textstyle")
      c1 0)
(repeat (sslength s1)
   (setq l1 (entget (ssname s1 c1))
         l2 (cons (cdr (assoc 1 l1)) l2)
         p1 (if p1 p1 (cdr (assoc 10 l1)))
         p2 (if p2 p2 (cdr (assoc 11 l1)))
         y2 (if y2 y2 (cdr (assoc  8 l1)))
         h2 (if h2 h2 (cdr (assoc 40 l1)))
         g2 (if g2 g2 (cdr (assoc  7 l1)))
         j2 (if j2 j2 (cdr (assoc 72 l1)))
         a2 0
         c1 (1+ c1))
);repeat
(setvar "cmdecho" 0)
(command "_erase" s1 "")
(setvar "clayer" y2)(setvar "textstyle" g2)(Osmo 0)
(foreach t1 (reverse l2)
   (if (= j2 0)
      (command "_text" p1 h2 (RtoG a2) t1)
      (command "_text" "_c" p2 h2 (RtoG a2) t1))
   (setq p1 (polar p1 (- a2 (GtoR 90))(* h2 2))
         p2 (polar p2 (- 1a2 (GtoR 90))(* h2 2))))
(setvar "clayer" y1)(setvar "textstyle" g1)(setvar "textsize" h1)
(Osmo nil)(princ));c:Stext

(defun SortXY (s1 ord / c1 s2 x1 x2 n1)
(setvar "cmdecho" 1)
(if ord
   (progn
      (setq s2 (ssadd))
      (while (> (sslength s1) 0)
         ;(Wait "Sorting")
         (setq c1 0 x1 nil n1 nil)
         (repeat (sslength s1)
            (if (not n1)(setq n1 0))
            (setq l1 (entget (ssname s1 c1))
                  x2 (if (= ord 'x)
                        (car  (cdr (assoc 10 l1)))
                        (cadr (cdr (assoc 10 l1)))))
            (if (not x1)(setq x1 x2))
            (if (= ord 'x)
               (if (<  x2 x1)(setq x1 x2 n1 c1))
               (if (>  x2 x1)(setq x1 x2 n1 c1)))
            (setq c1 (1+ c1)))
         (setq s2 (ssadd (ssname s1 n1) s2))
         (ssdel (ssname s1 n1) s1)));progn
   (setq s2 (if (and (> (sslength s1) 1)(YesNo "Sort"))
                  (SortXY (SortXY s1 'x) 'y) s1));setq
);if
s2);SortXY

(defun GtoR (grad)(* grad (/ pi 180.0)));GtoR

(defun RtoG (rad)(* rad (/ 180.0 pi)));RtoG

(defun Osmo (v1);global osmo0
(cond ((and v1 osmo0)(setvar "osmode" 0))
      (v1 (setq osmo0 (getvar "osmode"))(setvar "osmode" 0))
      (osmo0 (setvar "osmode" osmo0)(setq osmo0 nil)))
(princ));Osmo

[Эдуард]

Владимир-Скинул на мыло.

[Vova]

Pilot> не пойму как это работает
1. Что значит "позволяет выбрать об-екты и отсортировывает из них текст" Какие объекты?
2. При попытке указать текст после нажатия Enter удаляет все строки кроме верхней и говорит при этом что bad argument
Эдуард> Strok2.lsp выравнивает строки по выбранной оси но не создает правильный промежуток между строками. Кроме того, странно работает команда undo

[{Smirnoff}]

Вот сделал на скорую руку. Сначала указывем расстояние "разноса" строк, потом щелкаем по ним сверху вниз. Если выравниванеи было разное то дальше оно становиться по первой указанной строке. Безусловно это надо доработать, чтобы можно было выбирать рамкой или по одной строке и после нажатия [Enter] все делалось само. Ну уж извиняйте... Потом доработаем с учетом пожеланий и "защиту от дурака" сделаем.

Код:

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

(defun c:tal (/ strDist vlaText1 texAlign1 textBasePt1
	      vlaText2 texAlign2 textBasePt2 ptList
	      newPoint
	      )
  (setvar "cmdecho" 0)
  (vl-load-com)
  (command "_.undo" "_BE")
(setq strDist (getdist "Specify or enter string distanse: "))
  (terpri)
  (setq vlaText1(vlax-ename->vla-object(car(entsel "Specify text "))))
	(terpri)
	  (setq texAlign1 (vla-get-Alignment vlaText1)
	        textBasePt1 (vla-get-InsertionPoint vlaText1)
	  );end setq
  (while T
        (setq vlaText2(vlax-ename->vla-object(car(entsel "Specify text "))))
	      (terpri)
	  (setq texAlign2 (vla-get-Alignment vlaText2)
	        textBasePt2 (vla-get-InsertionPoint vlaText2)
	      ); end setq
      (if(/= texAlign1 texAlign2)
	(vla-put-Alignment vlaText2 texAlign1)
	); end if
 (setq ptList (vlax-safearray->list(vlax-variant-value textBasePt1))
       newPoint(vlax-3D-point (list (car ptList)
				    (-(cadr ptList) strDist) (nth 2 ptList)))
       ); end setq
    (vla-put-InsertionPoint vlaText2 newPoint) 
    	  (setq texAlign1 (vla-get-Alignment vlaText2)
	        textBasePt1 (vla-get-InsertionPoint vlaText2)
		); end setq
      ); end while
    ); end tal

[Vova]

Fantomas> lisp не загружается:
Command: _appload tal.lsp successfully loaded.
Command: ; error: bad argument type: numberp: nil
Command:

[{Smirnoff}]

>Vova
Я его поправлял, судя по всему ЛИСП уже висел и вы скопировали нерабочий вариант. Скопируйте еще раз, я сейчас попробовал все прекрасно работает.

[Pilot]

>Vova
Децствительно не работает. И никак не пойму почему. Постараюсь разобраться.

[vk]

Раскопал небольшой Лиспик, которым как то пользовался. Распределяет текстовые примитивы равномерно между первым (наибольшее значение Y) и последним (наименьшее Y). Можно изменить одну функцию для отслеживания X. Текущая ПСК не учитывается.

Код:

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

;; распределение текстовых примитивов равномерно между первым и последним
;; учитывая координату Y
(defun trovno (/ ss l:tdat l:ins l:sort i:sort spt ept n m q dat ins)
  (princ "\nВыберите текстовые примитивы >")
  (setq ss (ssget '((0 . "TEXT"))))
  (if (> (sslength ss) 2)
    (progn
      (while (> (sslength ss) 0)
        (setq l:tdat (cons (entget (ssname ss 0)) l:tdat))
        (ssdel (ssname ss 0) ss)
      ) ;_  while
      (setq l:ins (mapcar '(lambda (x) (cdr (assoc 10 x))) l:tdat))
      (setq i:sort (vl-sort-i (mapcar 'cadr l:ins) '<)) ; для X заменить 'cadr на 'car
      (while i:sort
        (setq l:sort (cons (nth (car i:sort) l:tdat) l:sort))
        (setq i:sort (cdr i:sort))
      ) ;_  while
      (setq spt (cdr (assoc 10 (car l:sort))))
      (setq ept (cdr (assoc 10 (last l:sort))))
      (setq n 1)
      (setq m (length l:sort))
      (setq q (mapcar '/ (mapcar '- ept spt) (list (1- m) (1- m) (1- m))))
      (while (< n m)
        (setq dat (nth n l:sort))
        (setq ins (mapcar '+ (mapcar '* q (list n n n)) spt))
        (if (and (zerop (cdr (assoc 72 dat))) (zerop (cdr (assoc 73 dat))))
          (entmod (subst (cons 10 ins) (assoc 10 dat) dat))
          (progn
            (setq v11 (mapcar '- (cdr (assoc 11 dat)) (cdr (assoc 10 dat))))
            (entmod (subst (cons 10 ins)
                           (assoc 10 dat)
                           (subst (cons 11 (mapcar '+ ins v11)) (assoc 11 dat) dat)
                    ) ;_  subst
            ) ;_  entmod
          ) ;_  progn
        ) ;_  if
        (setq n (1+ n))
      ) ;_  while
    ) ;_  progn
  ) ;_  if
) ;_  defun


(trovno)

[Vova]

Ребята, проверьте лисп VK У меня он загружается одноразово. И сразу же запрашивает строки текста. Для вторичного вызова надо опять загружать. Выравнивает строки текста между первой и последней равномерно, это мне нравится. Если получaется слишком тесно или широко можно подвинуть первую или последнюю строку и повторить операцию. Одновременно выравнивает их начала по линии между первой и последней строкой, что на мой взгляд вряд ли нужно. По лиспу от Fantomas'a пока ничего не скажу, завел личную переписку. Проверьте его кто-нибудь, pls.

[Эдуард]

С лиспом VK вроде все нормально.
Однако он оформлен не как команда и к имени функции нужно
обращаться в скобках (trovno)
Для того , чтобы он не выполнялся сразу после загрузки уберите в
файле последнюю строку -(trovno)

[vk]

>Vova
Этот лисп я писал когда то что называется на скорую руку и использовал всего несколько раз... Надо было распределить равномерно вдоль линии. Ну не пригодился он больше
Вам, нужно сдвигать тексты только по Y, а по X и Z оставлять как есть? Тогда миииинимальнейшая доработка: добавте одну строку, чтоб получилось так

(setq ins (mapcar '+ (mapcar '* q (list n n n)) spt))
(setq ins (list (cadr (assoc 10 dat)) (cadr ins) (cadddr (assoc 10 dat))))
(if (and ....

Последнюю строку можно выкинуть, как говорит Эдуард, а в первой имя функции начать с C:
(defun c:trovno (/....
тогда можно делать вызов с командной строки как вызов обычной команды, без скобок.

PS: А такой автоматический запуск (вызов функции в последней строке программы) мне кажется очень удобным для "одноразовых" функций, которые используются очень-очень редко. Раскопал файлик, перетащил его прям из проводника в окно АКАДа - функция без дополнительных запросов начнет выполняться.

[{Smirnoff}]

Листинг снят, потому что обнаружен "глюк". Поспешишь, людей насмешишь....

[Pilot]

Сообщение от Vova Pilot>... Что значит "позволяет выбрать об-екты и отсортировывает из них текст" Какие объекты?...

Можно выбрать любые объекты. НЕ-текстовые объекты отфильтровываются программой и дальше она работает только с текстом. Если в набор текст не попал, то будет предложено снова выбрать объекты.

Вроде теперь заработало. В чем была ошибка я так и не понял.

Код:

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

(defun C:Stext ( / a2 c1 g1 g2 h1 h2 j2 l1 l2 p1 p2 s1 t1 y1 y2);
(while (not s1)
   (princ "\nSelect text.")
   (setq s1 (ssget (list (cons 0 "TEXT")))));while
(setq s1 (SortXY (SortXY s1 'x) 'y)
      y1 (getvar "clayer")
      h1 (getvar "textsize")
      g1 (getvar "textstyle")
      c1 0)
(repeat (sslength s1)
   (setq l1 (entget (ssname s1 c1))
         l2 (cons (cdr (assoc 1 l1)) l2)
         p1 (if p1 p1 (cdr (assoc 10 l1)))
         p2 (if p2 p2 (cdr (assoc 11 l1)))
         y2 (if y2 y2 (cdr (assoc  8 l1)))
         h2 (if h2 h2 (cdr (assoc 40 l1)))
         g2 (if g2 g2 (cdr (assoc  7 l1)))
         j2 (if j2 j2 (cdr (assoc 72 l1)))
         a2 0
         c1 (1+ c1))
);repeat
(setvar "cmdecho" 0)
(command "_erase" s1 "")
(setvar "clayer" y2)(setvar "textstyle" g2)(Osmo 0)
(foreach t1 (reverse l2)
   (if (= j2 0)
      (command "_text" p1 h2 (RtoG a2) t1)
      (command "_text" "_c" p2 h2 (RtoG a2) t1))
   (setq p1 (polar p1 (- a2 (GtoR 90))(* h2 2))
         p2 (polar p2 (- a2 (GtoR 90))(* h2 2))))
(setvar "clayer" y1)(setvar "textstyle" g1)(setvar "textsize" h1)
(Osmo nil)
(princ));c:Stext

(defun SortXY (s1 ord / c1 s2 x1 x2 n1)
(setvar "cmdecho" 1)
(if ord
   (progn
      (setq s2 (ssadd))
      (while (> (sslength s1) 0)
         (setq c1 0 x1 nil n1 nil)
         (repeat (sslength s1)
            (if (not n1)(setq n1 0))
            (setq l1 (entget (ssname s1 c1))
                  x2 (if (= ord 'x)
                        (car  (cdr (assoc 10 l1)))
                        (cadr (cdr (assoc 10 l1)))))
            (if (not x1)(setq x1 x2))
            (if (= ord 'x)
               (if (<  x2 x1)(setq x1 x2 n1 c1))
               (if (>  x2 x1)(setq x1 x2 n1 c1)))
            (setq c1 (1+ c1)))
         (setq s2 (ssadd (ssname s1 n1) s2))
         (ssdel (ssname s1 n1) s1)));progn
   (setq s2 (if (and (> (sslength s1) 1) T)
               (SortXY (SortXY s1 'x) 'y) s1));setq
);if
s2);SortXY

(defun GtoR (grad)(* grad (/ pi 180.0)));GtoR

(defun RtoG (rad)(* rad (/ 180.0 pi)));RtoG

(defun Osmo (v1);global osmo0
(cond ((and v1 osmo0)(setvar "osmode" 0))
      (v1 (setq osmo0 (getvar "osmode"))(setvar "osmode" 0))
      (osmo0 (setvar "osmode" osmo0)(setq osmo0 nil)))
(princ));Osmo

[Vova]

Считается классикой создавать блок в слое 0 и цветом.. послою. Или по-блоку (для продвинутых). Но это, вероятно, правильно, если блочки небольшие. Они могут вставлятся в разные слои и брать их свойства. Но, бывает, блок создается из многих объектов, даже из всего чертежа, и не предназначен вставляться в определенный слой и брать его свойства. В этом блоке все разноцветное и разных типов/весов линии. И вот, допустим, получаю такой блок от смежников и мне надо его перекрасить в нейтральный цвет, но оставить нетронутыми слои (не превращать в 0) и их цвета, и типы линий. Больше того, чтобы была возможность выборочно перекрашивать объекты в блоке. То есть одним тычком окрасил весь блок в нужный цвет, а затем бы последовал вопрос: СЭР, не хотите ли что-нибудь еще? После радостного YES гарсон выносит палитру цветов, я выбираю нужный и тычу куда надо. И при этом тычок добирается до самого внутреннего блока, если он вложенный.
Нужны-ли кому, кроме меня, такие фантазии?

[Alaspher]

Сообщение от Vova ...мне надо его перекрасить в нейтральный цвет, но оставить нетронутыми слои (не превращать в 0) и их цвета, и типы линий. Больше того, чтобы была возможность выборочно перекрашивать объекты в блоке. То есть одним тычком окрасил весь блок в нужный цвет, а затем бы последовал вопрос: СЭР, не хотите ли что-нибудь еще? После радостного YES гарсон выносит палитру цветов, я выбираю нужный и тычу куда надо. И при этом тычок добирается до самого внутреннего блока, если он вложенный.

Делал подобное, уже просили юзеры, правда не в виде одной функции, а двумя отдельными:

Код:

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

(defun c:blcc () (pl:block-color) (princ))
(defun c:encc () (pl:block-ent-color) (princ))

(defun pl:block-ent-color (/ adoc blocks color ent lays)
    (setq adoc  (vla-get-activedocument (vlax-get-acad-object))
          lays  (vla-get-layers adoc)
          color (acad_colordlg 256)
    )
    (if color
        (progn (setvar "errno" 0)
               (vla-startundomark adoc)
               (while (and (not (vl-catch-all-error-p
                                    (setq ent (vl-catch-all-apply
                                                  (function nentsel)
                                                  '("\nSelect entity <Exit>:")
                                              )
                                    )
                                )
                           )
                           (/= 52 (getvar "errno"))
                      )
                   (if ent
                       (progn (setq ent (vlax-ename->vla-object (car ent))
                                    lay (vla-item lays (vla-get-layer ent))
                              )
                              (if (= (vla-get-lock lay) :vlax-true)
                                  (progn (setq layloc (cons lay layloc))
                                         (vla-put-lock lay :vlax-false)
                                  )
                              )
                              (vl-catch-all-apply (function vla-put-color) (list ent color))
                              (vla-regen adoc acallviewports)
                       )
                       (princ "\nNothing selection! Try again.")
                   )
               )
               (foreach i layloc (vla-put-lock i :vlax-true))
               (vla-endundomark adoc)
        )
    )
    (princ)
)

(defun pl:block-color (/ adoc blocks color ins lays)
    (setq adoc   (vla-get-activedocument (vlax-get-acad-object))
          blocks (vla-get-blocks adoc)
          lays   (vla-get-layers adoc)
          color  (acad_colordlg 256)
    )
    (if color
        (progn (setvar "errno" 0)
               (vla-startundomark adoc)
               (while (and (not (vl-catch-all-error-p
                                    (setq ins (vl-catch-all-apply
                                                  (function entsel)
                                                  '("\nSelect block <Exit>:")
                                              )
                                    )
                                )
                           )
                           (/= 52 (getvar "errno"))
                      )
                   (if ins
                       (progn (setq ins (vlax-ename->vla-object (car ins)))
                              (if (= (vla-get-objectname ins) "AcDbBlockReference")
                                  (if (vlax-property-available-p ins 'path)
                                      (princ "\nThis is external reference! Try pick other.")
                                      (progn (_pl:block-color blocks ins color lays)
                                             (vla-regen adoc acallviewports)
                                      )
                                  )
                                  (princ "\nThis isn't block! Try pick other.")
                              )
                       )
                       (princ "\nNothing selection! Try again.")
                   )
               )
               (vla-endundomark adoc)
        )
    )
    (princ)
)

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
    (vlax-for e (vla-item blocks (vla-get-name ins))
        (setq lay (vla-item lays (vla-get-layer e)))
        (if (= (vla-get-freeze lay) :vlax-true)
            (progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false))
        )
        (if (= (vla-get-lock lay) :vlax-true)
            (progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false))
        )
        (vl-catch-all-apply (function vla-put-color) (list e color))
        (if (and (= (vla-get-objectname e) "AcDbBlockReference")
                 (not (vlax-property-available-p e 'path))
            )
            (_pl:block-color blocks e color lays)
        )
        (foreach i layfrz (vla-put-freeze i :vlax-true))
        (foreach i layloc (vla-put-lock i :vlax-true))
    )
)

(progn (princ "\nType 'BLCC' or 'ENCC' for start.") (princ))

*WARNING* Особо не тестировалось - с местом применения этих функций постоянного контакта нет, может и проскочили какие глюки.

*Корректировка по замечанию №1.
*Корректировка блокировки ошибки №2.

[Лентяй]

Эх, опередили меня ! Но все равно, у меня лучче и, главное - изячнее Правда, без обработки ошибок и под 2005-й, иак что не обессудьте [sm2100]

Код:

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

(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 "Ну и ладушки!"))
);defun
;
(defun C:Blk_Pntr ( / adoc util bks kw blk bk1)
  (vl-load-com)
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))
        util (vla-get-Utility adoc)
        bks (vla-get-Blocks adoc))
  (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)))
               (vlax-for ent (setq bk1 bk) (vla-put-color ent 9))))
        (vla-regen adoc acAllViewports)));if
    );if
  (if (req "Красить бум") (pnt bk1) (princ))
);end

[Alaspher]

Сообщение от Лентяй у меня лучче и, главное - изячнее

Не покушаясь на изысканную изячность, робко поинтересуюся, а хде обработка блокировок/заморозок слоёв? :roll:

[Лентяй]

А лениво мне ! Впрочем, если вы такой зануда, дпржите 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

[Alaspher]

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

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

Ну и если лениво, так может и не перенапрягаться?

[Елпанов Евгений]

>Alaspher
>Лентяй
Поясните мне пожалуйста, зачем в этом коде нужен обработчик заблокированных или замороженных слоев?
Вы же работаете с описанием блоков, те. вам не страшны замороженные слои и при изменении цвета всех элементов блока, они все перекрасятся, не зависимо от состояния слоев!
Ведь состояние слоев, это атрибуты вставок блоков, но не описаний...

[Кулик Алексей aka kpblc]

Не совсем. Попробуй сделать так:

Код:

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

(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".

[Alaspher]

Вообще, теоретически влиять не должно, но у меня не раз вылезала ошибка именно при обработке примитивов блоков на замороженных/заблокированных слоях. С тех пор взял за правило размораживать и разблокировать перед "употреблением"

[Елпанов Евгений]

так и есть, замороженные слои, нормально обрабатываются, а заблокированные вызывают ошибку...

[Alaspher]

Сообщение от Елпанов Евгений так и есть, замороженные слои, нормально обрабатываются, а заблокированные вызывают ошибку...

Не удивлюсь, если разные версии АКАДа ведут себя по разному в этом отношении.

[Vova]

Код от Alaspher
работает хорошо, но есть один существенный недостаток: не делается Undo. Можно ли исправить?
Коду от Лентяя я предложил блок из всего чертежа, и он стал его регенерировать минут 5. Ничего не покрасил. Тогда я сделал рядом маленький блок и ткнул в него. И опять весь чертеж стал регенерироваться много раз. Вынес маленький блок на отдельный чертеж, На этот раз регенерации не было, но не покрасилось

[Кулик Алексей aka kpblc]

> Vova : странно. По коду метки есть.

[PL]

Сообщение от Vova И при этом тычок добирается до самого внутреннего блока, если он вложенный. Нужны-ли кому, кроме меня, такие фантазии?

вероятно эти большие блоки получились из xref?
Перекраска меня очень интересует, но глобальная , А могут эти коды красить обьекты из ADT?

[Alaspher]

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

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

Сообщение от PL А могут эти коды красить обьекты из ADT?

Нет, элементы АДТ вообще не работают адекватно со свойством - Color! Кстати, очень хорошо, что спросил об этом - изменил код, что бы он не вылетал на таких элементах.

[Vova]

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

[Vova]

Кто помнит, здесь пробегал лисп, который может поменять начало и конец отрезка. Дело в том, что имеются типы линий с буквами, и надо чтобы они не были вверх ногами. А рисовать иногда приходиться с неправильного конца, а потом переворачивать

[Krieger]

Vova
http://dwg.ru/dnl/607

[ShaggyDoc]

Сообщение от 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 любым способом.

[Vova]

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

[Nike]

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

Код:

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

 (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: info@jtbworld.com
;;;
;;; 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)
)

[Vova]

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

Nike, пребольшое спасибо

[CRISTOFF]

Offtop:

Сообщение от Vova кликнув на рамку впорт-а в пространстве листа, получить его контур в пространстве модели

а в каких случаях в работе этот контур нужен? Что с ним потом делаете?

[Vova]

Сообщение от CRISTOFF а в каких случаях в работе этот контур нужен? Что с ним потом делаете?

Просто чтобы знать какой участок в пространстве модели попал во Vport. Работаем ведь мы в моделе а чертеж выводится в простр. листа. Бывает, надо уточнить границы видового экрана чтобы не обрезать лишнего или добавить чего. Например, сейчас я работаю над разбивкой электрического плана жилого этажа по отдельным квартирам, чтобы на стройке могли работать несколько бригад поквартирно. Контуры квартир довольно сложные, они внедряются друг в друга. Полигональные рамки в-портов, спроецированные в пространство модели, хорошо помогают ориентироваться.
У нас на работе есть подобный лисп, но он работает только с прямоугольными экранами. Но зато он переводит полученную в модели рамку экрана в особый непечатаемый слой который можно не удалять. Могут ли наши умельцы подправить VPL и VPO чтобы контур попал во вновь образованный непечатный слой, как я просил в н-р 36?