Сообщество программистов Autodesk в СНГ :: Прозрачность в AutoCAD средствами lisp

Сообщество программистов Autodesk в СНГ
AutoLISP/VisualLISP и DCL
Прозрачность в AutoCAD средствами lisp

15/01/2015

Прозрачность в AutoCAD средствами lisp

Понадобилось тут "поиграться" с прозрачностью примитивов и слоев в AutoCAD. Это оказалось очень интересно и очень познавательно.

Прежде чем двигаться дальше, понадобится вспомнить, что само понятие прозрачности появилось в AutoCAD 2011. В AutoCAD 2009 (других версий просто нет) было понятие "растр либо прозрачен, либо нет", но установить прозрачность равной, например, 15%, было невозможно.

Итак, попробуем разобраться с установлением и изменением прозрачности:

графических примитивов
слоев

Конечно, идеальным был бы вариант установки прозрачности через ActiveX – тогда можно будет безболезненно менять прозрачность даже в неактивном документе. Но, к сожалению, тут не все просто.

Во-первых, возникает путаница с самим понятие "прозрачности" для растров и масок: этим примитивам можно установить свойство Transparency в :vlax-true, повторив ситуацию с более старыми версиями AutoCAD. А для "процентной" прозрачности используется EntityTransparency. То есть, казалось бы, можно нарисовать код установки прозрачности примитиву:

Код - Auto/Visual LISP: [Выделить]

