Тема: LISP. Трассировка линий связи на плане
;************ TRASSA.LSP - Трассировка линии связи на плане ******
;
; Разработал Громов В.В. декабрь 2004.
;
(apply '(lambda ()
(setvar "cmdecho" 0)
(setq inf (getstring T "\n Служебная информация (объект, этаж, помещение и др.): "))
(setq fil (strcat (getvar "DWGPREFIX") (vl-filename-base (getvar "DWGNAME")) "_trs.txt"))
(setq nug (getpoint "\n Укажите начальную точку трассировки (ENTER-отказ): "))
(if nug
(progn
(if nug (setq tn nug))
(setq tug 0 dl_all 0)
(while tug
(setq tug (getpoint tn "\n Укажите следующую точку трассировки (ENTER-Закончить): "))
(if tug
(progn
(setq tk tug)
(grdraw tn tk 5 1)
(setq dlina (distance tn tk))
(princ "\n Длина текущего сегмента (мм): ") (princ dlina)
(setq dl_all (+ dl_all dlina))
(setq tn tk)
))
);while
(setq dl_all (/ dl_all 1000))
(princ "\n Суммарная длина всех сегментов (в метрах): ") (princ dl_all)
(alert (strcat "\n Суммарная длина всех сегментов (в метрах): " (rtos dl_all 2 1)))
(command "_redraw")
(setq fl (open fil "a"))
(princ "\n\n" fl)
(princ inf fl)
(princ "\n ----------------------------------------------" fl)
(princ (strcat "\n Суммарная длина всех сегментов (в метрах): " (rtos dl_all 2 1) "\n") fl)
(close fl)
(princ "\n Информация записана в файл: ") (princ fil)
) ;progn
(princ "\n Отказ.")
)
(setq nug nil tug nil tn nil tk nil dlina nil fl nil inf nil dl_all nil)
(princ)
)
'()
)Возможный макрос для кнопки или пункта меню:
^C^C^P(load "trassa")
После загрузки в память программа немедленно выполняется и выгружается из памяти, поэтому для повтора выполнения надо опять нажать на кнопку.
Информация будет записана в файл в ту же папку, в которой находится рисунок, и полный путь к этому файлу отобразится в командной строке.
