Проект: Pblock
Файл: pblock.lsp
Язык: AutoLISP
Версия от 4 февраля 2007
;; функции отладки ;; в функцию передается ;; point - целое - номер контрольной точки и ;; sym - строка - имя переменной для анализа (defun pbl_debug (point sym) (if (vl-bb-ref 'vk_pblock_debug) (progn (princ (strcat "\nТочка " (itoa point) ": ")) (if (and sym (= (type sym) 'STR) (/= "" sym)) (progn (princ (strcat "переменная \"" sym "\" = ")) (princ (eval (read sym))) (princ " Тип \"") (princ (type (eval (read sym)))) (princ "\"") ) ;_ progn (princ sym) ) ;_ if (princ) ) ;_ progn ) ;_ if ) ;_ defun ;;========================================================================================== ;; Вход в программу (defun c:pblock (/ ;_ описание переменных *error* vk_modes vk_moder vk_tru_text ;_ локализованные функции pbl_coord pbl_draw_elem pbl_redraw ;_ локализованные функции pbl_block pbl_edit pbl_main pbl_select ;_ локализованные функции mode1 mode2 mode3 modezer modeset ;_ наборы sysvars oldcmd ;_ старое значение "cmdecho" temppt ;_ временная точка за пределами видимости ... ;;...или точка для перетаскивания набора примитивов блока stdat ;_ данные текущего стиля текста txtm ;_ смещение по X, связанное с наклоном текста vscale ;_ масштаб текущего ВЭ gap ;_ отступ текста от рамки th ;_ высота текста strs ;_ список строк текста txtpts ;_ крайние точки (углы) текста x1 x2 y1 y2 ;_ координаты крайних точек для прямоугольника x y z ;_ координаты вставки блока rad ;_ радиус окружности ss ;_ набор примитивов блока spt ept ;_ начальная и конечная точки линии выноски just ;_ опция выравнивания текста ipt ;_ точка вставки блока lead ;_ список выносок mode ;_ опция, введенная пользователем doc ;_ текущий документ (vla-объект) strsi ;_ список строк из редактора на отрисовку insl ;_ слой, на который вставлен (или вставляется) блок (текущий слой) layget ;_ данные слоя для проверки dclnm ;_ имя dcl файла ) (gc) ;_ очистка памяти ;;-------------------------------------------------------------------------- ;; Обработка ошибок (defun *error* (s) (princ (if (member s '("Function cancelled" "quit / exit abort" "*Прервано*" "завершить / выйти прервать")) "\nОтменено пользователем" (strcat "\nОднако, ошибка... " s " ERRNO=" (rtos (getvar "errno") 2 0)) ) ;_ if ) ;_ princ (if (and dclnm (findfile dclnm)) (vl-file-delete dclnm) ;_ удаление файла dcl ) (if doc (progn (vla-endundomark doc) ; завершим группу UNDO (vlax-release-object doc) (vl-cmdf "_.u") ; отмена сделанных изменений ) ;_ progn ) ;_ if (vl-exit-with-value (princ)) ; тихий выход из VLX ) ;_ defun ;;-------------------------------------------------------------------------- ;; сохранение системных переменных ;; возвращает список, состоящий из пар (имя_1 значение_1 имя_2 значение_2 ....) (defun vk_modes (listvar / ms) ;_ listvar - список системных переменных (foreach n listvar (setq ms (cons (getvar n) (cons n ms)))) (reverse ms) ) ;_ defun ;;-------------------------------------------------------------------------- ;; восстановление системных переменных (defun vk_moder (ms) ;_ ms - список, состоящий из пар (имя_1 значение_1 имя_2 значение_2 ....) (while ms (setvar (car ms) (cadr ms)) (setq ms (cddr ms))) ;_ while ) ;_ defun ;;------------------------------------------------------------------------------------------ ;; *** Отрисовка строки текста *** ;; с высотой, независимо от определенной в текущем текстовом стиле ;; синтаксис (vk_tru_text текст точка_начала высота_текста угол_поворота опция_выравнивания) (defun vk_tru_text (txt t0 h ug just / elast tbs) (setq elast (entlast)) ; последний созданный примитив (if (= (cdr (assoc 40 (setq tbs (entget (tblobjname "STYLE" (getvar "TEXTSTYLE")))))) 0.0) (if (and just (/= (strcase just) "_L")) ;_ при нулевой высота текста (vl-cmdf "_.TEXT" "_J" just t0 h ug txt) (vl-cmdf "_.TEXT" t0 h ug txt) ) ;_ if (progn ; при фиксированнной высоте текста в стиле (entmod (subst '(40 . 0.0) (assoc 40 tbs) tbs)) ; обнулить высоту текста в стиле (if (and just (/= (strcase just) "_L")) (vl-cmdf "_.TEXT" "_J" just t0 h ug txt) (vl-cmdf "_.TEXT" t0 h ug txt) ) ;_ if (entmod tbs) ; восстановить высоту текста в стиле ) ;_ progn ) ;_ if (if (/= elast (entlast)) (entlast) nil ) ;_ if ) ;_ defun vk_tru_text ;; *** конец отрисовки строки текста *** ;;------------------------------------------------------------------------------------------ ;;-------------------------------------------------------------------------- ;; *** Отрисовка координат *** ;; bord - вид контура ;; spt - начальная точка линии выноски ;; temppt - временная точка для отрисовки ;; just - выравнивание текста (defun pbl_coord (/ str ;_ строка текста txt ;_ созданный примитив TEXT ) (setq str (if (= bord "Xy") ; текст формируем на основе координат точки начала (strcat "X=" (rtos (car spt) 2 (getvar "dimdec")) " Y=" (rtos (cadr spt) 2 (getvar "dimdec"))) (strcat "X=" (rtos (car spt) 2 (getvar "dimdec"))) ) ;_ if txt (vk_tru_text str temppt th 0 just) ; добавляем в набор текст txtpts (textbox (entget txt)) ; крайние точки углов текста x1 (- (car temppt) gap (/ (caadr txtpts) 2)) ; координаты точек линии x2 (+ (car temppt) gap (/ (caadr txtpts) 2)) y1 (- (cadr temppt) gap (/ th 2)) y2 0.0 ; только, чтоб не было ошибки (любое число) strs (list str) ; список строк ) ;_ setq (ssadd txt ss) ; добавляем в наборчик первую строку текста (if (= bord "2xy") ; если координаты в две строки (progn (setq str (strcat "Y=" (rtos (cadr spt))) ; вторая строка текста temppt (list (car temppt) (- (cadr temppt) th gap gap)) txt (vk_tru_text str temppt th 0 just) ; добавляем в наборчик текст txtpts (textbox (entget txt)) ; крайние точки углов текста x1 (min x1 (- (car temppt) gap (/ (caadr txtpts) 2))) ; координаты x2 (max x2 (+ (car temppt) gap (/ (caadr txtpts) 2))) ; точек линии strs (append strs (list str)) ; добавим в список строк последнюю строку ) ;_ setq (ssadd txt ss) ; добавляем в наборчик вторую строку текста ) ;_ progn ) ;_ if (vl-cmdf "_.line" (list x1 y1) (list x2 y1) "") ; рисуем линию (ssadd (entlast) ss) ; добавляем её в наборчик (setq temppt (list x1 y1)) ; точка, за которую тащить ) ;_ defun pbl_coord ;; на выходе имеем: ;; temppt - точка, за которую тащить набор заготовок блока ;; txtpts ;; x1 ;; x2 ;; ss - набор заготовок блока ;; strs - список строк ;; *** конец отрисовки координат *** ;;-------------------------------------------------------------------------- ;;-------------------------------------------------------------------------- ;; **** отрисовка элементов блока **** ;; глобальные переменные ;; bord - вид контура ;; temppt - временная точка для отрисовки ;; th - высота текста ;; gap - зазор от текста ;; txtm - смещение по X, связанное с наклоном текста ;; just - выравнивание текста ;; strsi - список строк из редактора ;; vscale - масштаб (defun pbl_draw_elem (/ str ;_ строка текста txt ;_ примитив TEXT vla:txt ;_ объект TEXT txttx/2 ;_ половина ширины текста ty1 ;_ временная переменная для хранения координаты Y r ;_ радиус окружности (вычисленный) ) (initget 0) (while (= (if strsi ; есть строка из редактора? (setq str (car strsi) ; да - ввод первой строки текста из редактора strsi (cdr strsi) ) ;_ setq (setq str ;|(vl-string-trim " "|; (getstring t "\nString: ");|)|;) ; нет - ввод с клавы ) ;_ if "" ; пустая строка ) ;_ = ) ;_ while (setq txt (vk_tru_text str temppt th 0 just) ; рисуем текст txtpts (textbox (entget txt)) ; крайние точки углов текста txttx/2 (/ (- (caadr txtpts) (caar txtpts)) 2) x1 (- (car temppt) txttx/2 gap (if (minusp txtm) (abs txtm) 0.0 ) ;_ if ) ; координаты точек контура x2 (+ (car temppt) txttx/2 gap (if (> txtm 0) txtm 0.0 ) ;_ if ) ;_ + y1 (- (cadr temppt) gap (/ th 2)) y2 (+ (cadr temppt) gap (/ th 2)) ty1 y1 ; временная переменная strs (list str) ; список строк ) ;_ setq (vl-cmdf "_.move" txt "" (list txtm 0.0) '(0.0 0.0)) (vla-put-color (vlax-ename->vla-object txt) tcolor) ;_ установим цвет текста (vla-put-layer (vlax-ename->vla-object txt) tlayer) ;_ установим слой текста (ssadd txt ss) ; добавляем в набор первую строку текста (cond ((member bord '("Lines" "Twostring" "Onestring")) ;_ если контур - линия (vl-cmdf "_.line" (list x1 y1) (list x2 y1) "") ; рисуем первую линию (ssadd (entlast) ss) ; добавляем в набор первую линию ;; ввод последующих строк (while (cond ((or (= bord "Onestring") (and (= (length strs) 2) (= bord "Twostring"))) nil ; хватит, уже есть две строки для "Twostring" или одна для "Onestring" ) (strsi ; есть строка из редактора (setq str (car strsi)) (if (= str 0) ; конец списка строк nil ; выход из цикла (setq strsi (cdr strsi)) ) ;_ if ) ;_ strsi ((and ; ввод с клавиатуры (not (while (progn (setq str (getstring t (strcat "\nString #" ; ввод следующих строк (itoa (1+ (length strs))) (if (= bord "Lines") " <Ok>: " ": " ) ;_ if ) ;_ strcat ) ;_ getstring ) ;_ setq (not (or (= str "") ; выход при "пустой ввод" или "не только пробелы" (/= ;|(setq str|; (vl-string-trim " " str) ;|)|; "") ) ;_ or ) ;_ not ) ;_ progn ) ;_ while ) ;_ not (= str "") ; проверка на пустой ввод ) ;_ and nil ; был пустой ввод - прервать цикл ) (t t) ; иначе - продолжить цикл ) ;_ cond (setq temppt (list (car temppt) (- (cadr temppt) th gap gap)) txt (vk_tru_text str temppt th 0 just) ; рисуем текст txtpts (textbox (entget txt)) ; крайние точки углов текста txttx/2 (/ (- (caadr txtpts) (caar txtpts)) 2) ;; координаты точек контура x1 (min x1 (- (car temppt) txttx/2 gap (if (minusp txtm) txtm 0.0 ) ;_ if ) ;_ - ) ;_ min x2 (max x2 (+ (car temppt) txttx/2 gap (if (> txtm 0) txtm 0.0 ) ;_ if ) ;_ + ) ;_ max y1 (- (cadr temppt) gap (/ th 2)) strs (append strs (list str)) ; добавим в список строк последнюю строку ) ;_ setq (vla-put-color (vlax-ename->vla-object txt) tcolor) ;_ установим цвет текста (vla-put-layer (vlax-ename->vla-object txt) tlayer) ;_ установим слой текста (vl-cmdf "_.move" txt "" (list txtm 0.0) '(0.0 0.0)) (ssadd txt ss) ; добавляем в набор текст (vl-cmdf "_.line" (list x1 y1) (list x2 y1) "") ; рисуем линию (ssadd (entlast) ss) ) ;_ while ;; ввод строк для контур = "линия" завершен (setq temppt (list x1 (setq y1 ty1))) ; восстановим y1 и определим точку, за которую тащить блок ) ;; если контур - прямоугольник ((= bord "Rectangle") (vl-cmdf "_.move" txt "" '(0.0 0.0) (list (/ txtm 2) 0.0)) (vl-cmdf "_.rectang" (list x1 y1) (list x2 y2)) ; рисуем прямоугольник контура (setq temppt (list x1 y1)) ; точка, за которую тащить блок (ssadd (entlast) ss) ) ;; если контур - окружность ((= bord "Circle") ;; радиус окружности (setq r (+ gap (distance temppt (list (- (car temppt) txttx/2) (- (cadr temppt) (/ th 2)))))) (if (and (setq diafix (vl-bb-ref 'vk_pblock_diafix)) ;_ если задан диаметр окружности (= (type diafix) 'REAL) (> diafix 0.0) ) ;_ and (if (> r (setq rad (/ diafix 2.0 vscale))) ;_ если текст не лезет в окружность (progn (setq vla:txt (vlax-ename->vla-object txt)) (setq talpt (vla-get-textalignmentpoint vla:txt)) ;_ запомнить точку вставки текста (vla-put-height vla:txt (/ (* (vla-get-height vla:txt) rad) r)) ;_ скорректировать высоту текста (vla-put-textalignmentpoint vla:txt talpt) ;_ восстановить убежавшую точку вставки текста ) ;_ progn ) ;_ if (setq rad r) ) ;_ if (vl-cmdf "_.circle" temppt rad) ; рисуем окружность контура (if strsi ; была строка из редактора (setq temppt (polar temppt ang rad)) ) ;_ if (ssadd (entlast) ss) ) ) ;_ cond (cond ((and (= bord "Twostring") (= (length strs) 2)) ; только в случае двух строк текста (ssdel (entdel (entlast)) ss) ; удалим последнюю линию из набора и из пространства ) ((= bord "Onestring") (setq bord "Lines")) ; переход алгоритма ) ;_ cond ) ;_ defun pbl_draw_elem ;; на выходе имеем: ;; ss - набор элементов блока ;; temppt - точка, за которую тащить набор заготовок блока ;; x1, x2, y1, y2 - координаты крайних точек для прямоугольника ;; rad - радиус окружности ;; strs - список строк текста ;; *** конец отрисовки элементов блока *** ;;-------------------------------------------------------------------------- ;;-------------------------------------------------------------------------- ;; *** перерисовка набора заготовок с новым выравниванием *** ;; strs - список строк ;; ss - набор заготовок ;; just - выравнивание текста ;; gap - зазор от текста ;; x1, x2, y1 - координаты линии подчеркивания первой строки ;; z - координата Z ;; th - высота текста ;; bord - вид контура (defun pbl_redraw (/ yv ;_ координата начала вертикальной линии stxt ;_ начало строки текста с учетом выравнивания count ;_ к-во строк текста txt ;_ примитив TEXT ) ;; если строк несколько, то все перерисуем заново с новым выравниванием (if (member bord '("Lines" "Twostring" "Onestring")) (progn ;; удаляем всю визуализацию (setq count (sslength ss)) ; количество объектов в наборе (while (not (minusp (setq count (1- count)))) (entdel (ssname ss count)) ;_ удаляем ) ;_ while (setq ss nil ss (ssadd) ; создаем наборчик заново yv y1 ; координата начала вертикальной линии stxt (list (if (= just "_l") ; начало первой строки текста с учетом выравнивания (+ x1 gap (if (minusp txtm) (abs (/ txtm 2)) 0.0 ) ;_ if ) ;_ + (- x2 gap (if (> txtm 0) (* txtm 2) 0.0 ) ;_ if ) ;_ - ) ;_ if (+ y1 gap) z ) ;_ list count (length strs) ) ;_ setq (repeat count (setq txt (vk_tru_text (car strs) stxt th 0 just)) (vla-put-color (vlax-ename->vla-object txt) tcolor) ;_ установим цвет текста (vla-put-layer (vlax-ename->vla-object txt) tlayer) ;_ установим слой текста (if (= just "_l") (vl-cmdf "_.move" txt "" (list (/ (caar (textbox (entget txt))) 2) 0.0) '(0.0 0.0)) ) ;_ if (ssadd txt ss) ; добавим текст в наборчик (vl-cmdf "_.line" (list x1 y1 z) (list x2 y1 z) "") (ssadd (entlast) ss) ; добавим линию в наборчик (setq strs (cdr strs) ; удаляем первый элемент из списка строк stxt (list (car stxt) (- (cadr stxt) gap gap th) z) ; начало следующей строки y1 (- y1 gap gap th) ; коорд. y1 для следующей линии и конца вертикальной ) ;_ setq ) ;_ repeat (setq y1 (+ y1 gap gap th)) ; больше линий не будет, вернем y1 (if (and (= bord "Twostring") (= count 2)) ; и последней линии тоже нет (progn (ssdel (entdel (entlast)) ss) ; удалим последнюю линию (setq y1 (+ y1 gap gap th)) ; и ещё раз вернем y1 ) ;_ progn ) ;_ if (if (not (equal yv y1 1e-9)) ; надо рисовать вертикальную линию (progn (if (= just "_l") ; с нужной стороны (vl-cmdf "_.line" (list x1 yv z) (list x1 y1 z) "") (vl-cmdf "_.line" (list x2 yv z) (list x2 y1 z) "") ) ;_ if (ssadd (entlast) ss) ; добавим вертикальную линию в наборчик ) ;_ progn ) ;_ if ) ;_ progn ) ;_ if ) ;_ defun pbl_redraw ;; *** конец перерисовки набора заготовок с новым выравниванием *** ;;-------------------------------------------------------------------------- ;;-------------------------------------------------------------------------- ;; *** создание блока и присоединение выносок *** ;; ss - набор объектов для блока ;; ipt - точка вставки блока ;; lead - список выносок (defun pbl_block (/ ucsn ;_ имя UCS w0 ;_ точка (0.0 0.0 0.0) wipt ;_ точка вставки блока rm ;_ матрица текущей UCS (безопасный массив) rmx ;_ трансформационный матрикс текущей UCS irm ;_ инверсная матрица (трансформационный матрикс) текущей UCS count ;_ счетчик blkname ;_ имя блока edat ;_ (entget leader) ucsi ;_ значение системной переменной ucsicon vla:ob ;_ каждый из объектов блока для поворота\перемещения insert ;_ вставка блока ) ;; блок будем создавать в wcs, иначе он не приклеится к выноске (setq w0 (vlax-3d-point '(0 0 0)) ; (0.0 0.0 0.0) wipt (vlax-3d-point (trans ipt 1 0)) ucsi (getvar "ucsicon") ) ;_ setq (setvar "ucsicon" 0) ; отключение иконки UCS (if (= (getvar "WORLDUCS") 1) ; мы в wcs? (setq rm (vlax-variant-value (vlax-tmatrix '((1 0 0 0) (0 1 0 0) (0 0 1 0) (0 0 0 1))))) (if (member (setq ucsn (getvar "UCSNAME")) ; нет '("" "*TOP*" "*BOTTOM*" "*FRONT*" "*BACK*" "*LEFT*" "*RIGHT*") ; не именованная UCS ) ;_ member (progn (vl-catch-all-apply 'vl-cmdf '("_.ucs" "_d" "vk_pos_temp_ucs")) (vl-cmdf "_.ucs" "_s" "vk_pos_temp_ucs") ; дадим UCS временное имя (setq rm (vlax-variant-value (vla-getucsmatrix (vlax-ename->vla-object (tblobjname "ucs" "vk_pos_temp_ucs"))) ) ;_ vlax-variant-value ) ;_ setq (vl-cmdf "_.ucs" "_p") (vl-cmdf "_.ucs" "_d" "vk_pos_temp_ucs") ; удалим временное имя (мусор) ) ;_ progn (setq rm (vlax-variant-value (vla-getucsmatrix (vlax-ename->vla-object (tblobjname "ucs" ucsn))))) ) ;_ if ) ;_ if (mapcar '(lambda (i) (vlax-safearray-put-element rm i 3 (vlax-make-variant 0.0))) '(0 1 2) ; обнулим смещение UCS в матрице поворота UCS ) ;_ mapcar (setq irm (vlax-variant-value (setq rmx (vlax-make-variant rm)))) ; копия... (и финт ушами) (mapcar ; создадим инверсную матрицу irm '(lambda (i j) (vlax-safearray-put-element irm i j (vlax-safearray-get-element rm j i))) '(0 0 1 1 2 2) ; что '(1 2 2 0 0 1) ; на что менять ) ;_ mapcar (setq irm (vlax-make-variant irm) count -1 ; счетчик объектов заготовок ) ;_ setq (repeat (sslength ss) ; переместим и повернем набор заготовок блока (vla-move (setq vla:ob (vlax-ename->vla-object (ssname ss (setq count (1+ count))))) wipt w0) (vla-transformby vla:ob irm) ;_ поворот (if (/= (vla-get-objectname vla:ob) "AcDbText" ) ;_ для текстов сохраним цвет и слой (progn (vla-put-layer vla:ob "0") (vla-put-color vla:ob 0) ) ) (vla-put-linetype vla:ob "ByBlock") ;_ подрихруем другие признаки (vla-put-lineweight vla:ob -2) (vlax-release-object vla:ob) ) ;_ repeat ;; создание и вставка анонимного блока из набора объектов ;; блок создается на слое "0" и ставится на текущий слой с текущим цветом, ;; объекты остаются на своих слоях (entmake (list '(0 . "BLOCK") '(100 . "AcDbEntity") '(100 . "AcDbBlockBegin") '(2 . "*Unnn") '(8 . "0") ; на слой "0" '(70 . 1) ; анонимный блок (cons 10 '(0.0 0.0 0.0)) ) ;_ list ) ;_ entmake (setq count (sslength ss)) ; количество объектов в наборе (while (not (minusp (setq count (1- count)))) (entmake (entget (ssname ss count))) ;_ делаем копию в блок (entdel (ssname ss count)) ;_ удаляем оригинал ) ;_ while ;; завершаем описание блока (setq blkname (entmake (list '(0 . "ENDBLK") '(100 . "AcDbEntity") '(100 . "AcDbBlockEnd") '(8 . "0")))) (entmake (list '(0 . "INSERT") ; вставка блока '(100 . "AcDbBlockReference") (cons 2 blkname) (cons 8 insl) ; слой для вставки блока (cons 10 '(0.0 0.0 0.0)) '(-3 ("pblock" (1000 . "pblock"))) ; для дальнейшей идентификации блока ) ;_ list ) ;_ entmake (setq ss nil) ;; завершение создания и вставки анонимного блока (setq insert (entlast)) ;_ вставка блока (vla-transformby (setq vla:ob (vlax-ename->vla-object insert)) rmx) ; созданный блок вернем (vla-move vla:ob w0 wipt) ; на место (foreach n lead (setq edat (entget n)) (setq edat (subst (cons 10 (trans ipt 1 0)) (assoc 10 (reverse edat)) edat)); коррекция конца линии выноски (entmod (subst '(213 0.0 0.0 0.0) (assoc 213 edat) edat)) ; обнуление смещения аннотации (vla-put-annotation (vlax-ename->vla-object n) vla:ob) ; и приклеим его к выноскам ) ;_ foreach (vlax-release-object vla:ob) (setvar "ucsicon" ucsi) ; возврат иконки UCS insert ;_ возвращаемое значение - ename вставки блока ) ;_ defun ;; *** конец создания блока и присоединения выносок *** ;;-------------------------------------------------------------------------- ;;-------------------------------------------------------------------------- ;; *** функция выбора блока *** (defun pbl_select (/ dat) ;_ часть данных insdat (and ; выберем только наш объект (setq ent (car (entsel "\nSelect leader or block: "))) (if (= (cdr (assoc 0 (entget (setq lead ent)))) "LEADER") (= (cdr (assoc 0 (entget (setq insert (cdr (assoc 340 (entget lead))))))) "INSERT") (= (cdr (assoc 0 (entget (setq insert ent)))) "INSERT") ; insert - вставка блока ) ;_ if (= (substr (setq bname (cdr (assoc 2 (setq insdat (entget insert '("*")))))) 1 2) "*U") (= (caadr (assoc -3 insdat)) "pblock") ; принадлежность к своему приложению (setq insl (cdr (assoc 8 insdat))) ; слой, на который вставлен блок (setq dat (member '(102 . "{ACAD_REACTORS") insdat)) ; наличие реакторов ;; создание списка выносок в переменной lead или nil при отсутствии таковых (progn (setq lead nil) ; список выносок (repeat (vl-position '(102 . "}") (setq dat (cdr dat))) (if (= (cdr (assoc 0 (entget (cdar dat)))) "LEADER") (setq lead (cons (cdar dat) lead)) ) ;_ if (setq dat (cdr dat)) ) ;_ repeat (> (length lead) 0) ) ;_ progn (setq ent (cdr (assoc -2 (tblsearch "BLOCK" bname)))) ; первый примитив блока ) ;_ and все указывает на наш блок ) ;_ defun ;; insert - вставка блока ;; insdat - (entget insert) ;; bname - имя блока ;; lead - список выносок ;; ent - первый примитив блока ;; *** конец функции выбора блока *** ;;-------------------------------------------------------------------------- ;;============================================================================ ;; *** функции редактирования *** ;; (defun pbl_edit (/ pbl_dialog ;_ локализованная функция accept_dlg add_dlg del_dlg up_dlg alert_note down_dlg ;_ действия кнопок (локализованные функции) nline ;_ к-во линий в блоке nedit ;_ номер текущего editbox dcl_xy ;_координаты окна диалога dcl_id ;_ идентификатор диалога ent ;_ выбранный пользователем объект или каждый из примитивов блока при переборе insert ;_ примитив INSERT insdat ;_ (entget insert) cen ;_ центр окружности bname ;_ имя блока data ;_ тип примитива блока TEXT, LINE.... dlg_do ;_ признак завершения диалога (вне диалога) dd ;_ признак завершения диалога (внутри диалога) hj ;_ горизонтальное выравнивание текста ptxt ;_ точка вставки stro ;_ старый список строк (временно) 2leadpt ;_ вторая точка лидера для теста переворота блока ;; для вставки существующего блока vla:insert ;_ объект i:color ;_ цвет i:ltype ;_ тип линии i:lscale ;_ масштаб типа линии i:lw ;_ вес (толщина) линии i:layer ;_ слой ) ;; ;; ВЛОЖЕННЫЕ ФУНКЦИИ РЕДАКТИРОВАНИЯ (defun alert_note () (alert (strcat "Для прямугольника и окружности допускается только правка текста." "\n\nПустые строки а также строки только из пробелов" "\nоставлять не допускается." "\n\nДля добавления, удаления и перемещения строк в остальных" "\nтипах выносок установите курсор на нужную строку," "\nзатем нажмите кнопку для выполнения операции." "\n\n\"Add\" - добавление строки под текущей;" "\n\"Del\" - удаление текущей строки;" "\n\"Up\" - перемещение текущей строки вверх;" "\n\"Down\" - перемещение текущей строки вниз." "\n\nМаксимальное количество строк равно 20" ) ;_ strcat ) ;_ alert ) ;_ defun ;;--------------------------- ;; *** создание файла dcl и инициализация окна диалога *** ;; strsi - список строк для редактирования (defun pbl_dialog (/ dcl ;_ строка, описывающая диалог nln ;_ номер строки как целое snln ;_ номер строки как строка file ;_ файл для записи dcl estr ;_ строка для редактирования ucsi ;_ значение системной переменной ucsicon ) ;; формирование файла диалога $$pbl***.dcl (setq dcl "pblock:dialog{label=\"Редактирование выноски\";width=65;:row{:column{alignment=top;fixed_height=true;:edit_box{key=\"str0\";}" nln 1 dclnm (vl-filename-mktemp "$$pbl" (getvar "savefilepath") ".dcl") ;_ имя файла в папке временных файлов file (open dclnm "w") ; новый dcl файл для записи ) ;_ setq (while (/= nln (length strsi)) (setq dcl (strcat dcl ":edit_box{key=\"str" (itoa nln) "\";}") nln (1+ nln) ) ;_ setq ) ;_ while (write-line (strcat dcl (if (member bord '("Circle" "Rectangle")) "}}" ; конец строки из editbox'ов и места кнопок "}:column{fixed_width=true;fixed_height=true;alignment=top;:button{label=\"&Up\";key=\"up\";fixed_width=true;alignment=centered;}:row{:button{label=\"&Add\";key=\"add\";fixed_width=true;}:button{label=\"&Del\";key=\"del\";fixed_width=true;}}:button{label=\"Do&wn\";key=\"down\";fixed_width=true;alignment=centered;}}}" ) ;_ if ":row{:text{key=\"bs\";}ok_cancel_help;}}" ) ;_ strcat file ) ;_ write-line (close file) (pbl_debug 1 (vl-bb-ref 'vk_pblock_delay)) ;; задержка перед загрузкой диалога (if (vl-bb-ref 'vk_pblock_delay) (command "_delay" (vl-bb-ref 'vk_pblock_delay)) ) (pbl_debug 2 "dclnm") ;; файл создан. загружаем диалог (setq dcl_id (load_dialog dclnm)) (pbl_debug 3 "dcl_id") (new_dialog "pblock" dcl_id "" dcl_xy) (pbl_debug 4 "strsi") ;; запись текста и назначение действий в editbox'ы (setq nln 0) (while (/= nln (length strsi)) (if (= (setq estr (vl-string-trim " " (nth nln strsi))) "") ; если попалась пустая строка (set_tile "bs" "Blank string!") ) ;_ if (setq snln (itoa nln)) (set_tile (strcat "str" snln) estr) ;; задание едитбоксу функции определения своего номера (action_tile (strcat "str" snln) (strcat "(setq nedit " snln ")")) (setq nln (1+ nln)) ) ;_ while ;; назначение действий кнопок (if (not (member bord '("Circle" "Rectangle"))) (mapcar 'action_tile '("add" "del" "up" "down") '("(if(and(<(length strsi)21)(= bord \"Lines\"))(add_dlg)(mode_tile(strcat \"str\"(itoa nedit))2))" "(if(and(/=(length strsi)1)(= bord \"Lines\"))(del_dlg)(mode_tile(strcat \"str\"(itoa nedit))2))" "(if(/= nedit 0)(up_dlg)(mode_tile(strcat \"str\"(itoa nedit))2))" "(if(/= nedit(1-(length strsi)))(down_dlg)(mode_tile(strcat \"str\"(itoa nedit))2))" ) ) ;_ mapcar ) ;_ if (action_tile "accept" "(accept_dlg)(setq dcl_xy (done_dialog dd))") (action_tile "help" "(alert_note)") (if nedit ;_ если это не первый вызов диалога (уже что то редактировалось) (mode_tile (strcat "str" (itoa nedit)) 2) ;_ установка фокуса на текущий editbox ) ) ;_ defun ;; *** конец создания файла dcl и инициализации окна диалога *** ;;--------------------------- ;;--------------------------- ;; нажатие кнопки "Ok" (defun accept_dlg (/ str nln estr) (setq nln 0) (setq dd 1) (while (/= nln (length strsi)) ; чтение из editbox'ов (if (= (vl-string-trim " " (setq estr (get_tile (strcat "str" (itoa nln))))) "") (setq dd 2) ; повторить диалог ) ;_ if (setq str (append str (list estr)) nln (1+ nln) ) ;_ setq ) ;_ while (setq strsi str) ) ;_ defun ;;--------------------------- ;; кнопка "Add" - добавить строку снизу (defun add_dlg (/ str nln) (if nedit (progn (setq nln 0) (while (/= nln (length strsi)) ; чтение из editbox'ов (setq str (append str (list (get_tile (strcat "str" (itoa nln)))))) (if (= nln nedit) (setq str (append str '(""))) ; новая пустая строка ) ;_ if (setq nln (1+ nln)) ) ;_ while (setq strsi str) ; новый список строк (if (/= nedit (1- (length strsi))) (setq nedit (1+ nedit)) ) ;_ if (setq dcl_xy (done_dialog 2)) ) ;_ progn (alert_note) ) ;_ if ) ;_ defun ;;--------------------------- ;; кнопка "Del" - удалить текущую строку (defun del_dlg (/ str nln) (if nedit (progn (setq nln 0) (while (/= nln (length strsi)) ; чтение из editbox'ов (if (/= nln nedit) ; пропуск текущей строки (setq str (append str (list (get_tile (strcat "str" (itoa nln)))))) ) ;_ if (setq nln (1+ nln)) ) ;_ while (setq strsi str) ; новый список строк (if (/= nedit 0) (setq nedit (1- nedit)) ; перейти на строку выше ) ;_ if (setq dcl_xy (done_dialog 3)) ) ;_ progn (alert_note) ) ;_ if ) ;_ defun ;;--------------------------- ;; кнопка "Up" - переместить строку вверх (defun up_dlg (/ str nln) (if nedit (progn (setq nln 0) (while (/= nln (length strsi)) ; чтение из editbox'ов (cond ((= nln nedit) (setq str (append str (list (get_tile (strcat "str" (itoa (1- nln)))))))) ((= nln (1- nedit)) (setq str (append str (list (get_tile (strcat "str" (itoa (1+ nln)))))))) (t (setq str (append str (list (get_tile (strcat "str" (itoa nln))))))) ) ;_ cond (setq nln (1+ nln)) ) ;_ while (setq strsi str ; новый список строк nln 0 ) ;_ setq (set_tile "bs" "") (while (/= nln (length strsi)) ; запись новых значений в editbox'ы (if (= (setq estr (nth nln strsi)) "") (set_tile "bs" "Blank string!") ) ;_ if (set_tile (strcat "str" (itoa nln)) estr) (setq nln (1+ nln)) ) ;_ while (mode_tile (strcat "str" (itoa (1- nedit))) 2) ; установка фокуса на текущий editbox ) ;_ progn (alert_note) ) ;_ if ) ;_ defun ;;--------------------------- ;; кнопка "Down" - переместить строку вниз (defun down_dlg (/ str nln) (if nedit (progn (setq nln 0) (while (/= nln (length strsi)) ; чтение из editbox'ов (cond ((= nln nedit) (setq str (append str (list (get_tile (strcat "str" (itoa (1+ nln)))))))) ((= nln (1+ nedit)) (setq str (append str (list (get_tile (strcat "str" (itoa (1- nln)))))))) (t (setq str (append str (list (get_tile (strcat "str" (itoa nln))))))) ) ;_ cond (setq nln (1+ nln)) ) ;_ while (setq strsi str ; новый список строк nln 0 ) ;_ setq (set_tile "bs" "") (while (/= nln (length strsi)) ; запись новых значений в editbox'ы (if (= (setq estr (nth nln strsi)) "") (set_tile "bs" "Blank string!") ) ;_ if (set_tile (strcat "str" (itoa nln)) estr) (setq nln (1+ nln)) ) ;_ while (mode_tile (strcat "str" (itoa (1+ nedit))) 2) ; установка фокуса на текущий editbox ) ;_ progn (alert_note) ) ;_ if ) ;_ defun ;; КОНЕЦ ВЛОЖЕННЫХ ФУНКЦИЙ РЕДАКТИРОВАНИЯ ;;------------------------------- ;;--------------------------------------------------------- ;; *** главная функция редактирования *** ;; ;; расшифровка, удаление блока и редактирование данных (setq strsi nil ; список строк nline 0 ; к-во линий в блоке nedit nil ;_ номер текущего editbox (при первом вызове кнопка Ok) ) ;_ setq (if (not (setq dcl_xy (vl-bb-ref 'vk_pblock))) ; исходное положение окна диалога (setq dcl_xy '(-1 -1)) ; по центру ) ;_ if ;; выбор объекта для редактирования и чтение данных из блока (while ; цикл выбора объекта (if (pbl_select) ; выбор блока (while ent ; цикл чтения данных из блока (setq data (cdr (assoc 0 (entget ent)))) (cond ; определение алглритма ((= data "TEXT") (setq strsi (cons (cdr (assoc 1 (entget ent))) strsi) ; текст hj (cdr (assoc 72 (entget ent))) ; горизонтальное выравнивание текста ptxt (cdr (assoc 10 (entget ent))) ; точка вставки stro strsi ; сохраним старый список строк ) ;_ setq ) ((= data "CIRCLE") (setq cen (cdr (assoc 10 (entget ent))) ; центр окружности относительно блока bord "Circle" ) ;_ setq ) ((= data "LINE") (setq bord "Lines" nline (1+ nline) ) ;_ setq ) ((= data "LWPOLYLINE") (setq bord "Rectangle")) ) ;_ cond (setq ent (entnext ent)) ; следующий примитив блока ) ;_ while возвращает всегда nil - выход из цикла выбора объекта t ; иначе - продолжить цикл выбора объекта ) ;_ if (princ " Filtred out...") ) ;_ while цикл выбора объекта ;; работа с диалогом (setq dlg_do 2) ; значение для повторного вызова диалога (while (> dlg_do 1) (pbl_dialog) ;; старт диалога (setq dlg_do (start_dialog)) (unload_dialog dcl_id) (vl-file-delete dclnm) ) ;_ while ;; диалог закрыт... идем дальше (if (= dlg_do 1) ; если нажато Ok или Enter (progn (setq ucsi (getvar "ucsicon")) (setvar "ucsicon" 0) ; отключение иконки UCS ;; чтение данных существующей вставки блока (setq vla:insert (vlax-ename->vla-object insert) ;_ объект i:color (vla-get-color vla:insert) ;_ цвет i:ltype (vla-get-linetype vla:insert) ;_ тип линии i:lscale (vla-get-linetypescale vla:insert) ;_ масштаб типа линии i:lw (vla-get-lineweight vla:insert) ;_ вес (толщина) линии i:layer (vla-get-layer vla:insert) ;_ слой ) ;_ setq (vlax-release-object vla:insert) (vl-cmdf "_.ucs" "_n" "_ob" insert) (setq ipt '(0.0 0.0 0.0)) ; точка вставки блока (0) ;; опознание режима "Twostring" или угол точки вставки блока для "Circle" (cond ((and (= bord "Lines") (= nline 1) (= (length strsi) 2) (= (length stro) 2)) ;_ 2 строки и 1 линия (setq bord "Twostring") ;_ значит это "Twostring" ) ((= bord "Circle") (setq ang (angle cen ipt))) ; угол на окружности точки вставки ) ;_ cond ;; отсоединим блок от всех выносок (foreach n lead (setq n (entget n)) (entmod (vl-remove (assoc 340 n) n))) (entdel insert) ; удалим вставку блока (setq temppt '(0.0 0.0) ; временная точка strsi (append strsi '(0)) ; признак окончания списка строк ) ;_ setq ;; для коррекции выравнивания блока и лидера используем ;; вторую точку (или стрелку) лидера (в текущей ПСК) (setq 2leadpt (trans (cdadr (reverse (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car lead))))) 0 1)) ;; нарисуем элементы блока (pbl_draw_elem) ;; переместим их на место, выберем выравнивание и скорректируем точку для перемещения (cond ((= bord "Twostring") (setq just "_l") (if (minusp (car ptxt)) (setq temppt (list x2 y1)) ) ;_ if ) ((= bord "Rectangle") (setq just "_mc") (if (minusp (car ptxt)) (setq temppt (list x2 y1)) ) ;_ if (if (minusp (cadr ptxt)) (setq temppt (list (car temppt) y2)) ) ;_ if ) ((= hj 1) (setq just "_mc")) ;_ кружочки ((< (car temppt) (car 2leadpt)) ;_ при правом выравнивании блока линий (setq just "_r" temppt (list (- txtm (car temppt)) (cadr temppt)) ) ;_ setq (if (= hj 0) ;_ при изменении выравнивания (setq ipt (append (list (+ (car ipt) (* 2 (car temppt)))) (cdr ipt)) temppt (append (list (- (car temppt))) (cdr temppt)) ) ) ) (t (setq just "_l") ;_ при левом выравнивании блока линий (if (= hj 2) ;_ при изменении выравнивания (setq ipt (append (list (+ (car ipt) (* 2 (car temppt)))) (cdr ipt)) temppt (append (list (- (car temppt))) (cdr temppt)) ) ) ) ) ;_ cond (if (null (member bord '("Lines" "Twostring" "Onestring"))) (vl-cmdf "_.move" ss "" temppt ipt) ) ;; вычислим новые координаты точек контура после перемещений (setq z 0.0 x1 (- x1 (car temppt)) x2 (- x2 (car temppt)) y1 (- y1 (cadr temppt)) ) ;_ setq (pbl_redraw) ; перерисуем набор заготовок (vk_moder mode3) ; восстановим цвет и слой ;; восстановление свойств в соответствии со старой вставкой блока (setq vla:insert (vlax-ename->vla-object (pbl_block))) ; создание блока и присоединение выносок (vla-put-color vla:insert i:color) ;_ цвет (vla-put-linetype vla:insert i:ltype) ;_ тип линии (vla-put-linetypescale vla:insert i:lscale) ;_ масштаб типа линии (vla-put-lineweight vla:insert i:lw) ;_ вес (толщина) линии (vla-put-layer vla:insert i:layer) ;_ слой (vlax-release-object vla:insert) (vl-cmdf "_.ucs" "_p") ; возврат UCS (setvar "ucsicon" ucsi) ; возврат иконки UCS ) ;_ progn ) ;_ if (vl-bb-set 'vk_pblock dcl_xy) ; сохраним положение окна ;; *** конец главной функции редактирования *** ) ;_ defun pbl_edit ;; *** конец всех функций редактирования *** ;;============================================================================ ;;-------------------------------------------------------------------------- ;; *** функция добавления линии выноски *** (defun pbl_addlead (/ insert ;_ примитив INSERT insdat ;_ (entget insert) bname ;_ имя блока lead ;_ список выносок ent ;_ первый примитив блока pt0 ;_ точка, указанная пользователем pt1 ;_ точка, указанная пользователем ptlst ;_ список точек lnlst ;_ список временных линий ucsi ;_ значение системной переменной ucsicon vla:lead ;_ новый Leader vla:old ;_ последний Leader tmp ;_ Временная переменная ) (pbl_select) ;_ выбор блока (setq ucsi (getvar "ucsicon")) (setvar "ucsicon" 0) ;_ отключение иконки UCS (setq vla:old (vlax-ename->vla-object (car lead))) ;_ последний Leader (vl-cmdf "_.ucs" "_n" "_ob" insert) (setq ipt '(0.0 0.0 0.0)) ;_ точка вставки блока (0) (initget 33) ;_ запрет пустого ввода + пунктир (setq pt0 (getpoint ipt "\nTo point... > ")) (setq pt1 (setq pt0 (list (car pt0) (cadr pt0)))) (setq ptlst (cons pt0 (list ipt))) (vl-cmdf "_.line" ipt pt0 "") (setq lnlst (list (entlast))) (initget 32 "Ok") ;_ пунктир (while (not (member (setq pt0 (getpoint pt0 "\nTo point... > or [Ok]: ")) '(nil "Ok"))) (setq ptlst (cons (setq pt0 (list (car pt0) (cadr pt0))) ptlst)) (vl-cmdf "_.line" pt1 pt0 "") (setq lnlst (cons (entlast) lnlst) pt1 pt0 ) ;_ setq (initget 32 "Ok") ;_ пунктир ) ;_ while (mapcar 'entdel lnlst) ;_ удаление временных линий (vl-cmdf "_.leader") (mapcar 'vl-cmdf ptlst) (vl-cmdf "_a" "" "_n") (setq vla:lead (vlax-ename->vla-object (entlast))) ;_ последний leader (vla-put-annotation vla:lead (vlax-ename->vla-object insert));_ приклеим блок к выноске (vla-put-color vla:lead (vla-get-color vla:old)) ;_ копирование свойств (vla-put-layer vla:lead (vla-get-layer vla:old)) (vla-put-lineweight vla:lead (vla-get-lineweight vla:old)) (vla-put-linetype vla:lead (vla-get-linetype vla:old)) (vla-put-linetypescale vla:lead (vla-get-linetypescale vla:old)) (vlax-release-object vla:lead) (vlax-release-object vla:old) (vl-cmdf "_.ucs" "_p") (setvar "ucsicon" ucsi) ;_ возврат иконки UCS ) ;_ defun ;; *** конец функции добавления линии выноски *** ;;-------------------------------------------------------------------------- ;;-------------------------------------------------------------------------- ;; *** Основной блок программы *** (defun pbl_main (bord / hmul) ; *** НАЧНЕМ... *** (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark doc) ; начнем группу для отмены командой _.U ;; сохранение и установка переменных (setq mode1 (vk_modes '("cmdecho" "blipmode" "limcheck" "ucsfollow" "celtype" "textstyle" "pickfirst")) mode2 (vk_modes '("osmode" "snapmode")) ; эти будут меняться часто mode3 (vk_modes '("cecolor" "clayer" "celweight" "celtype")) ; цвет, слой, толщина и тип линии modezer '("osmode" 0 "snapmode" 0) modeset (list "cmdecho" 0 "blipmode" 0 "limcheck" 0 "ucsfollow" 0 "celtype" ; тип линий "CONTINUOUS" "CONTINUOUS" "textstyle" ; стиль текста как в стиле размера (getvar "dimtxsty") "cecolor" ; цвет byblock, "0" "clayer" ; текущий слой "0", "0" "celweight" ; толщина линии byblock для примитивов блока -2 "celtype" ; тип линии "ByBlock" "pickfirst" ; очистим текущий выбор 1 ) ;_ list ) ;_ setq (cond ;; проверка состояния слоя "0" ((= (logand 1 (cdr (assoc 70 (setq layget (tblsearch "LAYER" "0"))))) 1) (alert "Слой \"0\" заморожен!\n\nДальнейшая работа команды, увы, невозможна...") (exit) ) ((= (logand 4 (cdr (assoc 70 layget))) 4) (alert "Слой \"0\" заблокирован!\n\nДальнейшая работа команды, увы, невозможна...") (exit) ) ((minusp (cdr (assoc 62 layget))) (princ "\nСлой \"0\" для объектов блока отключен! Работа будет продолжена \"в слепую\"") ) ;; проверка состояния текщего слоя ((= (logand 1 (cdr (assoc 70 (setq layget (tblsearch "LAYER" (setq insl (getvar "clayer"))))))) 1) (alert (strcat "Слой \"" insl "\" заморожен!\n\nДальнейшая работа команды, увы, невозможна...")) (exit) ) ((= (logand 4 (cdr (assoc 70 layget))) 4) (alert (strcat "Слой \"" insl "\" заблокирован!\n\nДальнейшая работа команды, увы, невозможна...")) (exit) ) ((minusp (cdr (assoc 62 layget))) (princ (strcat "\nСлой \"" insl "\" для вставки блока отключен! Работа будет продолжена \"в слепую\".") ) ;_ princ ) ) ;_ cond ;; определим параметры (vk_moder modeset) ;_ установка переменных (setq stdat (if (and (setq stdat (vl-bb-ref 'vk_pblock_style)) ;_ извлечение данных текстового стиля (= (type stdat) 'STRR) (setq stdat (tblsearch "STYLE" stdat)) ) ;_ and stdat (tblsearch "STYLE" (getvar "dimtxsty")) ) ;_ if vscale (cond ((= (getvar "tilemode") 1) ;_ в Модели (if (and (> (getvar "dimscale") 0) (vl-bb-ref 'vk_pblock_dimscale) ) ;_ and (/ 1.0 (getvar "dimscale")) ;_ берем коэфф. из размерного стиля 1.0 ) ;_ if ) ((and (= (getvar "tilemode") 0) ;_ "tilemode" = 0 - находимся в Листе (/= (caar (vports)) 1) ;_ и активный какой то ВЭ ) ;_ and (vla-get-customscale (vla-get-activepviewport doc)) ; масштаб текущего ВЭ ) (t 1.0) ;_ в остальных случаях (Лист) масштаб = 1 ) ;_ cond hmul (if (and (setq hmul (vl-bb-ref 'vk_pblock_hmul)) ;_ задан коэфф. увеличения высоты текста (= (type hmul) 'REAL) (> hmul 0.0) ) ;_ and hmul 1.0 ) ;_ if temppt (list (+ (car (getvar "VSMAX")) (* 100 vscale)) ; временная точка (+ (cadr (getvar "VSMAX")) (* 100 vscale)) ; за пределами видимости ) ;_ list th (/ (* hmul (if (and (setq th (vl-bb-ref 'vk_pblock_thfix)) ;_ пользовательская высота текста (= (type th) 'REAL) (> th 0.0) ) ;_ and th (getvar "DIMTXT") ;_ высота текста из димстиля ) ;_ if ) ;_ * vscale ) ;_ / gap (/ (* hmul (if (and (setq gap (vl-bb-ref 'vk_pblock_gapfix)) ;_ пользовательский зазор от текста (= (type gap) 'REAL) (> gap 0.0) ) ;_ and gap (getvar "DIMGAP") ;_ зазор из димстиля ) ;_ if ) ;_ * vscale ) ;_ / txtm (* th (/ (sin (cdr (assoc 50 stdat))) (cos (cdr (assoc 50 stdat)))) 0.4) ; смещение текста ss (ssadd) ; создаем наборчик just "_mc" ; изначально выравнивание текста tcolor (if (and (setq tcolor (vl-bb-ref 'vk_pblock_tcolor)) ;_ цвет текста (= (type tcolor) 'INT) (>= tcolor 0) (<= tcolor 256) ) tcolor 0 ) ;_ if tlayer (if (and (setq tlayer (vl-bb-ref 'vk_pblock_tlayer)) ;_ слой текста (= (type tlayer) 'STR) ) tlayer "0" ) lcolor (if (and (setq tcolor (vl-bb-ref 'vk_pblock_lcolor)) ;_ цвет текста (= (type tcolor) 'INT) (>= tcolor 0) (<= tcolor 256) ) tcolor 0 ) ;_ if llayer (if (and (setq tlayer (vl-bb-ref 'vk_pblock_llayer)) ;_ слой текста (= (type tlayer) 'STR) ) tlayer "0" ) ) ;_ setq ;; если нет слоя для текста - создадим его (vla-add (vla-get-layers doc) tlayer) (vk_moder modezer) ; отключим привязки (cond ; выбор действия сообразно введенной опции ((= bord "Edit") (pbl_edit)) ; редактировать существующий блок ((= bord "Addleader") (pbl_addlead)) ; добавить Leaders (t ;; рисуем обычные выноски (не координаты) (if (and (/= bord "Xy") (/= bord "2xy")) (pbl_draw_elem) ) ;_ if ;; определим точку начала линии выноски (vk_moder mode2) ; восстановим привязки (initget 5) ; надо обязать юзера указать начальную точку (setq spt (getpoint "\nStart of leader: ") z (caddr spt) ; Z - координата плоскости построения ) ;_ setq ;; здесь юзер мог изменить настройки привязок. (setq mode2 (vk_modes '("osmode" "snapmode"))) ;_ сохраним новые привязки (vk_moder modezer) ; отключим привязки ;; рисуем координаты в одну или две строки (if (or (= bord "Xy") (= bord "2xy")) (pbl_coord) ) ;_ if ;; помещаем наборчик в точку старта выноски. Видно! (vl-cmdf "_.move" ss "" temppt spt) ;; перемещение набора в указанное юзером место (vk_moder mode2) ; восстановим привязки (while (progn ; повторять пока не будет указана точка (prompt "\nBlock position: ") (command "_.move" ss "" "_non" spt pause) (setq ept (getvar "lastpoint")) ; посмотрим, куда юзер ткнул (if (< (distance (list (car ept) (cadr ept)) (list (car spt) (cadr spt))) 1e-9) (vl-cmdf "_.undo" 1) ; пустой ввод? - отмена, возврат (t) - повтор цикла ) ;_ if ) ;_ progn ) ;_ while ;; здесь юзер мог изменить настройки привязок. сохраним новые привязки (setq mode2 (vk_modes '("osmode" "snapmode"))) ;_ сохраним новые привязки (vk_moder modezer) ;_ отключим привязки (vl-cmdf "_.move" ss "" ept (setq ept (list (car ept) (cadr ept) z))) ; вернем Z! ;; вычислим новые координаты точек контура после перемещений (setq x1 (- (+ x1 (car ept)) (car temppt)) x2 (- (+ x2 (car ept)) (car temppt)) y1 (- (+ y1 (cadr ept)) (cadr temppt)) y2 (- (+ y2 (cadr ept)) (cadr temppt)) ) ;_ setq ;; выберем ближайшую точку по X и выравнивание текста (if (>= (abs (- x1 (car spt))) (abs (- x2 (car spt)))) (setq x x2 just "_r" ) ;_ setq (setq x x1 just "_l" ) ;_ setq ) ;_ if ;; для координат: переход алгоритма и установка опции выравнивания (if (or (= bord "Xy") (= bord "2xy")) (setq bord "Twostring" just "_l" ) ;_ setq ) ;_ if ;; для прямоугольника: выберем ближайшую точку по Y (if (and (= bord "Rectangle") (> (abs (- y1 (cadr spt))) (abs (- y2 (cadr spt))))) (setq y y2) (setq y y1) ) ;_ if ;; перерисуем набор заготовок (pbl_redraw) ;; нарисуем линию выноски (vk_moder mode3) ; восстановим цвет, слой и толщину линии (if (= bord "Circle") ; для окружности (vl-cmdf "_.leader" ; создадим выноску spt ;; найдем точку вставки блока и конец линии выноски для окружности (setq ipt (polar spt (angle spt ept) (- (distance spt ept) rad))) "_a" "" "_n" ) ;_ vl-cmdf (vl-cmdf "_.leader" spt (setq ipt (list x y z)) "_a" "" "_n") ; выноска и точка вставки ) ;_ if (setq lead (list (entlast))) ; список выносок ;; создание блока и присоединение выносок (pbl_block) ) ) ;_ cond ; *** ВСЕ !!! *** (vk_moder mode3) ; восстановим цвет, слой и толщину линии (vk_moder mode2) ; восстановление привязок (vk_moder mode1) ; и других переменных (redraw) (vla-endundomark doc) ; завершим группу UNDO (vlax-release-object doc) (setq doc nil) ) ;_ defun ;; *** конец основного блока программы *** ;;-------------------------------------------------------------------------- ;;========================================================================================== ;; *** непосредственно программа *** ;; ввод опции (initget 0 "Multiple Lines Rectangle Circle Onestring Twostring Xy 2xy Edit Addleader") (if (= (setq mode (getkword "\nEnter option? [Multiple/Lines/Rectangle/Circle/OneString/TwoString/XY/2XY/Edit/AddLeader] <Lines>:" ) ;_ getkword ) ;_ setq "Multiple" ) ;_ = (progn ; выбрано "Multiple" - вводим вторую опцию (initget 0 "Lines Rectangle Circle Onestring Twostring Xy 2xy Edit Addleader") (if (setq mode (getkword "\nEnter option? [Lines/Rectangle/Circle/OneString/TwoString/XY/2XY/Edit/AddLeader] <Lines>:" ) ;_ getkword ) ;_ setq t (setq mode "Lines") ; по умолчанию ) ;_ if (while t (pbl_main mode)) ; зациклено! ) ;_ progn (pbl_main (if mode ; однократно mode "Lines" ; по умолчанию ) ;_ if ) ;_ pbl_main ) ;_ if (gc) (princ) ) ;_ defun ;; *** конец непосредственно программы *** ;;========================================================================================== (vl-load-com) (regapp "pblock") ;_ регистрация приложения для расширенных данных (princ "\nПростановка позиций с выноской (версия от 04.02.2007)") (princ "\n©2003 Владимимр Клещёв e-mail: vla-kleschev@yandex.ru") (princ "\nВызов из командной строки: PBLOCK")