[MA2]

Не МОГУ БОЛЬШЕ. Помогите. Пришли чертежи от смежной организации, а там большая проблема с привязками. Такое ощущение, что они рисуют на глазок. А привязки не используют совсем. Можно ли это исправить? Я не селен в лиспах, АРХ, но очень хочется воплотить такую идею. Координаты вершин, полилиний или линий, центров окружностей,точки вставок блоков переносились в новое положение, с их округлением (например, 5 мм) в мировой системе координат. Т.е. если координата вершины полилинии имеет (25.0096, -86.1156, 0.0064) чтоб после выполнения программы вершина полилинии центр окружности, или точка вставоки блока, имели такие координаты (25.000, 85.000, 0,000).Спасибо за любой совет

[MA2]

Все что я смог найти это такой код программы, от господина kpblc (defun c:round-coord (/ selset item x_round y_round z_round point vla_point)

(vl-load-com)
(if (not *kpblc-activedoc*)
(setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
) ;_ end of if
(vla-startundomark *kpblc-activedoc*)
(setq counter 0
selset (ssget '((0 . "POINT")))
) ;_ end of setq
(if selset
(progn
(setq x_round (getint "\nКоличество знаков после запятой для X <0> : "))
(if (not x_round)
(setq x_round 0)
(setq x_round (abs x_round))
) ;_ end of if
(setq
y_round (getint (strcat "\nКоличество знаков после запятой для Y <"
(itoa x_round)
"> : "
) ;_ end of strcat
) ;_ end of getint
) ;_ end of setq
(if (not y_round)
(setq y_round x_round)
(setq y_round (abs y_round))
) ;_ end of if
(setq
z_round (getint (strcat "\nКоличество знаков после запятой для Z <"
(itoa x_round)
"> : "
) ;_ end of strcat
) ;_ end of getint
) ;_ end of setq
(if (not z_round)
(setq z_round x_round)
(setq z_round (abs z_round))
) ;_ end of if
(while (and selset
(> (sslength selset) 0)
) ;_ end of and
(setq item (ssname selset 0))
(ssdel item selset)
(setq item (vlax-ename->vla-object item)
point (vlax-safearray->list
(vlax-variant-value (vla-get-coordinates item))
) ;_ end of vlax-safearray->list
vla_point (vlax-make-safearray vlax-vbdouble '(0 . 2))
) ;_ end of setq
(vlax-safearray-fill
vla_point
(list (atof (rtos (car point) 2 x_round))
(atof (rtos (cadr point) 2 y_round))
(atof (rtos (caddr point) 2 z_round))
) ;_ end of list
) ;_ end of vlax-safearray-fill
(vla-put-coordinates item vla_point)
) ;_ end of while
) ;_ end of progn
) ;_ end of if
(vla-regen *kpblc-activedoc* acallviewports)
(vla-endundomark *kpblc-activedoc*)
) ;_ end of defun

но он только для точек, может, кто поможет на основании его сделать выравнивание вершин для полилиний, линий, центров окружностей, и точек вставок блоков

[Лентяй]

Сообщение от MA2 Не МОГУ БОЛЬШЕ. Помогите. Пришли чертежи от смежной организации, а там большая проблема с привязками. Такое ощущение, что они рисуют на глазок. А привязки не используют совсем. Можно ли это исправить? Я не селен в лиспах, АРХ, но очень хочется воплотить такую идею. Координаты вершин, полилиний или линий, центров окружностей,точки вставок блоков переносились в новое положение, с их округлением (например, 5 мм) в мировой системе координат. Т.е. если координата вершины полилинии имеет (25.0096, -86.1156, 0.0064) чтоб после выполнения программы вершина полилинии центр окружности, или точка вставоки блока, имели такие координаты (25.000, 85.000, 0,000).Спасибо за любой совет

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

Код:

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

(defun put (pt / cc)
  (setq cc (mapcar '(lambda (x y) (atof (rtos x 2 y)))
             (vlax-safearray->list (vlax-variant-value (if (wcmatch (vla-get-ObjectName it) "*Polyline,*Leader")
                                                         (vlax-get-property it pt n) (vlax-get-property it pt)))) prc))
  (if (not (wcmatch (vla-get-ObjectName it) "*Polyline,*Leader"))
    (vlax-put-property it pt (vlax-3d-point cc))
    (vlax-put-property it pt n
      (if (wcmatch (vla-get-ObjectName it) "*DPolyline,*Leader") (vlax-3d-point cc)
        (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble '(0 . 1)) cc)))));if
);end
;
(defun C:CrdRndUp (/ adoc csp mod prc n)
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (mapcar '(lambda (x y) (set x (vlax-get-property adoc y))) '(util ms ps)
    '(Utility ModelSpace PaperSpace))
  (vla-startundomark adoc)
  (vla-InitializeUserInput util 128 "Вместе Порознь")
  (setq mod (vla-getKeyword util "Округлять координаты [Вместе/Порознь]: ? <Вместе>")
        prc0 (if (null prc0) 0 prc0))
  (if (= mod "") (setq mod "Вместе"))
  (if (= mod "Вместе")
    (progn (setq prc0 (if (listp prc0) (car prc0) prc0))
      (if (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
            (setq prc (vla-getInteger util (strcat "Количество знаков после запятой <" (itoa prc0) "> : " ))))))
        (setq prc prc0));if
      (setq prc (list prc prc prc)));progn
    (setq prc0 (if (not (listp prc0)) (list prc0 prc0 prc0) prc0)                 
          prc (mapcar '(lambda (x y / z) (if (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
                 (setq z (vla-getInteger util (strcat "Количество знаков после запятой для " x " <" (itoa y) "> : " ))))))
                 (setq z y) (setq y z))) '("X" "Y" "Z") prc0)));if
  (setq prc0 prc)
  (foreach sp (list ms ps)
      (vlax-for it sp
        (cond ((wcmatch (vla-get-ObjectName it) "*Circle,*Ellipse,*Arc") (put "Center"))
              ((wcmatch (vla-get-ObjectName it) "*Ttext,*BlockReference") (put "InsertionPoint"))
              ((wcmatch (vla-get-ObjectName it) "*Line") (mapcar '(lambda (x) (put x)) '(StartPoint EndPoint)))              
              ((wcmatch (vla-get-ObjectName it) "*Polyline,*Leader") (setq n 0)
               (while (<= n (1- (vlax-curve-getEndParam it))) (put "Coordinate") (setq n (1+ n))))
              (t nil))
        ));foreach
  (vla-regen adoc acallviewports)
  (vla-endundomark adoc) 
);end

И пжалста, доложь о результатах.

[SkiFF]

Сообщение от Лентяй И пжалста, доложь о результатах.

Как запустить то

[SkiFF]

А допустим вариант для выбраных объектов. При чем с жестким требованием выбора объектов округления, а то можно весь чертеж испортить.
И буду благодарить ......

[Лентяй]

Сообщение от SkiFF Сообщение от Лентяй И пжалста, доложь о результатах. Как запустить то

Да как обычно. Копируешь прогу в Notepad, сохраняешь гдн-нить с расширением .lsp, затем appload и печатаешь в коммандной сторке CrdRndUp, жмешь Enter, и будет тебе щястя

[Лентяй]

Сообщение от SkiFF А допустим вариант для выбраных объектов. При чем с жестким требованием выбора объектов округления, а то можно весь чертеж испортить. И буду благодарить ......

Можно, но DCL ваять не буду. А выбор из командной строки - это пжалста.

[MA2]

РЕЗУЛЬТАТЫ/
Странно, но у меня ничего не заработало
1. ПОСЛЕ команды "CRDRNDUP" идет запрос "Округлять координаты [Вместе/Порознь]: ?" затем еще один запрос "Количество знаков после запятой <1> :". на этом обращение с пользователем заканчивается. Дальше появляется вот такие надписи "Command: Regenerating model." и "Command: nil"
Все. Как-то осталось без внимания момент выбора объектов.
И простите мою наглость но можно сразу задать что количество знаков после запетой всегда равно "0", а в место этого лучше вести вопрос до какого целого число округлять. (например округлить до 5 мм, или до 1 метра).
Уважаемый Лентяй, за ту помощь, которую оказываете Вы нам оказываете, Вас не возможно забыть. Внутренняя чистота чертежей будет всегда мне напоминать о Вас.

[MA2]

Уважаемый Лентяй, приношу Вам свои извинения. Все работает, вершины точек линий переносятся в новое положение, блоки то же, окружности также, Вот только первая вершина полилиний остается на месте и не изменяется. И не сочти те меня нахалом но можно все же сделать выбор объектов, и выбор степени округления?

[Лентяй]

Сообщение от MA2 РЕЗУЛЬТАТЫ/ Странно, но у меня ничего не заработало 1. ПОСЛЕ команды "CRDRNDUP" идет запрос "Округлять координаты [Вместе/Порознь]: ?" затем еще один запрос "Количество знаков после запятой <1> :". на этом обращение с пользователем заканчивается. Дальше появляется вот такие надписи "Command: Regenerating model." и "Command: nil" Все. Как-то осталось без внимания момент выбора объектов.

А чего бы вы хотели? "Вместе/Порознь" определяет, округляются ли координаиы по X, Y и Z вместе или по отдельности. :twisted:
А если вам нужен выбор объектов, то держите доработку.

Код:

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

(defun put (pt / cc)
  (setq cc (mapcar '(lambda (x y) (atof (rtos x 2 y)))
             (vlax-safearray->list (vlax-variant-value (if (wcmatch (vla-get-ObjectName it) "*Polyline,*Leader")
                                                         (vlax-get-property it pt n) (vlax-get-property it pt)))) prc))
  (if (not (wcmatch (vla-get-ObjectName it) "*Polyline,*Leader"))
    (vlax-put-property it pt (vlax-3d-point cc))
    (vlax-put-property it pt n
      (if (wcmatch (vla-get-ObjectName it) "*DPolyline,*Leader") (vlax-3d-point cc)
        (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble '(0 . 1)) cc)))));if
);end
;
(defun rnd (ss / it)
  (vlax-for it ss
        (cond ((wcmatch (vla-get-ObjectName it) "*Circle,*Ellipse,*Arc") (put "Center"))
              ((wcmatch (vla-get-ObjectName it) "*Text,*BlockReference") (put "InsertionPoint"))
              ((wcmatch (vla-get-ObjectName it) "*Line") (mapcar '(lambda (x) (put x)) '(StartPoint EndPoint)))              
              ((wcmatch (vla-get-ObjectName it) "*Polyline,*Leader") (setq n 0)
               (while (<= n (1- (vlax-curve-getEndParam it))) (put "Coordinate") (setq n (1+ n))))
              (t nil)))
);rnd
;
(defun C:CrdRndUp (/ adoc ass ms ps mod prc n opt1 opt2)
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (mapcar '(lambda (x y) (set x (vlax-get-property adoc y))) '(ass util ms ps)
    '(ActiveSelectionSet Utility ModelSpace PaperSpace))
  (if (> (vla-get-count ass) 0) (vla-clear ass))
  (vla-startundomark adoc)
  (vla-InitializeUserInput util 128 "Вместе Порознь")
  (setq mod (vla-getKeyword util "Округлять координаты [Вместе/Порознь]: <Вместе>?")
        prc0 (if (null prc0) 0 prc0))
  (if (= mod "") (setq mod "Вместе"))
  (if (= mod "Вместе")
    (progn (setq prc0 (if (listp prc0) (car prc0) prc0))
      (if (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
            (setq prc (vla-getInteger util (strcat "Количество знаков после запятой <" (itoa prc0) "> : " ))))))
        (setq prc prc0));if
      (setq prc (list prc prc prc)));progn
    (setq prc0 (if (not (listp prc0)) (list prc0 prc0 prc0) prc0)                 
          prc (mapcar '(lambda (x y / z) (if (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
                 (setq z (vla-getInteger util (strcat "Количество знаков после запятой для " x " <" (itoa y) "> : " ))))))
                 (setq z y) (setq y z))) '("X" "Y" "Z") prc0)));if
  (setq prc0 prc)
  (vla-InitializeUserInput util 128 "Все ВЫбрать Тип")
  (setq opt1 (vla-getKeyword util "Выберете объекты: [Все/ВЫбрать]: <Все>"))
  (if (= opt1 "") (setq opt1 "Все"))
  (if (= opt1 "Все") (foreach sp (list ms ps) (rnd sp))
    (progn (vla-InitializeUserInput util 128 "Circle Ellipse Arc Text BlockReference Line Polyline Leader")
      (setq opt2 (vla-getKeyword util "Выбрать объекты по типу или <ENTER> для указания [Circle/Ellipse/Arc/Text/BlockReference/Line/Polyline/Leader]: "))
      (if (= opt2 "") (vla-selectOnScreen ass)
        (vla-select ass acSelectionSetAll nil nil (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0))
           (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list (strcat "*" opt2)))));if
      (rnd ass)));if
  (vla-regen adoc acallviewports)
  (vla-endundomark adoc) 
);end

Элемент бусурманщины определяется исключительно удобством написания кода. В противном случае пришлось бы перетолмачивать. а мне лениво .
Опять же, проьба доложито результатах, потому как проверять мне было снова лениво :twisted: :twisted:

И простите мою наглость но можно сразу задать что количество знаков после запетой всегда равно "0", а в место этого лучше вести вопрос до какого целого число округлять. (например округлить до 5 мм, или до 1 метра).

Я вам одну страшную тайну открою. Все координаты в АвтоКАДе - безразмерные. Размерность устанавливается при определении стиля размеров. Причем округление размеров может не совпадать с внутренними координатами АвтоКАДа.

[MA2]

Да знаю я, что нету в акаде нет размерности координат. Скажу так Нужна степень округления координат, измеряемая в единицах чертежа. Понятно, если чудик из ВК все чертит метрах, то округлять его координаты нужно до 0,005. Если архитектурная часть, где одна единица чертежа равна 1 миллиметру, 5 единиц измерения чертежа, я думаю достаточная точность.

[MA2]

Результат. Новый код, с выбором объектов, так же прекрасно работает, только вот все же последняя вершина полилинии не меняет свое положение

[SkiFF]

А вот бы еще чтобы округлять до 100 или до 1000 или до 10 или до 5 или до 37 и цены вам нет

[Лентяй]

Сообщение от MA2 Да знаю я, что нету в акаде нет размерности координат. Скажу так Нужна степень округления координат, измеряемая в единицах чертежа. Понятно, если чудик из ВК все чертит метрах, то округлять его координаты нужно до 0,005. Если архитектурная часть, где одна единица чертежа равна 1 миллиметру, 5 единиц измерения чертежа, я думаю достаточная точность.

Не понял, он что, все в пространстве листа все чертит, что-ли? Насколько я понимаю в медицине, он в этом случае бессильна. Однако, если копировать его ВКаки в пространство модели, есс-но, соот-но масштабируя, то кого волнует, какие единицы этот ВКакер использовал. А стиль размеров можно поменять, и будет всем щастя .

[MA2]

ВК чертит так, если есть длина 1 метр, в пространстве модели это 1 единица, а не 1000 как мне хотелось бы. Ладно ВК можно и отмасштабировать. НЕ проблема. Но как сделать так чтоб последняя вершина полилинии то же меняла свое положение, я не знаю Уважаемый Лентяй В коде программы который вы тут представили есть такая ошибка, не могли бы ВЫ это подправить. а то получается что все точки меняют свое положение, а последняя вершина полилинии нет. НЕ порядок И так глобально, возможно ли в лиспе организовать округление? что то вроде ROUND. Ели нужно всю идею переваривать на VBA?

[Лентяй]

Замените строку

Код:

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

(while (<= n (1- (vlax-curve-getEndParam it))) (put "Coordinate") (setq n (1+ n))))

на

Код:

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

 (while (<= (if (= (vla-get-closed it) :vlax-true) (1- n) n)
                          (vlax-curve-getEndParam it)) (put "Coordinate") (setq n (1+ n))))

и будет вам щастя

[MA2]

Щастье не случилось теперь если полилиния Closed, появляется такое сообщение "Automation Error. Invalid index", при состоянии полилинии open все работает, последняя точка меняет свое положение.

[Лентяй]

Ну, подумешь. напутал слегка, плюсб минус - делов-то... Попробуй так:

Код:

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

(while (<= (if (= (vla-get-closed it) :vlax-true) (1+ n) n) 
                          (vlax-curve-getEndParam it)) (put "Coordinate") (setq n (1+ n))))

