Тема: LISP. Удобная команда построения 3-х мерной полилинии.
Рискнул поместить её в "готовые", хотя тестирование должным образом не было проведено. Не судите строго. Если что - пишите, исправим.
; Команда построения 3-х мерной полилинии с дополнительными опциями управления текущей ПСК.
; Перед указанием каждой следующей вершины полилинии имеется возможность установить желаемую ориентацию осей ПСК.
; Опции командной строки похожи на опции команды UCS, но имеются особенности:
; 1. Точка начала ПСК всегда переносится в последнюю построенную вершину полилинии.
; Все изменения ПСК с помощью доступных опций касаются только направления её осей X и Y.
; Точка начала ПСК остается неизменной. Это позволяет задавать координаты вершин (кроме первой)
; с командной строки в абсолютных координатах (не используя @).
; 2. Oпция Above.
; Запрашивает смещение следующей вершины относительно последней построенной вдоль оси Z ПСК.
; Строит новую вершину и переносит в неё ПСК.
; 3. Опция ZDepth.
; Запрашивает смещение ПСК вдоль оси Z относительно последней вершины, переносит ПСК, но вершину не строит,
; а ждет указания точки уже в новой плоскости построений.
; 4. Опция Prev.
; Ориентирует оси текущей ПСК в соответствии с ориентацией осей ближайшей ПСК из списка отката, у которой
; направление осей не совпадает с текущим. Начало текущей ПСК остается неизменным.
; Загружать весь файл.
; Вызов с командной строки: 3DPLINE
;
;
(defun c:3dpline ( /
read-ucs; локальная функция.
ucs; список - состояние ПСК на момент вызова команды.
icon; текущее состояние системной переменной UCSICON.
)
; Определение локальной функции:
(defun read-ucs ( / org)
(setq org (getvar 'ucsorg))
(list org
(mapcar '+ (getvar 'ucsxdir) org)
(mapcar '+ (getvar 'ucsydir) org)
); return.
); end defun.
;
(begin-undo-group 0)
;
(setq icon (getvar 'ucsicon))
(setq ucs (read-ucs))
;
(vl-catch-all-apply 'brokenline)
;
; Восстановление исходной ПСК и видимости пиктограммы:
(setvar 'ucsicon 0)
(command "_.ucs" "_World" "_.ucs" "_3point" (car ucs) (cadr ucs) (caddr ucs))
(setvar 'ucsicon icon)
;
(end-undo-group)
(princ)
); end defun.
; BROKENLINE.
; Внешняя функция: READ-UCS.
; Внешняя переменная: icon - состояние системной переменной UCSICON на момент вызова команды.
; Переменная уровня документа: ::model_space - указатель пространства модели.
(defun brokenline ( /
pt; результат запроса точки.
brol; vla-указатель.
disp; смещение начала ПСК.
nullbase; точка (0.0 0.0 0.0).
org; точка начала ПСК.
act; список с информацией о последнем действии пользователя.
actions; список действий.
coords; список координат построенной полилинии.
)
(setq nullbase '(0.0 0.0 0.0))
(if (not ::model_space) (setq ::model_space (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))));
;
(initget "eXit")
(setq pt (getpoint "\nSpecify first vertex or [eXit] <exit>: "))
(if (or (not pt) (= pt "eXit")) (quit));
(setq actions (append (list (cons nil (read-ucs))) actions))
(command "_.ucs" "_Origin" pt)
(while pt
(initget 0 "Above ZDepth Top Bottom Front BAck Left Right X Y Z Prev Undo")
(setq pt (getpoint
nullbase
"\nSpecify next vertex or [Above/ZDepth/Top/Bottom/Front/BAck/Left/Right/X/Y/Z/Prev/Undo] <exit>: "
)
); setq.
(cond
((not pt)); конец построений.
((listp pt); указана точка:
(cond
(brol; добавляем новую вершину:
(setq actions (append (list (cons T (read-ucs))) actions))
(command "_.ucs" "_Origin" pt)
(vlax-invoke-method brol 'AppendVertex (vlax-3d-point (trans nullbase 1 0)))
(vlax-invoke-method brol 'update)
);
(T; создаем полилинию из 2х вершин:
(setq brol (vlax-invoke-method
::model_space
'Add3Dpoly
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble '(0 . 5))
(append (trans nullbase 1 0) (trans pt 1 0))
)
(+ vlax-vbarray vlax-vbdouble)
);
);
); setq.
(setq actions (append (list (cons T (read-ucs))) actions))
(command "_.ucs" "_Origin" pt)
);
); end cond.
);
((= pt "ZDepth"); указание на смещение ПСК вдоль оси Z:
(setq disp nil)
(while (not disp)
(initget 128)
(setq disp (getpoint "\nSpecify Z-elevation for new UCS origin: "))
(cond
((not disp) (princ "\nInvalid input. Please retry.")); пустой ввод. Повтор.
((listp disp) (setq disp (caddr disp)));
((numberp (setq disp (atof disp))));
(T (princ "\nInvalid input. Please retry.") (setq disp nil));
); end cond.
); end while.
(setq actions (append (list (cons nil (read-ucs))) actions))
(command "_.ucs" "_Move" "_Zdepth" disp)
);
((= pt "Above"); указание на построение следующей вершины смещением предыдущей по оси Z:
(setq disp nil)
(while (not disp)
(initget 128)
(setq disp (getpoint "Specify Z-elevation for next vertex: "))
(cond
((not disp) (princ "\nInvalid input. Please retry.")); пустой ввод. Повтор.
((listp disp) (setq disp (caddr disp)));
((numberp (setq disp (atof disp))));
(T (princ "\nInvalid input. Please retry.") (setq disp nil));
); end cond.
); end while.
(setq actions (append (list (cons T (read-ucs))) actions))
(command "_.ucs" "_Origin" (setq pt (list 0.0 0.0 disp)))
(vlax-invoke-method brol 'AppendVertex (vlax-3d-point (trans nullbase 1 0)))
(vlax-invoke-method brol 'update)
);
((wcmatch pt "[XYZ]"); поворот вокруг оси:
(setq ang (getreal (strcat "\nSpecify rotation angle about " pt " axis <0.0>: ")))
(cond
(ang
(setq actions (append (list (cons nil (read-ucs))) actions))
(command "_.ucs" (strcat "_" pt) ang)
);
); end cond.
);
((or (wcmatch (substr pt 1 1) "[TBFLRW]") (= pt "BAck"))
(setq actions (append (list (cons nil (read-ucs))) actions))
(setq org (getvar 'ucsorg))
(setvar 'ucsicon 0)
(command "_.ucs" (strcat "_" pt))
(setq org (trans org 0 1))
(command "_.ucs" "_Origin" org)
(setvar 'ucsicon icon)
);
((= pt "Prev")
(setq pt 0)
(setq act (car actions))
(while (and act (equal
(list (getvar 'ucsxdir) (getvar 'ucsydir))
(list (mapcar '- (caddr act) (cadr act)) (mapcar '- (cadddr act) (cadr act)))
1e-9; точность сравнения.
);
); and.
(setq pt (1+ pt))
(setq act (nth pt actions))
); end while.
(cond
(act; найдена ПСК в списке отката, которая отличается от текущей:
(setq org (getvar 'ucsorg))
(setq actions (append (list (cons nil (read-ucs))) actions))
(setvar 'ucsicon 0)
(command "_.ucs" "_World" "_.ucs" "_3point" (cadr act) (caddr act) (cadddr act))
(setq org (trans org 0 1))
(command "_.ucs" "_Origin" org)
(setvar 'ucsicon icon)
);
(T (princ "All previous UCSs not differs from current UCS."));
); end cond.
);
((= pt "Undo"); отмена последнего действия:
(setq act (car actions)); последнее зафиксированное действие.
(setq actions (cdr actions))
(cond
((car act); последним действием была добавлена вершина полилинии:
(setq coords (reverse (vlax-safearray->list (vlax-variant-value (vlax-get-property brol 'coordinates)))))
(cond
((= (length coords) 6); полилиния из oдного сегмента:
(vlax-invoke-method brol 'delete)
(vlax-release-object brol)
(setq brol nil)
);
(T; полилиния из 2х и более сегментов:
(vlax-invoke-method brol 'delete)
(vlax-release-object brol)
(setq coords (reverse (cdddr coords)))
(setq brol (vlax-invoke-method
::model_space
'Add3Dpoly
(vlax-make-variant
(vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length coords)))) coords)
(+ vlax-vbarray vlax-vbdouble)
);
);
); setq.
);
); end cond.
(setvar 'ucsicon 0)
(command "_.ucs" "_World" "_.ucs" "_3point" (cadr act) (caddr act) (cadddr act))
(setvar 'ucsicon icon)
);
(actions; изменялась только ПСК и список отката не пустой:
(setvar 'ucsicon 0)
(command "_.ucs" "_World" "_.ucs" "_3point" (cadr act) (caddr act) (cadddr act))
(setvar 'ucsicon icon)
);
(T
(setvar 'ucsicon 0)
(command "_.ucs" "_World" "_.ucs" "_3point" (cadr act) (caddr act) (cadddr act))
(setvar 'ucsicon icon)
(initget "eXit")
(setq pt (getpoint "\nSpecify first vertex or [eXit] <exit>: "))
(if (or (not pt) (= pt "eXit")) (quit));
(setq actions (append (list (cons nil (read-ucs))) actions))
(command "_.ucs" "_Origin" pt)
);
); end cond.
);
); end cond.
); end while.
(princ)
); end defun.
; BEGIN-UNDO-GROUP.
; Установка отметки начала группы команд.
; Возврат: набор объектов предварительного выбора или nil.
(defun begin-undo-group (mode; режим обработки набора предварительно выбранных объектов.
/
undo_state; текущая настройка команды UNDO.
ss; набор объектов предварительного выбора.
)
(cond
((= mode 0) (sssetfirst nil nil)); не разрешен предварительный выбор.
((= mode 1); команда может использовать набор предварительного выбора:
(if (and (setq ss (ssget "_I")) (= 0 (getvar 'pickfirst))) (sssetfirst nil nil)); end if.
);
((= mode 2); функция не меняет набор предварительного выбора:
(setq ss (ssget "_I"))
);
); end cond.
;
(setq undo_state (getvar 'undoctl))
(setvar 'cmdecho 0)
(cond
((= 0 (logand undo_state 1)) (command "_.undo" "_All")); если отключена возможность отмены.
((= 2 (logand undo_state 2)) (command "_.undo" "_control" "_all")); если запрещена отмена более одной команды.
); end cond.
(if (= 0 (logand undo_state 8)) (command "_.undo" "_begin")); если нет открытой группы команд.
(if (and (= mode 2) ss) (sssetfirst nil ss))
ss; return.
); end defun.
; END-UNDO-GROUP.
; Установка отметки окончания группы команд.
; Возврат: nil.
(defun end-undo-group ( / )
(setvar 'cmdecho 0)
(if (= 8 (logand (getvar 'undoctl) 8))(command "_.undo" "_end")); end if.
); end defun.
