LISP. LIB. Функция - расширение для vla-getboundingbox

; Функция: VLA-GETBOUNDINGBOX-EX.
; Представляет собой оболочку-расширение для встроенной vla-функции получения габаритного контейнера примитива.
; Вычисляет точки габаритного контейнера примитива в координатах указанной ПСК.
; ПСК задается единичными векторами осей X и Y и точкой начала координат (все параметры относительно МСК)
; и передается в функцию с помощью 4-го, 5-го и 6-го аргументов.
; Записывает в переменные, указанные во 2-м и 3-м арументах, значения для минимальной и максимальной точек контейнера.
; Из функции происходит обращение к внешней константе ::active_doc - указателю на активный документ.
; Возвращает Т при успешном завершении и nil в противном случае.
(defun vla-getboundingbox-ex (
vlao; VLA-объект.
                  vla-getboundingbox-ex::min; содержит имя переменной для возврата списка мин.точки контейнера.
                  vla-getboundingbox-ex::max; содержит имя переменной для возврата списка макс.точки контейнера.
                  xdir; вариант - единичный вектор оси X ПСК.
                  ydir; вариант - единичный вектор оси Y ПСК.
                  orig; вариант - точка начала ПСК.
                  /
                  is_error; флаг ошибки.
                  ucss; указатель на семейство ПСК.
                  ucs; указатель на ПСК.
                  matrix; матрица прямого преобразования.
                  tmatrix; транспонированная матрица.
                  i; счетчик цикла.
                  j; счетчик цикла.
                  acc; буфер.
                  item; текущий элемент массива.
                  torig; преобразованная точка начала ПСК.
                  fantom; временная копия примитива.
                  lays; указатель на семейство слоев документа
                  lay; указатель на слой временной копии.
                  lock_status; статус слоя временной копии.
                  minp; буфер.
                  maxp; буфер.
                  )
  (setq is_error
     (vl-catch-all-apply
       (function
         (lambda ()
           (setq ucss (vlax-get-property ::active_doc 'UserCoordinateSystems))
           (setq ucs (vlax-invoke-method ucss 'add (vlax-3d-point '(0.0 0.0 0.0)) xdir ydir "vla-getboundingbox-ex"))
           (vlax-release-object ucss)
           (setq matrix (vlax-variant-value (vlax-invoke-method ucs 'getucsmatrix))); 4x4 массив- матрица преобразования.
           (vlax-invoke-method ucs 'delete)
           (vlax-release-object ucs)
           ;
           ; Формирование транспонированной матрицы и одновременный пересчет точки начала ПСК:
           (setq orig (append (vlax-safearray->list (vlax-variant-value orig)) (list 1.0)))
           (setq tmatrix (vlax-make-safearray vlax-vbdouble '(0 . 3) '(0 . 3)))
           (setq i 0)
           (repeat 4
         (setq j 0)
         (setq acc 0.0)
         (repeat 4
           (setq item (vlax-safearray-get-element matrix j i))
           (vlax-safearray-put-element tmatrix i j item)
           (setq acc (+ acc (* item (nth j orig))))        
           (setq j (1+ j))
         ); end repeat.
         (setq torig (cons acc torig))
         (setq i (1+ i))
           ); end repeat.
           (setq torig (reverse (cdr torig))); список из 3х координат.
           (setq tmatrix (vlax-make-variant tmatrix (+ vlax-vbarray vlax-vbdouble))); вариант с транспонированной матрицей.
           ;
           (setq fantom (vlax-invoke-method vlao 'copy)); VLA-указатель объекта-двойника.
           (setq lays (vlax-get-property ::active_doc 'layers))
           (setq lay (vlax-invoke-method lays 'item (vlax-get-property fantom 'layer)))
           (vlax-release-object lays)
           (cond
         ((equal (vlax-get-property lay 'lock) :vlax-true)
          (setq lock_status :vlax-true)
          (vlax-put-property lay 'lock :vlax-false)
         );
         (T (setq lock_status :vlax-false));
               ); end cond.
           (vlax-put-property fantom 'visible :vlax-false); oтключение видимости.
           ;
           ; Применение транспонированной матрицы к копии объекта и вычисление габаритного контейнера:
           (vlax-invoke-method fantom 'transformby tmatrix)
           (vlax-invoke-method fantom 'getboundingbox 'minp 'maxp)
           (vlax-invoke-method fantom 'delete)
           (vlax-release-object fantom)
           ;
           (vlax-put-property lay 'lock lock_status)
           (vlax-release-object lay)
           ;
           (set vla-getboundingbox-ex::min (vlax-3d-point (mapcar '- (vlax-safearray->list minp) torig))); ref return.
           (set vla-getboundingbox-ex::max (vlax-3d-point (mapcar '- (vlax-safearray->list maxp) torig))); ref return.
         ); lambda.
       ); function.
     ); vl-catch-all-apply.
  ); setq is_error.
  (cond
    ((vl-catch-all-error-p is_error)
     (vl-catch-all-apply 'vlax-release-object (list ucss))
     (vl-catch-all-apply 'vlax-invoke-method (list ucs 'delete))
     (vl-catch-all-apply 'vlax-release-object (list ucs))
     (vl-catch-all-apply 'vlax-invoke-method (list fantom 'delete))
     (vl-catch-all-apply 'vlax-release-object (list fantom))
     (vl-catch-all-apply 'vlax-release-object (list lays))
     (vl-catch-all-apply 'vlax-put-property (list lay 'lock lock_status))
     nil; vla-getboundingbox-ex return.
    );
    (T T); vla-getboundingbox-ex return.
  ); end cond.
); end defun.
; Функция для тестирования.
; Определяет габаритный контейнер указанного примитива в координатах текущей ПСК.
(defun c:test ( / org xdir ydir minb maxb)
  (setq org (vlax-3d-point (getvar 'ucsorg)))
  (setq xdir (vlax-3d-point (getvar 'ucsxdir)))
  (setq ydir (vlax-3d-point (getvar 'ucsydir)))
  ;
  (vla-getboundingbox-ex (vlax-ename->vla-object (car(entsel))) 'minb 'maxb xdir ydir org)
  ;
  (princ (vlax-safearray->list(vlax-variant-value minb)))
  (princ (vlax-safearray->list(vlax-variant-value maxb)))
  (gc)
  (princ)
);