[MA2]

Спасибо, действительно очень сильно помогли. Не знаю, что случилось, но первый вариант заработал, а второй выдает ошибку "Automation Error. Description was not provided", но при этом то же работает. Странно. . А по поводу степени округления координат, мне так и не понятно, возможно это реализовать на лиспе, или нет?

[Лентяй]

Сообщение от MA2 Спасибо, действительно очень сильно помогли. Не знаю, что случилось, но первый вариант заработал, а второй выдает ошибку "Automation Error. Description was not provided", но при этом то же работает. Странно. . А по поводу степени округления координат, мне так и не понятно, возможно это реализовать на лиспе, или нет?

Действительно, непонятка получаестя [sm2100]... У меня все работает, и безо всяких страшеых сообщений. Хотя с моим 2005, как ни странно, проходят всякие грязные трюки, типа присвоения символу знака или функции. МБ, 2006 более чувствителен к подобным насилиям. Впрочем, попробуйте такой более "правильный" варинт:

Код:

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

(while (<= n (- (vlax-curve-getEndParam it)
(if (= (vla-get-closed it) :vlax-true) 1 0)) (put "Coordinate") (setq n (1+ n))))

и, как обычно, плз, доложьте о результатах. Успехов [sm2200]
Что же касается округления до десятокв и сотен, да еще и с учетом с учетом единиц, то это требует отдельной программы.

