Тема: 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
