pblock.lsp.20070204

Материал из Lblss.ru
Перейти к: навигация, поиск

Информация

Проект: 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")
Персональные инструменты