[VVA]

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

Был в отпуске, поэтому чуть с запозданием.
http://forum.dwg.ru/showthread.php?p=26859#post26859 Alaspher №10
Текст приведу здесь

Код:

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

(defun pl:round (num digit / fact) 
  (setq fact 1.0) 
  (repeat (abs digit) (setq fact (* 10 fact))) 
  (if (minusp digit)(setq fact (/ 1.0 fact))) 
  (setq num (/ (fix (+ (* num fact) 0.5)) fact)) 
  (if (> 1 digit)(fix num) num))

Вырианты:
(pl:round 1234.346 2) -> 1234.35
(pl:round 1234.346 0) -> 1234
(pl:round 1266.346 -1) -> 1270
(pl:round 1266.346 -2) -> 1300

[Astartes]

Граждане приветствую. Вот код взятый отсюда http://www.caduser.ru/forum/index.ph...#message173683 и подправленный автором, скинул мне через личку, но у меня все равно не работает. Кто подскажет в чем дело.
Никакого округления не происходит. Как были координаты со знаками после запятой так они и остаются.
Никаких ошибок при выполение команды не происходит.
Автокад 2011, русский, леценз.

PS Выложу на всякий случай пример. В файле линия, у нее координата Х дробная. Хотелось бы ее округлить до целого значения.

Код:

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

(defun c:round-coord (/                          _kpblc-eval-nearest        _kpblc-ent-modify-autoregen
                      _kpblc-conv-list-to-2dpoints                          lst
                      round
                      )
  (defun _kpblc-conv-list-to-2dpoints (lst / res)
    (cond
      ((not lst)
       nil
       )
      (t
       (setq res (cons (list (car lst)
                             (if (cadr lst)
                               (cadr lst)
                               0.
                               ) ;_ end of if
                             ) ;_ end of list
                       (_kpblc-conv-list-to-2dpoints (cddr lst))
                       ) ;_ end of cons
             ) ;_ end of setq
       )
      ) ;_ end of cond
    res
    ) ;_ end of defun
 
  (defun _kpblc-ent-modify-autoregen (ent bit value ext_regen / ent_list old_dxf new_dxf layer_dxf70)
    (setq ent (_kpblc-conv-ent-to-ename ent))
    (if (not
          (and
            (or
              (= (strcase (cdr (assoc 0 (entget ent))) nil) "STYLE")
              (= (strcase (cdr (assoc 0 (entget ent))) nil) "DIMSTYLE")
              (= (strcase (cdr (assoc 0 (entget ent))) nil) "LAYER")
              ) ;_ end of or 
            (= bit 100)
            ) ;_ end of and 
          ) ;_ end of not 
      (progn
        (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 (not (equal 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
            (if ent_regen
              (entupd ent)
              (redraw ent)
              ) ;_ end of if
            ) ;_ end of progn 
          ) ;_ end of if 
        ) ;_ end of progn 
      ) ;_ end of if 
    ent
    ) ;_ end of defun
 
  (defun _kpblc-eval-nearest (value lst / x base)
    (if lst
      (progn
        (setq x    (car lst)
              base (abs (- value x))
              ) ;_ end of setq
        (foreach item (cdr lst)
          (if (> base (abs (- value item)))
            (setq x    item
                  base (abs (- value item))
                  ) ;_ end of setq
            ) ;_ end of if
          ) ;_ end of foreach
        ) ;_ end of progn
      (setq x value)
      ) ;_ end of if
    x
    ) ;_ end of defun
  (vl-load-com)
  (if (not *kpblc-activedoc*)
    (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of if
  (vla-startundomark *kpblc-activedoc*)
  (cond
    ((setq round
            (getreal "\nЗначение округления координат <Приводить к целым> : ")
           ) ;_ end of setq
     )
    (t (setq round 1.))
    ) ;_ end of cond
  (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget))))
    (vl-catch-all-apply
      (function
        (lambda ()
          (cond
            ((member (cdr (assoc 0 (entget ent))) '("POINT" "INSERT"))
             (_kpblc-ent-modify-autoregen
               ent
               10
               (mapcar '(lambda (x)
                          (_kpblc-eval-nearest
                            x
                            (list (* round (fix (/ x round)))
                                  (* round (1+ (fix (/ x round))))
                                  ) ;_ end of list
                            ) ;_ end of _kpblc-eval-nearest
                          ) ;_ end of lambda
                       (cdr (assoc 10 (entget ent)))
                       ) ;_ end of mapcar
               t
               )
             )
            ((member (cdr (assoc 0 (entget ent))) '("ARC" "CIRCLE"))
             (mapcar
               '(lambda (y)
                  (_kpblc-ent-modify-autoregen
                    ent
                    y
                    ((lambda (/ res)
                       (setq res
                              (mapcar '(lambda (x)
                                         (_kpblc-eval-nearest
                                           x
                                           (list (* round (fix (/ x round)))
                                                 (* round (1+ (fix (/ x round))))
                                                 ) ;_ end of list
                                           ) ;_ end of _kpblc-eval-nearest
                                         ) ;_ end of lambda
                                      (if (= (type (cdr (assoc y (entget ent)))) 'list)
                                        (cdr (assoc y (entget ent)))
                                        (list (cdr (assoc y (entget ent))))
                                        ) ;_ end of if
                                      ) ;_ end of mapcar
                             ) ;_ end of setq
                       (if (/= (type (cdr (assoc y (entget ent)))) 'list)
                         (setq res (car res))
                         ) ;_ end of if
                       res
                       )
                     )
                    t
                    )
                  )
               '(10 40)
               )
             )
            ((= (cdr (assoc 0 (entget ent))) "LINE")
             (mapcar '(lambda (y)
                        (_kpblc-ent-modify-autoregen
                          ent
                          y
                          (mapcar '(lambda (x)
                                     (_kpblc-eval-nearest
                                       x
                                       (list (* round (fix (/ x round)))
                                             (* round (1+ (fix (/ x round))))
                                             ) ;_ end of list
                                       ) ;_ end of _kpblc-eval-nearest
                                     ) ;_ end of lambda
                                  (cdr (assoc y (entget ent)))
                                  ) ;_ end of mapcar
                          t
                          ) ;_ end of _kpblc-ent-modify-autoregen
                        ) ;_ end of lambda
                     '(10 11)
                     ) ;_ end of mapcar
             )
            ((= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
             (vla-put-coordinates
               (vlax-ename->vla-object ent)
               (vlax-make-variant
                 (vlax-safearray-fill
                   (vlax-make-safearray
                     vlax-vbdouble
                     (cons 0
                           (1- (length (setq lst
                                              (mapcar
                                                '(lambda (x)
                                                   *
                                                   (_kpblc-eval-nearest
                                                     *
                                                     x
                                                     *
                                                     (list (* round (fix (/ x round)))
                                                           *
                                                           (* round (1+ (fix (/ x round))))
                                                           *
                                                           ) ;_ end of list
                                                     *
                                                     ) ; _ end of
                                                   *
                                                   ) ;_ end of lambda
                                                (vlax-safearray->list
                                                  *
                                                  (vlax-variant-value
                                                    *
                                                    (vla-get-coordinates
                                                      *
                                                      (vlax-ename->vla-object ent)
                                                      *
                                                      ) ;_ end of vla-get-coordinates
                                                    *
                                                    ) ;_ end of vlax-variant-value
                                                  *
                                                  ) ;_ end of vlax-safearray->list
                                                ) ;_ end of mapcar
                                             ) ;_ end of setq
                                       ) ;_ end of length
                               ) ;_ end of 1-
                           )
                     )
                   lst
                   )
                 )
               )
             )
            )
          )
        )
      )
    )
  (vla-endundomark *kpblc-activedoc*)
  (princ)
  ) ;_ end of defun