(vl-load-com)
(defun set-ent-trans-vla (ent tr / err res)
                         ;|
    * Установка прозрачности для примитива
    * Параметры вызова:
    ent - vla-указатель на графический примитив. Не контролируется
    tr - устанавливаемое значение прозрачности. Строка или целое число
    |;
  (cond
    ((not (vlax-property-available-p ent 'entitytransparency t))
     (princ "\nEntityTRansparency not available")
     )
    ((vl-catch-all-error-p
       (setq err (vl-catch-all-apply
                   (function
                     (lambda ()
                       (vla-put-entitytransparency ent tr)
                       ) ;_ end of lambda
                     ) ;_ end of function
                   ) ;_ end of vl-catch-all-apply
             ) ;_ end of setq
       ) ;_ end of vl-catch-all-error-p
     (princ (strcat "\nError set EntityTransparency property : "
                    (vl-catch-all-error-message err)
                    ) ;_ end of strcat
            ) ;_ end of princ
     )
    (t
     (vla-get-entitytransparency ent)
     )
    ) ;_ end of cond
  ) ;_ end of defun

Но! Попробуем задать прозрачность "ByLayer" ("ПоСлою") или "ByBlock" ("ПоБлоку")! Что проще, казалось бы! Задаем в качестве tr прямо строку – "ByLayer", и все!

И все? Нет, не получится. Стоит код запустить в русской версии AutoCAD, и вместо "bylayer" придется передавать "послою". Сильно подозреваю, что при работе в других локализациях ситуация будет аналогичной. Конечно, от безысходности можно и такое использовать, но попробуем все же работу через ename-представления. Понятно, что это практически гарантированно отключает работу в неактивном документе и осложняет обработку блоков, но что поделать…

Внимательно посмотрев DXF Reference, мы можем увидеть новую необязательную группу: 440. Именно ее значение и регулирует значение прозрачности. Кажется, вот оно! Но несколько экспериментов по установке прозрачности "ПоСлою" у меня сначала потерпели полное фиаско. Спасибо Александру Ривилису, он подсказал решение. Всего-то надо установить в 440 группу значение 0, и она исчезает. Благодаря Евгению Елпанову, показавшему весьма оригинальный вариант на обсуждении исходной статьи, можно нарисовать код:

Код - Auto/Visual LISP: [Выделить]

(defun set-ent-transparency (ent tr / eval_value)
                            ;|
    * Установка прозрачности ename-представлению примитива (не слоя!)
    * Параметры вызова:
    ent ename-указатель на графический примитив
    tr устанавливаемое значение прозрачности. Строка или целое число (для нецелых дробная часть отсекается)
    |;
  (defun eval_value (value)
    (+ 33554431 (fix (* (- 100 value) 2.56)))
    ) ;_ end of defun
  (_kpblc-ent-modify-autoregen
    ent
    440
    (cond
      ((and (/= (type tr) 'str) (> tr 90.)) (eval_value 90))
      ((member (type tr) (list 'real 'int)) (eval_value (fix tr)))
      ((and (= (type tr) 'str) (= (strcase tr) "BYBLOCK"))
       16777216
       )
      (t 0)
      ) ;_ end of cond
    t
    ) ;_ end of _kpblc-ent-modify-autoregen
  ) ;_ end of defun

Используется функция модификации ename-примитива:

Код - Auto/Visual LISP: [Выделить]

(defun _kpblc-ent-modify-autoregen
                                   (ent bit value ext_regen / ent_list old_dxf new_dxf)
                                   ;|
    * Функция модификации указанного бита примитива
    * Параметры вызова:
    * entity - примитив, полученный через (entsel), (entlast) etc
    * bit - dxf-код, значение которого надо установить
    * value - новое значение
    * regen - выполнять или нет регенерацию примитива сразу. t/ nil
    * Примеры вызова:
    (_kpblc-ent-modify-autoregen (entlast) 8 "0" t) ; перенести последний примитив на слой 0
    (_kpblc-ent-modify-autoregen (entsel) 62 10 nil) ; установить выбранному примитиву цвет 10
    * Возвращаемое значение:
    * примитив с модифицированным dxf-списком. Примитив перерисовывается в
    * зависимости от значения ключа ext_regen
    |;
  (if
    (not
      (and (or (= (strcase (cdr (assoc 0 (entget ent))) nil) "STYLE")
               (= (strcase (cdr (assoc 0 (entget ent))) nil) "DIMSTYLE")
               (= (strcase (cdr (assoc 0 (entget ent))) nil) "LAYER")
               ) ;_ end of or
           (= bit 100)
           ) ;_ end of and
      ) ;_ end of not
     (progn (setq ent_list (entget ent)
                  new_dxf  (cons bit
                                 (if (and (= bit 62) (= (type value) 'str))
                                   (if (= (strcase value) "BYLAYER")
                                     256
                                     0
                                     ) ;_ end of if
                                   value
                                   ) ;_ end of if
                                 ) ;_ end of cons
                  ) ;_ end of setq
            (if (not (equal new_dxf (setq old_dxf (assoc bit ent_list))))
              (progn (entmod (if old_dxf
                               (subst new_dxf old_dxf ent_list)
                               (append ent_list (list new_dxf))
                               ) ;_ end of if
                             ) ;_ end of entmod
                     (if ent_regen
                       (entupd ent)
                       (redraw ent)
                       ) ;_ end of if
                     ) ;_ end of progn
              ) ;_ end of if
            ) ;_ end of progn
     ) ;_ end of if
  ent
  ) ;_ end of defun

Теперь можно передавать в функцию числа и строки "bylayer" и "byblock", не учитывая локализацию. Но, повторюсь, решение будет работать только с текущим документом. Хотя Евгений и предложил вариант

Код - Auto/Visual LISP: [Выделить]

(entmod (entget (vlax-vla-object->ename ent)))

Но я не очень доверяю подобным преобразованиям, особенно если они касаются неактивного документа. Может быть, срабатывает моя паранойя :)

Теперь попробуем разобраться с прозрачностью слоев. Тут все становится очень и очень интересно. Найдем, где и как AutoCAD хранит данные о прозрачности слоя.

Попробуем сначала поработать с ActiveX-представлением слоя:

Код - Auto/Visual LISP: [Выделить]

$ (vlax-dump-Object (vla-item (vla-get-layers (vla-get-ActiveDocument (vlax-get-acad-object))) "0") t)
; IAcadLayer: A logical grouping of data, similar to transparent acetate overlays on a drawing
; Property values:
;   Application (RO) = #
;   Description = ""
;   Document (RO) = #
;   Freeze = 0
;   Handle (RO) = "10"
;   HasExtensionDictionary (RO) = -1
;   LayerOn = -1
;   Linetype = "Continuous"
;   Lineweight = -3
;   Lock = 0
;   Material = "Global"
;   Name = "0"
;   ObjectID (RO) = 42
;   ObjectID32 (RO) = 42
;   ObjectName (RO) = "AcDbLayerTableRecord"
;   OwnerID (RO) = 43
;   OwnerID32 (RO) = 43
;   PlotStyleName = "Color_7"
;   Plottable = -1
;   TrueColor = #
;   Used (RO) = -1
;   ViewportDefault = 0
; Methods supported:
;   Delete ()
;   GetExtensionDictionary ()
;   GetXData (3)
;   SetXData (2)

Как видно, в свойствах слоя попросту отстутствует что бы то ни было, имеющее отношение к Transparency. Поэтому для исследования берем ename-представление слоя:

Код - Auto/Visual LISP: [Выделить]

_$ (entget (tblobjname "layer" "0") '("*"))
'((-1 . <entity name: 7ffffb03900>)
  (0 . "LAYER")
  (5 . "10")
  (102 . "{ACAD_XDICTIONARY")
  (360 . <entity name: 7ffffb05240>)
  (102 . "}")
  (330 . <entity name: 7ffffb03820>)
  (100 . "AcDbSymbolTableRecord")
  (100 . "AcDbLayerTableRecord")
  (2 . "0")
  (70 . 0)
  (62 . 7)
  (6 . "Continuous")
  (290 . 1)
  (370 . -3)
  (390 . <entity name: 7ffffb038f0>)
  (347 . <entity name: 7ffffb03ee0>)
  (348 . <entity name: 0>)
  )

(Возвращаемый результат приведен в удобочитаемый вид)

После этого вручную установим слою прозрачность и выполним повторный entget:

Код - Auto/Visual LISP: [Выделить]

_$ (entget (tblobjname "layer" "0") '("*"))
'((-1 . <entity name: 7ffffb03900>)
  (0 . "LAYER")
  (5 . "10")
  (102 . "{ACAD_XDICTIONARY")
  (360 . <entity name: 7ffffb05240>)
  (102 . "}")
  (330 . <entity name: 7ffffb03820>)
  (100 . "AcDbSymbolTableRecord")
  (100 . "AcDbLayerTableRecord")
  (2 . "0")
  (70 . 0)
  (62 . 7)
  (6 . "Continuous")
  (290 . 1)
  (370 . -3)
  (390 . <entity name: 7ffffb038f0>)
  (347 . <entity name: 7ffffb03ee0>)
  (348 . <entity name: 0>)
  (-3 ("AcCmTransparency" (1071 . 33554646)))
  )

Становится интересно: появились расширенные данные для приложения "AcCmTransparency". Напрашивающееся внесение или изменение этих данных "просто так" результата может и не дать: требуется регистрация приложения "AcCmTransparency". Поскольку работа выполняется только в текущем документе, то достаточно выполнить строку

Код - Auto/Visual LISP: [Выделить]

(regapp "AcCmTransparency")

После этого становится возможным внести соответствующие изменения в представление слоя. Код получается достаточно простой:

Код - Auto/Visual LISP: [Выделить]

(vl-load-com)
(defun layer-trans-vla (name tr / ent xd xt adoc err)
  ;; name : имя слоя
  ;; tr : прозрачность, число от 0 до 90
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-add (vla-get-registeredapplications adoc)
           "AcCmTransparency"
           ) ;_ end of vla-add
  (if (vl-catch-all-error-p
        (setq err (vl-catch-all-apply
                    (function
                      (lambda ()
                        (setq ent (vla-item (vla-get-layers adoc) name))
                        (vla-getxdata ent "AcCmTransparency" 'xt 'xd)
                        (setq xt (if xt
                                   (vlax-safearray->list xt)
                                   (list 1001 1071)
                                   ) ;_ end of if
                              xd (if xd
                                   (mapcar (function vlax-variant-value)
                                           (vlax-safearray->list xd)
                                           ) ;_ end of mapcar
                                   (list "AcCmTransparency" 0)
                                   ) ;_ end of if
                              xd (mapcar (function cons) xt xd)
                              xd (subst (cons 1071
                                              (+ 33554431
                                                 (fix (* (- 100
                                                            (fix (cond
                                                                   ((> tr 90.) 90)
                                                                   ((< tr 0.) 0)
                                                                   (t tr)
                                                                   ) ;_ end of cond
                                                                 ) ;_ end of fix
                                                            ) ;_ end of -
                                                         2.56
                                                         ) ;_ end of *
                                                      ) ;_ end of fix
                                                 ) ;_ end of +
                                              ) ;_ end of cons
                                        (assoc 1071 xd)
                                        xd
                                        ) ;_ end of subst
                              ) ;_ end of setq
                        (vla-setxdata
                          ent
                          (vlax-safearray-fill
                            (vlax-make-safearray
                              vlax-vbinteger
                              (cons 0 (1- (length xd)))
                              ) ;_ end of vlax-make-safearray
                            (mapcar (function car) xd)
                            ) ;_ end of vlax-safearray-fill
                          (vlax-safearray-fill
                            (vlax-make-safearray
                              vlax-vbvariant
                              (cons 0 (1- (length xd)))
                              ) ;_ end of vlax-make-safearray
                            (mapcar
                              (function
                                (lambda (x)
                                  (vlax-make-variant (cdr x))
                                  ) ;_ end of LAMBDA
                                ) ;_ end of function
                              xd
                              ) ;_ end of mapcar
                            ) ;_ end of vlax-safearray-fill
                          ) ;_ end of vla-setxdata
                        ) ;_ end of lambda
                      ) ;_ end of function
                    ) ;_ end of vl-catch-all-apply
              ) ;_ end of setq
        ) ;_ end of vl-catch-all-error-p
    (princ
      (strcat "\nError : " (vl-catch-all-error-message err))
      ) ;_ end of princ
    ) ;_ end of if
  (command "_.regenall")
  ) ;_ end of defun

И для варианта обработки ename-представления:

Код - Auto/Visual LISP: [Выделить]

(defun layer-trans-ename (name tr / ent xd value)
  ;; name : имя слоя
  ;; tr : прозрачность, число от 0 до 90
  (setq ent   (tblobjname "layer" name)
        ent   (entget ent '("*"))
        xd    (cdr (assoc -3 ent))
        value (+ 33554431
                 (fix (* (- 100
                            (fix (cond
                                   ((> tr 90.) 90)
                                   ((< tr 0.) 0)
                                   (t tr)
                                   ) ;_ end of cond
                                 ) ;_ end of fix
                            ) ;_ end of -
                         2.56
                         ) ;_ end of *
                      ) ;_ end of fix
                 ) ;_ end of +
        ) ;_ end of setq
  (regapp "AcCmTransparency")
  (setq xd
         (if xd
           (subst
             (cons "AcCmTransparency"
                   (subst (cons 1071 value)
                          (assoc 1071 (cdr (assoc "AcCmTransparency" xd)))
                          (cdr (assoc "AcCmTransparency" xd))
                          ) ;_ end of subst
                   ) ;_ end of cons
             (assoc "AcCmTransparency" xd)
             xd
             ) ;_ end of subst
           (cons "AcCmTransparency" (list (cons 1071 value)))
           ) ;_ end of if
        ) ;_ end of setq
  (entmod (if (assoc -3 ent)
            (subst (cons -3 xd) (assoc -3 ent) ent)
            (append ent (list (list -3 xd)))
            ) ;_ end of if
          ) ;_ end of entmod
  (entupd (cdr (assoc -1 ent)))
  (command "_.regenall")
  ) ;_ end of defun

Но при этом следует учитывать несколько дополнительных моментов:

Открытый диспетчер слоев может не отобразить внесенные изменения, хотя слой изменится
Модификация через ename приводит к моментальному изменению слоя и всех примитивов, ему принадлежащих. Обработка через vla к такому не приводит. Возможно, понадобится дополнительно проходить по всем примитивам, принадлежащим этому слою, и выполнять из обновление (я такого кода не рисовал)
Повторное открытие файла с прозрачностью, измененной через ActiveX-представление, покажет корректные результаты
Выполнение команды _.regen или _.regenall при обработке через ActiveX никакого видимого эффекта не дает

Остались совсем мелочи: получить установленное значение прозрачности примитива

Код - Auto/Visual LISP: [Выделить]

(defun get-ent-trans-ename (ent / res)
                           ;|
    * Получение прозрачности слоя / примитива
    * Параметры вызова:
    ent - ename-указатель на примитив
    |;
  (cond
    ((and (setq res (cdr (assoc 440 (entget ent))))
          (= res 16777216)
          ) ;_ end of and
     "byblock"
     )
    ((or (setq res (cdr (assoc 440 (entget ent))))
         (setq res (cdr
                     (assoc
                       1071
                       (cdar
                         (cdr
                           (assoc -3
                                  (entget ent '("AcCmTransparency"))
                                  ) ;_ end of assoc
                           ) ;_ end of cdr
                         ) ;_ end of cdar
                       ) ;_ end of assoc
                     ) ;_ end of cdr
               ) ;_ end of setq
         ) ;_ end of or
     (fix (- 100 (/ (logand res -33554433) 2.55)))
     )
    ) ;_ end of cond
  ) ;_ end of defun

и то же самое, но для слоя:

Код - Auto/Visual LISP: [Выделить]

(defun get-layer-trans-ename (name / ent res)
                             ;|
* Получение прозрачности для слоя.
* Параметры вызова:
  name имя слоя
  Если прозрачность не устанавливалась, возвращается nil
|;
  (if (setq ent (tblobjname "layer" name))
    (if (setq res
               (cdr (assoc
                      1071
                      (cdadr (assoc -3 (entget ent '("AcCmTransparency"))))
                      ) ;_ end of assoc
                    ) ;_ end of cdr
              ) ;_ end of setq
      (fix (- 100 (/ (logand res -33554433) 2.55)))
      ) ;_ end of if
    ) ;_ end of if
  ) ;_ end of defun