Тема: LISP. Растры.Управление выгрузкой/загрузкой/удалением путем указания точки внутри контура
Предлагается набор команд для управления выгрузкой, обновлением, удалением растров из чертежа путем указания точки внутри контура растра.
Идея возникла здесь https://www.caduser.ru/forum/topic27696.html
Коды программ
;|******************* DoImage *********************** * Ф-ция выгружает, загружает, удаляет растры * * Выбор растров производится путем указания точки * * внытри контура растра * *************************************************** * Аргумент [Тип]: WhatD0 - строка [String] * значения "reload" - только перезагружать выгруженные растры "unload" - только выгружать загруженные растры "reload-unload" - перезагружать/выгружать "detach" - удалить растры "unloadall" - выгрузить все растры "loadall" - загрузить все растры * Возвращает nil * Пример использования ;_Перезагрузить выбранные выгруженные растры (DoImage "reload") ;_Выгрузить выбранные загруженные растры (DoImage "unload") ;_Выбранные растры перезагрузить если выгружен ;_ выгрузить если загружен (DoImage "reload-unload") ;_Выбранные растры удалить (DoImage "detach") |; (defun DoImage ( WhatDo / reload_list unload_list *error* ) ;;;Обработчик ошибок (defun *error* (message / image_set) ;;;Прерываем активную команду (while (> (getvar "CMDACTIVE") 0)(command)) (or *kpblc-activedoc* (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))) (princ message) ;;;Восстанавливаем состояние слоев (foreach item *kpblc-list-layer-status* (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))) (setq *kpblc-list-layer-status* nil) (kpblc-error-restore-sysvar) (if (setq image_set (ssget "_I"))(sssetfirst image_set)) (setq image_set nil) (vla-endundomark *kpblc-activedoc*) (princ) ) ;_ end of defun (or *kpblc-activedoc* (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))) (kpblc-error-save-sysvar (list '("QAFLAGS" 0) '("CMDECHO" 0) '("EXPERT" 5) '("ANGBASE" 0) '("ANGDIR" 0))) (vla-endundomark *kpblc-activedoc*) (vla-startundomark *kpblc-activedoc*) ;;;Прерываем активную команду (while (> (getvar "CMDACTIVE") 0)(command)) ;;;Разблокируем слои и сохраняем в списке *kpblc-list-layer-status* ;;;вида '(vla-указатель ("lock" . :vlax-false)) (or *kpblc-activedoc* (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object))) ) (if *kpblc-list-layer-status* (setq *kpblc-list-layer-status* nil) ) ;_ end of if (vlax-for item (vla-get-layers *kpblc-activedoc*) (setq *kpblc-list-layer-status* (append *kpblc-list-layer-status* (list (list item (cons "lock" (vla-get-lock item)) )))) ;_ end of setq (vla-put-lock item :vlax-false) ) (cond ((member WhatDo '("unloadall" "loadall")) ;_Выгружаем Загружаем все растры (setq reload_list (ssget "_X" '((0 . "IMAGE")))) (if reload_list (setq unload_list (mapcar (function vlax-ename->vla-object) (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex reload_list))))) (setq unload_list nil)) (foreach item unload_list (if (= WhatDo "unloadall") (command "_.-IMAGE" "_Unload" (vla-get-Name item)) (command "_.-IMAGE" "_ReLoad" (vla-get-Name item)))) ) (t (setq reload_list (ImageLoadUnloadList) unload_list (car reload_list) reload_list (cadr reload_list)) (cond ((= WhatDo "reload") ;_Загружаем (foreach item reload_list (command "_.-IMAGE" "_Reload" item) )) ((= WhatDo "unload") ;_Выгружаем (foreach item unload_list (command "_.-IMAGE" "_Unload" item)) ) ((= WhatDo "reload-unload") ;_Загружаем/Выгружаем (foreach item reload_list (command "_.-IMAGE" "_Reload" item)) (foreach item unload_list (command "_.-IMAGE" "_Unload" item)) ) ((= WhatDo "detach") ;_Удаляем растры (foreach item (append reload_list unload_list) (command "_.-IMAGE" "_Detach" item)) ) (t nil) ) ) ) ) ;;;Восстанавливаем состояние слоев (foreach item *kpblc-list-layer-status* (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))) (setq *kpblc-list-layer-status* nil) (kpblc-error-restore-sysvar) (vla-endundomark *kpblc-activedoc*) ) ;|******************* ImageLoadUnloadList *********************** * Ф-ция возвращает списки имен загруженных/выгруженных растров* *************************************************************** * Аргумент [Тип]: нет * Возвращает список списков имен растров для загрузки/выгрузки (СписокИменДляЗагрузки СписокИменДляВыгрузки) * Пример использования (setq load_list (ImageLoadUnloadList) unload_list (cadr load_list) load_list (car load_list) ) (princ "\nВыгруженные растры = ") (mapcar '(lambda (x)(princ x)(princ ", ")) unload_list) (princ "\nЗагруженные растры = ") (mapcar '(lambda (x)(princ x)(princ ", ")) load_list) **************************************************************|; (defun ImageLoadUnloadList (/ image_set image_list ImageName pt1 pt2 pt3 pt4 width height ug pt load_list unload_list ) (if (setq image_set (ssget "_I"))(sssetfirst image_set)) (setq image_set nil image_set (ssget "_X" '((0 . "IMAGE"))) ) (if image_set (setq image_list (mapcar (function vlax-ename->vla-object) (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex image_set))))) (setq image_list nil) ) (setq image_set nil image_set (ssadd)) ;_ setq (while (and image_list (setq pt (getpoint "\nУкажите точку внутри растра <выход>: "))) (foreach item image_list (setq pt1 (vlax-safearray->list (vlax-variant-value (vla-get-Origin item)) ) ug (vla-get-Rotation item) width (vla-get-ImageWidth item) height (vla-get-ImageHeight item) pt2 (polar pt1 ug width) ug (+ ug (* 0.5 PI)) pt3 (polar pt2 ug height) ug (+ ug (* 0.5 PI)) pt4 (polar pt3 ug width) pt (trans pt 1 0) ) (if (In_Figure pt (list pt1 pt2 pt3 pt4)) (progn ;_ Точка внутри контура растра ;_ Узнаем статус (выгружен/загружен) (setq ImageName (vla-get-Name item) ug (ImageLoadStatus item)) (ssadd (vlax-vla-object->ename item) image_set) (sssetfirst image_set image_set) (cond ((= ug "load") (if (not (member ImageName load_list)) (setq load_list (append load_list (list ImageName)));_setq ) ) ((= ug "unload") (if (not (member ImageName unload_list)) (setq unload_list (append unload_list (list ImageName)));_setq ) ) (t nil)))) );_foreach );_while (sssetfirst image_set) (setq image_set nil) (if (null image_list)(alert "\nНет растров в чертеже")) ;В load_list - имена загруженных растров ;В unload_list - имена выгруженных растров (list load_list unload_list) ) ;|******************* ImageLoadStatus ********************* * Ф-ция возвращает состояние растра (Загружен/Выгружен) * ********************************************************* * Аргумент [Тип]: ImageObject - указатель на растр [VLA-OBJECT] * Возвращает строку со значением "unload" - выгружен "load" - загружен "unknown" - состояние неизвестно * Пример использования (if (and (setq e1 (car (entsel "\nУкажите растр: "))) (= (cdr(assoc 0 (entget e1))) "IMAGE") ) (alert (strcat "Состояние растра - " (ImageLoadStatus (vlax-ename->vla-object e1))) ) ) **************************************************************|; (defun ImageLoadStatus ( ImageObject / imageList ImageName grp) (setq ImageName (vla-get-Name ImageObject )) (setq imageList (dictsearch (namedobjdict) "ACAD_IMAGE_DICT")) (if (setq grp (assoc 350 (member (cons 3 ImageName) ImageList))) (progn (setq grp (entget (cdr grp))) (setq grp (cdr (assoc 280 grp))) ) ) (cond ((= 0 grp) "unload") ((= 1 grp) "load") (t "unknown")) ) ;|****************** In_Figure ***************************** * Тест — находится ли точка pt внутри контура contur. * * Тема поднималась здесь * * https://www.caduser.ru/forum/topic4008.html * * Алгоритм взят из статьи О.Р.Мусина в журнале * * "Программирование" 4, 91г. * * Выбран алгоритм "Сумма ориентаций пересечений" * ********************************************************** * Аргументы [Тип] : pt — тестируемая точка (X Y Z) [list] contur — список координат точек образующих контур в виде (pt1 pt2 ...ptn) [list] * Возвращает t - точка в контуре nil - точка вне контура * Функции : _locat — проверяет находится ли пара точек в квадрантах * ((1,4)(2,4)(1,3)) _kk — вычисляет ориентацию отрезка ***********************************************************|; (defun In_Figure (pt contur / pt1 pt2 pti ptl ptp ptc eps tmp) ;;;---------------------------------------------------------- (defun My- (x y)(cond ((< x y) -1)((> x y) 1)(t 0))) ;;;---------------------------------------------------------- (defun My+ (x y) (or (zerop x) (zerop y) (zerop (+ x y)))) ;;;---------------------------------------------------------- (defun _Locat (pt1 pt2) ;_ Допустимая ли комбинация четвертей ? (cond ((and (>= (car pt1) 0) (>= (cadr pt1) 0)) ;_ 1 (or (and (>= (car pt2) 0) (< (cadr pt2) 0)) ;_ 1-4 (and (< (car pt2) 0) (< (cadr pt2) 0))));_ 1-3 ((and (< (car pt1) 0) (>= (cadr pt1) 0)) ;_ 2 (and (>= (car pt2) 0) (< (cadr pt2) 0))) ;_ 2-4 ((and (< (car pt1) 0) (< (cadr pt1) 0)) ;_ 3 (and (>= (car pt2) 0) (>= (cadr pt2) 0))) ;_ 3-1 (t ;_ 4 (or (and (>= (car pt2) 0) (>= (cadr pt2) 0)) ;_ 4-1 (and (< (car pt2) 0) (>= (cadr pt2) 0))))));_ 4-2 ;_------------------------------------------------------------ (defun _Kk (pt1 pt2)(if(>= (cadr pt1) (cadr pt2)) 1 -1)) ;_------------------------------------------------------------ (setq tmp nil pt1 (mapcar '- (car contur) pt) ptp pt1) ;_ создается список отрезков (while contur (setq ptc (mapcar '- (car contur) pt) contur (cdr contur)) (if (_locat ptc ptp) (setq tmp (cons (list ptc ptp) tmp))) (setq ptp ptc));_while (if (_locat pt1 ptp) (setq tmp (cons (list pt1 ptp) tmp))) ;_ ищем точки пересечения L+ с контуром (setq pt '(0 0 0) ptl '(1 0 0) eps 0) (while tmp (setq pt1 (caar tmp) pt2 (cadar tmp) tmp (cdr tmp) pti (inters pt1 pt2 pt ptl nil)) (cond ((< (car pti) 0) nil);_ Отрезок пересекает L- (t (setq eps (+ (_kk pt1 pt2) eps)))) );_while ;_ В eps — сформированный признак (not (zerop eps)) ) ;|================================================================ * Сохраняется текущее значение системных переменных. Список глобальный (*kpblc-sysvar-list*) * При условии, что заданы значения, они устанавливаются. * Поскольку список *kpblc-sysvar-list* не обнуляется, в нем хранится история изменения значений переменных. * Параметры вызова: * *kpblc-sysvar-list* список системных переменных, состояние которых надо сохранить. * Список состоит из подсписков (Переменная Значение) * В списке могут повторяться Переменные. В таком случае будет * установлено последнее значение. * Если в качестве второго параметра используется nil, то значение * системной переменной просто сохраняется. * Примеры вызова: (kpblc-error-sysvar-list (list '("cmdecho" 0) '("blipmode") '("osmode" 503))) (kpblc-error-sysvar-list (kpblc-get-all-sysvar-list)) ==============================================================|; (defun kpblc-error-save-sysvar (sysvar-list) (foreach item sysvar-list (setq *kpblc-sysvar-list* (cons (list (strcase (car item)) (getvar (car item))) *kpblc-sysvar-list* ) ;_ end of cons ) ;_ end of setq (if (cadr item) ; передано устанавливаемое значение (setvar (car item) (cadr item)) ) ;_ end of if ) ;_ end of foreach ) ;_ end of defun ;|============================================================== * Восстанавливаются системные переменные. Значения системных переменных * должны храниться в глобальном списке *kpblc-sysvar-list*. Если списка нет * (nil), происходит просто выход. * Параметры вызова: * Нет * Примеры вызова: (kpblc-error-restore-sysvar) ==============================================================|; (defun kpblc-error-restore-sysvar () (if *kpblc-sysvar-list* (foreach item *kpblc-sysvar-list* (setvar (car item) (cadr item)) ) ;_ end of foreach ) ;_ end of if (setq *kpblc-sysvar-list* nil) (gc) ) ;_ end of defun
Команды
;======================= КОМАНДЫ ====================== ;******* Команда для выгрузки загруженных растров ***** ; Выгруженные растры остаются выгруженными (defun C:ptImageUnload ( )(DoImage "unload")(princ)) ;******* Команда для загрузки выруженных растров ****** ; Загруженные растры остаются загруженными (defun C:ptImageReload ( )(DoImage "reload")(princ)) ;******* Команда для загрузки выруженных растров ****** ; и выгрузки загруженных ; Загруженные растры выгружаютмя, выгруженные заргужаются (defun C:ptImageReloadUnload ( )(DoImage "reload-unload")(princ)) ;******* Команда для удаления вставленных растров ****** (defun C:ptImageDetach ( )(DoImage "detach")(princ)) ;******* Команда для обновления всех вставленных растров ****** (defun C:ImageReloadAll ( )(DoImage "loadall")(princ)) ;******* Команда для выгрузки всех вставленных растров ****** (defun C:ImageUnloadAll ( )(DoImage "unloadall")(princ))
Возможные макросы для кнопки или пункта меню:
^C^C^P(if (not DoImage)(load "Doimage"));ptImageUnload; ^C^C^P(if (not DoImage)(load "Doimage"));ptImageReload; ^C^C^P(if (not DoImage)(load "Doimage"));ptImageReloadUnload; ^C^C^P(if (not DoImage)(load "Doimage"));ptImageDetach;
если текст кода сохранить в файле DoImage.lsp