[Лиспер]

Закомментируй строку

Код:

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

(setq ent (_kpblc-conv-ent-to-ename ent))

Этой функции нет, да и не похоже, чтобы была нужна

[Astartes]

Лиспер,
А у тебя/вас заработало?
У меня нет. На всякий случай уточню, чтобы закомментировать строку нужно вначале строки поставить // ?

[Лиспер]

На "ты" ко мне, если можно.
Комментирование в лиспе - знак ";". Все, что за ним - не обрабатывается. После комментирования строки, про которую я говорил, все сработало на ура

[Astartes]

Лиспер, Огромное спасибо тебе. Ну и автору лиспа разумеется.
А в данном лиспе не заложено округление до заданного знака? Или только до целых?

[Лиспер]

Так лисп же спрашивает - до какой точности округлять. Вроде бы можно хоть до миллионных долей делать...

[Astartes]

Я просто не совсем понял как задать точность
Команда: ROUND-COORD
Значение округления координат <Приводить к целым> Что здесь написать если я хочу округлить до десятых?
Сори если вопрос тупой ))

Значение округления координат <Приводить к целым>0.1
Так ?

Вроде разобрался ))

[Лиспер]

Похоже на то. Я не проверял, надо автора кода ждать

[Агент СмиТ]

To Лентяй
Взял код из поста #10, всё работало (у меня AutoCad2011 x64), затем заменил строку из поста #18 изменений вроде не обнаружилось, а вот строка из поста #20 вызвала отказ в исполнении, пишет сообщение: неизвестная команда CrdRndUp.
Но суть вопроса в следующем: можно ли подправить программу, что бы в случае если отбрасываемая часть округляемого числа равна половине предыдущего разряда, то округление производиться до ближайшего четного. Например:
3.75 = 3.8
3.85 = 3.8
Существующий же алгоритм выполняет простое арифметическое округление 3.85 = 3.9
Заранее спасибо!

