[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: