• G_RAV
  • Восстановленный участник
  • На форуме с 5 марта 2008г.
  • Сообщений: 35
  • Спасибо: 0

Тема: Разбивочный чертеж

Извините, что начинаю надоедать, но я только вчера случайно нарвался на этот сайт, чему очень рад, а вопросов немерено. Вообще я геодезист, сейчас работаю в землеустройстве, и для данного вида работ пытаюсь немного "программировать" в LISP'е, иногда получается, но зачастую не очень!
В землеустроительном деле есть один фрагмент, который называется "разбивочный чертеж" с ним всегда больше всего мороки.
Сижу уже вечность, "колдую" в LISP'е и ни как не могу сообразить , как сделать автоматический подпись линий:
-допустим из одной точки выходит несколько линий, требуется одной линии присвоить начальное значение 000гр 00'00", а всем оставшимся значения углов между этой начальной линией по часовой стрелке (круг право). Значение угла + расстояние отрезка должны текстом лечь по каждой линии.

  • Donhuan
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 25 февраля 2008г.
  • Сообщений: 169
  • Спасибо: 0

Re: Разбивочный чертеж

Что-то вроде этого. Писал наскору руку, по-этому размер текста - 5, надписи на концах линий и повернуты на такой же угол (от 90 до 270 градусов вверх ногами), но это несложно исправить саму или я исправлю когд время появится. Может и еще какие ошибки есть.
(vl-load-com)
(setq select nil mspace nil)
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(defun c:geo_angle ()
           (if (vl-catch-all-error-p
    (vl-catch-all-apply
    'gp:line_angle))
    (progn
    (mapcar '(lambda(x)(vla-Highlight x :vlax-false)) (mapcar 'vlax-ename->vla-object select))
      (print "Выполнение функции прервано.")
    ))
(setq select nil)
(princ)
)
(defun gp:line_angle (/ f_line start_point zero_angle start end angle_line out_list real_angle x)
    (setq out_list '())
      (princ "\nУкажите линии:")
      (setq select (ssget '((0 . "LINE")))); выбор линий
      (setq select (vl-remove-if 'listp (mapcar (function cadr) (ssnamex select)))); извлечение из набора ename в список
      (mapcar '(lambda(x)(vla-Highlight x :vlax-true)) (mapcar 'vlax-ename->vla-object select)); подсветка списка
        (princ "\nУкажите начальную линию:")
    (setq f_line (ssname (ssget ":S") 0))
      (setq start_point (getpoint "Укажите точку схождения линий:"))
    (if (cdr select); проверка наличия в списке более одной линии
      (progn
        (setq zero_angle (angle
                   (if (equal start_point (cdr (assoc 10 (entget f_line))) 0.01)
                               (cdr (assoc 10 (entget f_line)))
                               (cdr (assoc 11 (entget f_line))))   
                               (if (equal start_point (cdr (assoc 10 (entget f_line))) 0.01)
                               (cdr (assoc 11 (entget f_line)))
                               (cdr (assoc 10 (entget f_line))))
                 )
        )
        (while
          (progn
            (setq x (car select))
              (setq start (if (equal start_point (cdr (assoc 10 (entget x))) 0.01)
                                     (cdr (assoc 10 (entget x)))
                                     (cdr (assoc 11 (entget x)))))   
                (setq end   (if (equal start_point (cdr (assoc 10 (entget x))) 0.01)
                                     (cdr (assoc 11 (entget x)))
                                     (cdr (assoc 10 (entget x)))))
            (setq real_angle (angle start end))
            (setq angle_line (if (= x f_line) (angtos 0 1 6)
                                      (if (and (<= real_angle zero_angle) (>= real_angle 0))
                              (angtos (abs (- real_angle zero_angle)) 1 6)
                                   (angtos (- (* 2 pi) (- real_angle zero_angle)) 1 6)
                              )
            ))
            (setq out_list (cons  (list x start end real_angle angle_line) out_list))
            (vla-Highlight (vlax-ename->vla-object x) :vlax-false)
            (redraw x)
            (setq select (cdr select))
         )
        )
        (gp:draw_text out_list)
    )
       )
)
(defun gp:draw_text (out_list / vla_name_text x); отрисовка текста
(while
  (progn
   (setq x (car out_list))
   (setq vla_name_text (vla-addtext mspace (strcat (rtos (distance (cadr x) (caddr x))) " " (last x)) (vlax-3d-point (caddr x)) 5)); вывод текста
   (vla-rotate vla_name_text (vlax-3d-point (caddr x)) (cadddr x))
   (setq out_list (cdr out_list))
  )
)
)
(princ "\nЗапуск программы: geo_angle.")

  • G_RAV
  • Восстановленный участник
  • На форуме с 5 марта 2008г.
  • Сообщений: 35
  • Спасибо: 0

Re: Разбивочный чертеж

Текст исправил с 5 на 0.8 - самое элементарное наверное! Но вот только текст "левой стороны окружности" нужно поворачивать на 180гр., тут нужен либо отдельный макрос на кнопку, чтоб текст на 180 поворачивать либо условия накладывать в "line_angle". И хотелось бы чтоб в углах в место "d" было "%%d" тогда он правильно градусы показывает (кружком). В минутах, если до 10'  0 не пишет (и кстати  "Dimension" почему то так же отображает), а хотелось бы чтобы корректно угол выглядел! Ну и секунды округление до целых! И можно ли сделать цвет этому тексту серый, ну скажем "Color253".
P.S. А в целом супер!!! Работает так как я и хотел! Автоматизация полная!

  • Donhuan
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 25 февраля 2008г.
  • Сообщений: 169
  • Спасибо: 0

Re: Разбивочный чертеж

Добавил:
- задание масштабного коэффициента для длины линий;
- задание высоты текста;
- цвет текста серый (можно поменять в коде);
- правильный поворот текста;
- отображение знака градус вместо d.
Вроде углы тоже правильно отображает проверял вплоть до угла в 30 секунд.
(vl-load-com)
(defun c:geo_angle (/ select mspace)
        (setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
           (if (vl-catch-all-error-p
    (vl-catch-all-apply
    'gp:line_angle))
    (progn
    (mapcar '(lambda(x)(vla-Highlight x :vlax-false)) (mapcar 'vlax-ename->vla-object select))
      (print "Выполнение функции прервано.")
    ))
        (princ)
)
(defun gp:line_angle (/ count p_string f_line start_point zero_angle start end angle_line out_list real_angle text_h scale_l x)
    (setq out_list '())
      (princ "\nУкажите линии:")
      (setq select (ssget '((0 . "LINE")))); выбор линий
      (setq select (vl-remove-if 'listp (mapcar (function cadr) (ssnamex select)))); извлечение из набора ename в список
      (mapcar '(lambda(x)(vla-Highlight x :vlax-true)) (mapcar 'vlax-ename->vla-object select)); подсветка списка
        (princ "\nУкажите начальную линию:")
    (setq f_line (ssname (ssget ":S") 0))
      (setq start_point (getpoint "Укажите точку схождения линий:"))
    (princ "\nВведите масштабный коэффициент для длины линий:")
      (initget 7)
    (setq scale_l (getreal))
      (princ "\nВведите величину высоты текста:")
      (initget 7)
    (setq text_h (getreal))
    (if (cdr select); проверка наличия в списке более одной линии
      (progn
        (setq zero_angle (angle
                   (if (equal start_point (cdr (assoc 10 (entget f_line))) 0.01)
                               (cdr (assoc 10 (entget f_line)))
                               (cdr (assoc 11 (entget f_line))))   
                               (if (equal start_point (cdr (assoc 10 (entget f_line))) 0.01)
                               (cdr (assoc 11 (entget f_line)))
                               (cdr (assoc 10 (entget f_line))))
                 )
        )
        (while
          (progn
            (setq x (car select))
              (setq start (if (equal start_point (cdr (assoc 10 (entget x))) 0.01)
                                     (cdr (assoc 10 (entget x)))
                                     (cdr (assoc 11 (entget x)))))   
                (setq end   (if (equal start_point (cdr (assoc 10 (entget x))) 0.01)
                                     (cdr (assoc 11 (entget x)))
                                     (cdr (assoc 10 (entget x)))))
            (setq real_angle (angle start end))
            (setq angle_line (if (= x f_line) (angtos 0 1 4)
                                      (if (and (<= real_angle zero_angle) (>= real_angle 0))
                              (angtos (abs (- real_angle zero_angle)) 1 4)
                                   (angtos (- (* 2 pi) (- real_angle zero_angle)) 1 4)
                              )
            ))
            (setq count 0)
            (setq p_string "")
            (while
              (progn
            (setq count (+ count 1))
            (setq p_string (strcat p_string (if (= (substr angle_line count 1) "d"); замена символа
                                  "%%d"; на заданый
                                  (substr angle_line count 1)))
            )
            (/= (substr angle_line (+ count 1) 1) "")
              )
            )
            (setq angle_line p_string)
            (setq out_list (cons  (list x start end real_angle angle_line) out_list))
            (vla-Highlight (vlax-ename->vla-object x) :vlax-false)
            (redraw x)
            (setq select (cdr select))
         )
        )
        (gp:draw_text out_list text_h scale_l)
    )
       )
)
(defun gp:draw_text (out_list text_h scale_l / vla_name_text x); отрисовка текста
(while
  (progn
   (setq x (car out_list))
   (setq vla_name_text (vla-addtext mspace (strcat (rtos (* scale_l (distance (cadr x) (caddr x))) 2 2) " " (last x)) (vlax-3d-point (caddr x)) text_h)); вывод текста
   (if (and (<= (cadddr x) (* pi 1.5)) (> (cadddr x) (/ pi 2))); поворот текста
     (progn
       (vla-rotate vla_name_text (vlax-3d-point (caddr x)) (+ (cadddr x) pi))
       (vlax-put-property vla_name_text "Alignment" acAlignmentRight)
       (vlax-put-property vla_name_text "TextAlignmentPoint" (vlax-3d-point (caddr x)))
     )
      (progn
       (vla-rotate vla_name_text (vlax-3d-point (caddr x)) (cadddr x))
       (vlax-put-property vla_name_text "Alignment" acAlignmentLeft)
     )
   )
   (vla-put-color vla_name_text 253); задание цвета текста
   (setq out_list (cdr out_list))
  )
)
)
(princ "\nЗапуск программы: geo_angle.")

  • G_RAV
  • Восстановленный участник
  • На форуме с 5 марта 2008г.
  • Сообщений: 35
  • Спасибо: 0

Re: Разбивочный чертеж

Спасибо большое, Donhuan!!! Все в идеале!! Задание масштабного коэффициента для длины линий-это вообще мысль. Только я хочу переделать на задание масштаба, "кричишь" масштаб чертежа и в соответствии с ним проставляются длины линий! Надеюсь справлюсь :)! Еще раз спасибо!!

  • yri
  • Восстановленный участник
  • На форуме с 26 ноября 2007г.
  • Сообщений: 39
  • Спасибо: 0

Re: Разбивочный чертеж

а какой порядок работы сэтим кодом? подгоузил его пишет "выбрать" выбираю но ничего не происходит

  • Donhuan
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 25 февраля 2008г.
  • Сообщений: 169
  • Спасибо: 0

Re: Разбивочный чертеж

Вопрос звучал: "допустим из одной точки выходит несколько линий, требуется одной линии присвоить начальное значение 000гр 00'00", а всем оставшимся значения углов между этой начальной линией по часовой стрелке (круг право). Значение угла + расстояние отрезка должны текстом лечь по каждой линии".
Программа работет с примитивами типа "Line", полилинии не выбираются.
Выбираешь линии, которые надо обработать, потом  указываешь линию, которая будет начальной, потом точку из которой линии выходят и т.д - любуешся результатом ).

  • yri
  • Восстановленный участник
  • На форуме с 26 ноября 2007г.
  • Сообщений: 39
  • Спасибо: 0

Re: Разбивочный чертеж

Я конечно извиняюсь , делаю как вы писали-выбираю линии-выбирает Пробую выбирать начальную точку- пишет (выбрано повторно) и ступор. Помогите.

  • Donhuan
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 25 февраля 2008г.
  • Сообщений: 169
  • Спасибо: 0

Re: Разбивочный чертеж

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

  • yri
  • Восстановленный участник
  • На форуме с 26 ноября 2007г.
  • Сообщений: 39
  • Спасибо: 0

Re: Разбивочный чертеж

А теперь после выбора линий и нажатия ВВод. - все действия заканчиваются.Может где в тексте кода какая "запятая" пропущена? Вот я вам надоел?

  • G_RAV
  • Восстановленный участник
  • На форуме с 5 марта 2008г.
  • Сообщений: 35
  • Спасибо: 0

Re: Разбивочный чертеж

2 yri
Все прекрасно работает!
1. Выбери все линии исходящие из одной точки
[Enter]
2. Выбери одну линию начальную
[Enter]
3. Укажи коэфициент (масштабный)
[Enter]
4. Укажи высоту текста
[Enter]
!! Наслаждайся результатом....

  • G_RAV
  • Восстановленный участник
  • На форуме с 5 марта 2008г.
  • Сообщений: 35
  • Спасибо: 0

Re: Разбивочный чертеж

Пропустил....после 2-го пункта "укажи точку выхода всех линий"

  • yri
  • Восстановленный участник
  • На форуме с 26 ноября 2007г.
  • Сообщений: 39
  • Спасибо: 0

Re: Разбивочный чертеж

После выбора линий и нажатия ввод все заканчивается.(расширение файла *.LSP)Может какие настройки в Акаде у меня не установлены?

  • Donhuan
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 25 февраля 2008г.
  • Сообщений: 169
  • Спасибо: 0

Re: Разбивочный чертеж

Возможно проблема в том, что программа работает только с примитивами "Line", а у Вас полилинии, соответственно они не выбираются (не выделяются на чертеже после выбора) и после нажатия ввод происходит выход из функции по ошибке: должно быть написано "Выполнение функции прервано".

  • yri
  • Восстановленный участник
  • На форуме с 26 ноября 2007г.
  • Сообщений: 39
  • Спасибо: 0

Re: Разбивочный чертеж

Да нет , именно с примитивом "линия" пытаюсь делать.Выбираю эти линии, делаю ввод и мне пишет "выполнение функции прервано"
Линии на чертеже выделяются(подсвечены) и после ввода все.
Блин - что может быть?

  • Donhuan
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 25 февраля 2008г.
  • Сообщений: 169
  • Спасибо: 0

Re: Разбивочный чертеж

Начертите линии, которые Вы собираетесь обработать и вышлите мне файл на мыло igkiv@tut.by. Укажите версию Acada, в которой Вы работаете. Посмотрю у себя, что за проблема.

  • Donhuan
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 25 февраля 2008г.
  • Сообщений: 169
  • Спасибо: 0

Re: Разбивочный чертеж

Посмотрел твой файл в 2008 acade - все работает.
Попробуй переделать заглавную функцию вот так и посмотри, что за ошибка появляется.
(vl-load-com)
(defun c:geo_angle (/ select mspace)
        (setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
           (gp:line_angle)
    (princ)
)

  • yri
  • Восстановленный участник
  • На форуме с 26 ноября 2007г.
  • Сообщений: 39
  • Спасибо: 0

Re: Разбивочный чертеж

Пишет ошибка по (gp:line_angle)

  • VVA
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 29 марта 2006г.
  • Сообщений: 1,859
  • Спасибо: 25

Re: Разбивочный чертеж

Судя по всему у Donhuan английская версия Автокада, а у тебя русская
Замени (ssget ":S") на (ssget "_:S") в (gp:line_angle).
Должно помочь, если в остальном все верно

  • Donhuan
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 25 февраля 2008г.
  • Сообщений: 169
  • Спасибо: 0

Re: Разбивочный чертеж

Да не учел в программе этот момент, наверное все дело в нем.

  • yri
  • Восстановленный участник
  • На форуме с 26 ноября 2007г.
  • Сообщений: 39
  • Спасибо: 0

Re: Разбивочный чертеж

Ну наконец то заработало.Только результат пишет в конце линий, а как чтоб в середине и длина - над линией а угол под линией? Или это уже круто?

  • Donhuan
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 25 февраля 2008г.
  • Сообщений: 169
  • Спасибо: 0

Re: Разбивочный чертеж

Сейчас текст в центре линии, длина над линией, угод под линией.
Добавлен параметр смещения текста относительно линии для предотвращения сливания его с линией.

(vl-load-com)
(defun c:geo_angle (/ select mspace)
  (setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
  (if (vl-catch-all-error-p
    (vl-catch-all-apply
      'gp:line_angle))
    (progn
      (mapcar '(lambda(x)(vla-Highlight x :vlax-false)) (mapcar 'vlax-ename->vla-object select))
      (print "Выполнение функции прервано.")
    ))
(princ)
)
(defun gp:line_angle (/ count p_string f_line start_point zero_angle start
              end angle_line out_list real_angle text_h scale_l x step_line)
  (setq out_list '())
  (princ "\nУкажите линии:")
  (setq select (ssget '((0 . "LINE"))))    ; выбор линий
  (setq    select (vl-remove-if 'listp(mapcar (function cadr) (ssnamex select)))); извлечение из набора ename в список
  (mapcar '(lambda (x) (vla-Highlight x :vlax-true)) (mapcar 'vlax-ename->vla-object select)); подсветка списка
  (princ "\nУкажите начальную линию:")
  (setq f_line (ssname (ssget "_:S") 0))
  (setq start_point (getpoint "Укажите точку схождения линий:"))
  (princ "\nВведите масштабный коэффициент для длины линий:")
  (initget 7)
  (setq scale_l (getreal))
  (princ "\nВведите величину высоты текста:")
  (initget 7)
  (setq text_h (getreal))
  (princ "\nВведите величину смещения между текстом и линией:")
  (initget 7)
  (setq step_line (getreal))
  (if (cdr select); проверка наличия в списке более одной линии
    (progn
      (setq zero_angle (angle
        (if (equal start_point (cdr (assoc 10 (entget f_line))) 0.01)
          (cdr (assoc 10 (entget f_line)))
          (cdr (assoc 11 (entget f_line))))
        (if (equal start_point (cdr (assoc 10 (entget f_line))) 0.01)
          (cdr (assoc 11 (entget f_line)))
          (cdr (assoc 10 (entget f_line))))
      ))
      (while
         (progn
           (setq x (car select))
           (setq start (if (equal start_point (cdr (assoc 10 (entget x))) 0.01)
                         (cdr (assoc 10 (entget x)))
                         (cdr (assoc 11 (entget x)))))
           (setq end (if (equal start_point (cdr (assoc 10 (entget x))) 0.01)
                       (cdr (assoc 11 (entget x)))
                       (cdr (assoc 10 (entget x)))))
           (setq real_angle (angle start end))
           (setq angle_line (if (= x f_line) (angtos 0 1 4)
           (if (and (<= real_angle zero_angle) (>= real_angle 0))
             (angtos (abs (- real_angle zero_angle)) 1 4)
             (angtos (- (* 2 pi) (- real_angle zero_angle)) 1 4)
           )
      ))
      (setq count 0)
      (setq p_string "")
      (while
        (progn
          (setq count (+ count 1))
          (setq p_string (strcat p_string (if (= (substr angle_line count 1) "d"); замена символа
                                            "%%d"; на заданый
                                            (substr angle_line count 1))))
          (/= (substr angle_line (+ count 1) 1) "")
      ))
      (setq angle_line p_string)
      (setq out_list (cons (list x start end real_angle angle_line) out_list))
      (vla-Highlight (vlax-ename->vla-object x) :vlax-false)
      (redraw x)
      (setq select (cdr select))
    )
  )
  (gp:draw_text out_list text_h scale_l)
)))
(defun gp:draw_text (out_list text_h scale_l / vla_name_text x center_line); отрисовка текста
(while
  (progn
    (setq x (car out_list))
    (setq center_line (polar (cadr x) (cadddr x) (/ (distance (cadr x) (caddr x)) 2)))
    (setq vla_name_text (vla-addtext mspace
    (rtos (* scale_l (distance (cadr x) (caddr x))) 2 2)  (vlax-3d-point center_line) text_h)); вывод текста
    (gp:rotate_text vla_name_text center_line acAlignmentBottomCenter x step_line)
    (setq vla_name_text (vla-addtext mspace
    (last x)  (vlax-3d-point center_line) text_h)); вывод текста
    (gp:rotate_text vla_name_text center_line acAlignmentTopCenter x step_line)
    (setq out_list (cdr out_list))
   )
)
)
(princ "\nЗапуск программы: geo_angle.")
(defun gp:rotate_text (vla_name_text center_line alignment x step_line / tng_angle half_line gippot)
    (setq half_line (/ (distance (cadr x) (caddr x)) 2)); половина линии между старт и конец
    (setq gippot (sqrt (+ (expt step_line 2) (expt half_line 2))))
    (setq tng_angle (atan step_line half_line)); угол для смещения текста от линии (предотвращение сливания с линией)
    (if (and (<= (cadddr x) (* pi 1.5)) (> (cadddr x) (/ pi 2))); поворот текста
      (progn
        (vla-rotate vla_name_text (vlax-3d-point center_line) (+ (cadddr x) pi))
        (vlax-put-property vla_name_text "Alignment" alignment)
    (if (= alignment acAlignmentTopCenter)
      (vlax-put-property vla_name_text "TextAlignmentPoint" (vlax-3d-point (polar (cadr x) (+ (cadddr x) tng_angle) gippot)))
      (vlax-put-property vla_name_text "TextAlignmentPoint" (vlax-3d-point (polar (cadr x) (- (cadddr x) tng_angle) gippot)))
    )
      )
      (progn
        (vla-rotate vla_name_text (vlax-3d-point center_line) (cadddr x))
        (vlax-put-property vla_name_text "Alignment" alignment)
    (if (= alignment acAlignmentTopCenter)
      (vlax-put-property vla_name_text "TextAlignmentPoint" (vlax-3d-point (polar (cadr x) (- (cadddr x) tng_angle) gippot)))
      (vlax-put-property vla_name_text "TextAlignmentPoint" (vlax-3d-point (polar (cadr x) (+ (cadddr x) tng_angle) gippot)))
    )
      )
    )
  (vla-put-color vla_name_text 253); задание цвета текста
)

  • yri
  • Восстановленный участник
  • На форуме с 26 ноября 2007г.
  • Сообщений: 39
  • Спасибо: 0

Re: Разбивочный чертеж

Спасиб за отклик.Но опять "но", После команды ( nВведите величину смещения между текстом и линией) происходит прекращение выполнения проги.(Акад 2007 Рус) Иеще уж. Если можно то чтоб полученный результат (№ исходной точки, 0- направление и т.д вывести в Ехеl)? (Во оборзел)

  • Donhuan
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 25 февраля 2008г.
  • Сообщений: 169
  • Спасибо: 0

Re: Разбивочный чертеж

Попробуй так. Добавил вывод в файл.

(vl-load-com)
(defun c:geo_angle (/ select mspace)
  (setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
  (if (vl-catch-all-error-p
    (vl-catch-all-apply
      'gp:line_angle))
    (progn
      (mapcar '(lambda(x)(vla-Highlight x :vlax-false)) (mapcar 'vlax-ename->vla-object select))
      (print "Выполнение функции прервано.")
    ))
(princ)
)
(defun gp:line_angle (/ count p_string f_line start_point zero_angle start
          end angle_line out_list real_angle text_h scale_l x step_line)
  (setq out_list '())
  (princ "\nУкажите линии:")
  (setq select (ssget '((0 . "LINE"))))  ; выбор линий
  (setq  select (vl-remove-if 'listp(mapcar (function cadr) (ssnamex select)))); извлечение из набора ename в список
  (mapcar '(lambda (x) (vla-Highlight x :vlax-true)) (mapcar 'vlax-ename->vla-object select)); подсветка списка
  (princ "\nУкажите начальную линию:")
  (setq f_line (ssname (ssget "_:S") 0))
  (setq start_point (getpoint "Укажите точку схождения линий:"))
  (princ "\nВведите масштабный коэффициент для длины линий:")
  (initget 7)
  (setq scale_l (getreal))
  (princ "\nВведите величину высоты текста:")
  (initget 7)
  (setq text_h (getreal))
  (princ "\nВведите величину смещения между текстом и линией:")
  (initget 7)
  (setq step_line (getreal))
  (setq zero_angle (angle
        (if (equal start_point (cdr (assoc 10 (entget f_line))) 0.01)
          (cdr (assoc 10 (entget f_line)))
          (cdr (assoc 11 (entget f_line))))
        (if (equal start_point (cdr (assoc 10 (entget f_line))) 0.01)
          (cdr (assoc 11 (entget f_line)))
          (cdr (assoc 10 (entget f_line))))
      ))
      (while
         (progn
           (setq x (car select))
           (setq start (if (equal start_point (cdr (assoc 10 (entget x))) 0.01)
                         (cdr (assoc 10 (entget x)))
                         (cdr (assoc 11 (entget x)))))
           (setq end (if (equal start_point (cdr (assoc 10 (entget x))) 0.01)
                       (cdr (assoc 11 (entget x)))
                       (cdr (assoc 10 (entget x)))))
           (setq real_angle (angle start end))
           (setq angle_line (if (= x f_line) (angtos 0 1 4)
           (if (and (<= real_angle zero_angle) (>= real_angle 0))
             (angtos (abs (- real_angle zero_angle)) 1 4)
             (angtos (- (* 2 pi) (- real_angle zero_angle)) 1 4)
           )
      ))
      (setq count 0)
      (setq p_string "")
      (while
        (progn
          (setq count (+ count 1))
          (setq p_string (strcat p_string (if (= (substr angle_line count 1) "d"); замена символа
                                            "%%d"; на заданый
                                            (substr angle_line count 1))))
          (/= (substr angle_line (+ count 1) 1) "")
      ))
      (setq out_list (cons (list x start end real_angle p_string angle_line) out_list)); имя линии, стартовая точка, конечная точка,
                                                  ;угол относительно оси х, вычисленный угол со знаком градус, вычисленный угол в стандарте acad-a
      (vla-Highlight (vlax-ename->vla-object x) :vlax-false)
      (redraw x)
      (setq select (cdr select))
    )
  )
  (gp:draw_text out_list text_h scale_l)
  (gp:out_file out_list scale_l)
)
(defun gp:draw_text (out_list text_h scale_l / vla_name_text x center_line); отрисовка текста
(while
  (progn
    (setq x (car out_list))
    (setq center_line (polar (cadr x) (cadddr x) (/ (distance (cadr x) (caddr x)) 2)))
    (setq vla_name_text (vla-addtext mspace
    (rtos (* scale_l (distance (cadr x) (caddr x))) 2 3)  (vlax-3d-point center_line) text_h)); вывод текста
    (gp:rotate_text vla_name_text center_line 13 x step_line)
    (setq vla_name_text (vla-addtext mspace
    (last x)  (vlax-3d-point center_line) text_h)); вывод текста
    (gp:rotate_text vla_name_text center_line 7 x step_line)
    (setq out_list (cdr out_list))
   )
)
)
(princ "\nЗапуск программы: geo_angle.")
(defun gp:rotate_text (vla_name_text center_line alignment x step_line / tng_angle half_line gippot)
    (setq half_line (/ (distance (cadr x) (caddr x)) 2)); половина линии между старт и конец
    (setq gippot (sqrt (+ (expt step_line 2) (expt half_line 2))))
    (setq tng_angle (atan step_line half_line)); угол для смещения текста от линии (предотвращение сливания с линией)
    (if (and (<= (cadddr x) (* pi 1.5)) (> (cadddr x) (/ pi 2))); поворот текста
      (progn
        (vla-rotate vla_name_text (vlax-3d-point center_line) (+ (cadddr x) pi))
        (vlax-put-property vla_name_text "Alignment" alignment)
  (if (= alignment acAlignmentTopCenter)
    (vlax-put-property vla_name_text "TextAlignmentPoint" (vlax-3d-point (polar (cadr x) (+ (cadddr x) tng_angle) gippot)))
    (vlax-put-property vla_name_text "TextAlignmentPoint" (vlax-3d-point (polar (cadr x) (- (cadddr x) tng_angle) gippot)))
  )
      )
      (progn
        (vla-rotate vla_name_text (vlax-3d-point center_line) (cadddr x))
        (vlax-put-property vla_name_text "Alignment" alignment)
  (if (= alignment acAlignmentTopCenter)
    (vlax-put-property vla_name_text "TextAlignmentPoint" (vlax-3d-point (polar (cadr x) (- (cadddr x) tng_angle) gippot)))
    (vlax-put-property vla_name_text "TextAlignmentPoint" (vlax-3d-point (polar (cadr x) (+ (cadddr x) tng_angle) gippot)))
  )
      )
    )
  (vla-put-color vla_name_text 253); задание цвета текста
)
(defun gp:out_file (out_list scale_l / d_file x prec mode)
  (setq d_file (open (getfiled "Файл результата" "" "xls" 1) "w"))
  (setq prec 3); точность отображения координат
  (setq mode 2); режим отображения координат
  (write-line "Начальная точка (x)\tНачальная точка (y)\tНачальная точка (z)\tКонечная точка (x)\tКонечная точка (y)\tКонечная точка (z)\tДлина\tУгол относительно оси x\tВычисленный угол" d_file)
  (while
    (progn
      (setq x (car out_list))
      (write-line (strcat (rtos (caadr x) mode prec) "\t" (rtos (cadadr x) mode prec) "\t" (rtos (car (cddadr x)) mode prec) "\t"
              (rtos (caaddr x) mode prec) "\t" (rtos (car (cdaddr x)) mode prec) "\t" (rtos (cadr (cdaddr x)) mode prec) "\t"
              (rtos (* scale_l (distance (cadr x) (caddr x))) mode prec) "\t" (angtos (cadddr x) 1 4) "\t" (cadr (cddddr x))) d_file)
      (setq out_list (cdr out_list))
     )
   )
  (close d_file)
)

  • yri
  • Восстановленный участник
  • На форуме с 26 ноября 2007г.
  • Сообщений: 39
  • Спасибо: 0

Re: Разбивочный чертеж

Ступор на том же месте. Происходит вылет после указания величины смещения текста от линии.