[АлексЮстасу]

Лентяй: программа задачу выполняет, спасибо! Но после нее почему-то резко уменьшилась рабочая область файла. И undo привело к глухому зависанию Автокада.
Еще сюрприз: при вызове программы CrdRndUp в пространстве листа, началось бесконечное ее выполнение, остановить которое удалось только Диспетчером задач.

[PsixVK]

здравствуйте проблема почти таже
ГПисты привыкли кирпичом в пещере на стенах рисовать - потом пересели на кульманы всех все устраивало
но сейчас век когда нужно рисовать четко и красиво тем более есть комп для этого
помогите пожалуйста
два лиспа которые здесь представлены работают, но какбы не совсем то что нужно, один просто округляет до количества знаков второй только с отрезками работает (((
в приложенном файле кусочек плана с очень не точными координатами
мне бы слепить результат тех двух лиспов в один и чтобы все работало

кстати что такое ординатный размер ГП не вкурсе - нужно самому координатную сетку с чертежом переносить кудой нужно

[VVA]

А этот? http://forum.dwg.ru/showthread.php?p=919890#post919890

[PsixVK]

Сообщение от VVA А этот? http://forum.dwg.ru/showthread.php?p=919890#post919890

в общем тоже самое что и тут в 22-м посте
работает только с линиями, а полилинии и остальное чет отказывается двигать

[vl74]

Да, программа в посте #22 не работает с полилиниями.
Как вариант - сохранять файл в dxf и тупо искать поля с координатами, далее округлять их.

[VVA]

Сообщение от Astartes подправленный автором, скинул мне через личку, но у меня все равно не работает. Кто подскажет в чем дело.

Сообщение от vl74 Да, программа в посте #22 не работает с полилиниями.

В LW полилинии нельзя через vla-put-coordinates менять сразу все координаты. Это не работает. Работает если обновлять по одной
Немного (процентов на 90 ) изменил код #22 Сделал обновление через entmod. Тестировал без фанатизма, должно работать.
PS. Убегаю регистрироваться на Сапряжение.
PPS Если не нужно округлять радиусы, то в строке

Код:

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

(if (member (car x) '(10 11 40)) ;_Начало (10); конец (11); точка вставки (10); радиус (40)

нужно удалить цифру 40

Код:

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

 
(defun c:RC (/ _kpblc-eval-nearest round)
;;;Round-Coord
;;;http://forum.dwg.ru/showthread.php?p=1181242#post1181242
;;;VVA for dwg.ru
  (defun _kpblc-eval-nearest (value lst / x base)
    (if lst
      (progn
        (setq x    (car lst)
              base (abs (- value x))
        ) ;_ end of setq
        (foreach item (cdr lst)
          (if (> base (abs (- value item)))
            (setq x    item
                  base (abs (- value item))
            ) ;_ end of setq
          ) ;_ end of if
        ) ;_ end of foreach
      ) ;_ end of progn
      (setq x value)
    ) ;_ end of if
    x
  ) ;_ end of defun
  (vl-load-com)
  (if (not *kpblc-activedoc*)
    (setq *kpblc-activedoc*
           (vla-get-activedocument (vlax-get-acad-object))
    ) ;_ end of setq
  ) ;_ end of if
  (vla-startundomark *kpblc-activedoc*)
  (cond
    ((setq round
            (getreal
              "\nЗначение округления координат <Приводить к целым> : "
            ) ;_ end of getreal
     ) ;_ end of setq
    )
    (t (setq round 1.))
  ) ;_ end of cond
  (foreach ent
           (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_:L"))))
    (vl-catch-all-apply
      (function
        (lambda ()
          (cond
            ((wcmatch (cdr (assoc 0 (entget ent)))
                      "LWPOLYLINE,LINE,ARC,CIRCLE,POINT,INSERT"
             ) ;_ end of wcmatch
             (entmod
               (mapcar
                 '(lambda (x)
                    (if (member (car x) '(10 11 40)) ;_Начало; конец; точка вставки; радиус
                      (vl-list*
                        (car x)
                        (if (listp (cdr x))
                          (mapcar
                            '(lambda (y)
                               (_kpblc-eval-nearest
                                 y
                                 (list (* round (fix (/ y round)))
                                       (* round (1+ (fix (/ y round))))
                                 ) ;_ end of list
                               ) ;_ end of _kpblc-eval-nearest
                             ) ;_ end of lambda
                            (cdr x)
                          ) ;_ end of mapcar
                          (_kpblc-eval-nearest
                            (cdr x)
                            (list (* round (fix (/ (cdr x) round)))
                                  (* round (1+ (fix (/ (cdr x) round))))
                            ) ;_ end of list
                          ) ;_ end of _kpblc-eval-nearest
                        ) ;_ end of if
                      ) ;_ end of VL-LIST*
                      x
                    ) ;_ end of if
                  ) ;_ end of lambda
                 (entget ent)
               ) ;_ end of mapcar
             ) ;_ end of entmod
             (entupd ent)
            )
            (t nil)
          ) ;_ end of cond
        ) ;_ end of lambda
      ) ;_ end of function
    ) ;_ end of vl-catch-all-apply
  ) ;_ end of foreach
  (vla-endundomark *kpblc-activedoc*)
  (princ)
) ;_ end of defun

[PsixVK]

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

[PsixVK]

здравствуйте
возник вопрос
а можно как то сделать так что бы припустим все линии и полинии были строго вертикально и строго горизонтально друг к другу и относительно МСК
для чего: припустим есть у нас генеральный план (реконструкция) там все сети, здания сделаны абы как под разными углами друг к другу. нужно с этого чуда сделать принципиальную схему тоесть сделать все упрощенно и ровненько (горизонтально и вертикально)
буду очень благодарен

[Дима_]

Код:

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

 (vl-load-com)
(defun c:rovno()
  ((lambda (p-pt doc lst)
     (vla-startundomark doc)
     (mapcar
       '(lambda (ent)
           (if (= (cdr (assoc 0 ent)) "LINE")
               (entmod (subst (cons 11 (apply 'p-pt (mapcar '(lambda (x) (cdr (assoc x ent))) '(10 11))))
                       (assoc 11 ent)
                       ent))
               ((lambda (frec) (entmod (frec (cdr (assoc 10 ent)) ent)))
                (lambda (pt lst)
                  (if lst (if (= (caar lst) 10)
                              ((lambda (pt) (cons (cons 10 pt) (frec pt (cdr lst))))
                               (p-pt pt (cdar lst)))
                              (cons (car lst) (frec pt (cdr lst)))))))))
       lst)
       (vla-endundomark doc))
   (lambda (pt1 pt2);p-pt - кладет на ближайшую ось
     (if (apply '> (mapcar 'abs (apply 'mapcar (cons '- (mapcar '(lambda (x) (list (car x) (cadr x))) (list pt1 pt2))))))
         (list (car pt2) (cadr pt1))
         (list (car pt1) (cadr pt2))))
   (vla-get-activedocument (vlax-get-acad-object))
   (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*LINE")))))))))

Как выравнивать последний сегмент замкнутой полилинии - я не придумал, доделывать не буду (разминка).

[Dant]

Проверял в AutoCAD 2011. И CrdRndUp и РС прекрасно работают . Единственное замечание - выносные размерные линии остаются с прежними координатами. Получается, что все размеры нужно вытирать и проставлять по новой, иначе выносные не совпадают с объектом образмеривания. Может уже и это можно подправить? Тогда действительно этим функциям цены не будет.

[PsixVK]

спасибо
то что доктор прописал )
а еще бы сделать что бы лиспик объкекты,которые были в цепочке, проецировало на одну прямую тоесть чтоб цепочка сохранялась

тоесть припустим линия(полилиния)+ окружность+линия(полилиния)+и т.д........ (проходящие под углом к МСК) так и оставались в цепочке но уже горизонтально или вертикально

[Tyhig]

Сообщение от VVA изменил код #22 Сделал обновление через entmod. Тестировал без фанатизма, должно работать

Добрый день.
У меня одного этот лисп не работает ?

Команда: rс Неизвестная команда "RС".

При загрузке лиспа пишет

Команда: _appload RC.lsp успешно загружено. Команда: ; ошибка: синтаксическая ошибка

Простите, у меня руки из жопы растут. Всё работает.

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

Возможно, скопировал не все (забыл скобку или две).

[VVA]

Чтобы "зациклить" темы Округление координат кратно значению

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

В таком случае продолжаем в той теме, а эту я закрываю )