до работка конвектора(защита файла)

DEM · 15.10.2007, 15:10

Задача состоит в следующем.
Есть конвектор "ESConvert" от Эдуарда Смолянка и Пётр Лоскутова.
Требуется несколько доработать его т.к. есть возможность распечатки.
Хотелось бы перевести все примитивы черт. в слой Defpoints, при этом сохранив цвет и вес примитива как в исходном слое, если же что то изменили то в присвоеном значении.

VVA · 15.10.2007, 16:09

Пробуй

Код:

[Выделить все]

;;Функция переводит все примитивы черт. в слой Defpoints
;; при этом сохраняя цвет и вес примитива как в исходном слое, если же что то изменили то в присвоеном значении
;;http://dwg.ru/f/showthread.php?p=174556#post174556
(defun change-objects-color&lw ( / lays lay color truecolor doc count mip:layer-status-restore mip:layer-status-save bn)
    (defun mip:layer-status-restore () 
    (foreach item *MIP_LAYER_LST*
      (if (not (vlax-erased-p (car item))) 
        (vl-catch-all-apply 
          '(lambda () 
             (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
             (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
             ) ;_ end of lambda 
          ) ;_ end of vl-catch-all-apply 
        ) ;_ end of if 
      ) ;_ end of foreach
    (setq *MIP_LAYER_LST* nil)
    ) ;_ end of defun 

  (defun mip:layer-status-save ()
    (setq *MIP_LAYER_LST* nil)
    (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) 
      (setq *MIP_LAYER_LST* (cons (list item 
                                  (cons "freeze" (vla-get-freeze item)) 
                                  (cons "lock" (vla-get-lock item)) 
                                  ) ;_ end of cons 
                            *MIP_LAYER_LST* 
                            ) ;_ end of cons 
            ) ;_ end of setq 
      (vla-put-lock item :vlax-false) 
      (vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false))) 
      ) ;_ end of vlax-for 
    ) ;_ end of defun 

  (vl-load-com)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark doc)
  (setq lays (vla-get-layers doc))
  (if (null (tblsearch "layer" "Defpoints"))
    (vla-add lays "Defpoints")
  ) ;_ end of if
  (mip:layer-status-save)
  (vlax-for Blk (vla-get-blocks doc)
    (setq count 0 bn (vla-get-name Blk))
    (vl-catch-all-apply
      '(lambda ()
         (if (= (vla-get-isxref Blk) :vlax-false)
           (vlax-for Obj Blk
             (grtext -1 (strcat bn " Change item N="(rtos (setq count (1+ count)) 2 0)))
             (setq lay (vla-item lays (vla-get-layer obj)))
             (if (= (vla-get-color obj) acbylayer)
               (progn
                 (if (listp
                       (setq
                         color (if (= (vla-get-colormethod
                                        (setq
                                          TrueColor (vla-get-truecolor lay)
                                        ) ;_ end of setq
                                      ) ;_ end of vla-get-ColorMethod
                                      accolormethodbyrgb
                                   ) ;_ end of =
                                 (list (vla-get-red TrueColor)
                                       (vla-get-green TrueColor)
                                       (vla-get-blue TrueColor)
                                 ) ;_ end of list
                                 (vla-get-color lay)
                               ) ;_ end of if
                       ) ;_ end of setq
                     ) ;_ end of listp
                   (progn
                     (setq TrueColor (vla-get-truecolor obj))
                     (vla-setrgb
                       TrueColor
                       (nth 0 color)
                       (nth 1 color)
                       (nth 2 color)
                     ) ;_ end of vla-setRGB
                     (vla-put-truecolor obj TrueColor)
                   ) ;_ end of progn
                   (vla-put-color obj color)
                 ) ;_ end of if
               ) ;_ end of progn
             ) ;_ end of if
             (if (= (vla-get-lineweight obj) aclnwtbylayer)
               (progn
                 (vla-put-lineweight obj (vla-get-lineweight lay))
               ) ;_ end of progn
             ) ;_ end of if
             (vla-put-layer obj "Defpoints")
           ) ;_ end of vlax-for
         ) ;_ end of if
       ) ;_ end of lambda
    ) ;_ end of vl-catch-all-apply
  ) ;_ end of vlax-for
  (mip:layer-status-restore)
  (vla-endundomark doc)
  (princ)
) ;_ end of defun

;;Пример
(defun C:TEST ( )(CHANGE-OBJECTS-COLOR&LW))

Применяй до Esconvert

** Исправлено

DEM · 15.10.2007, 16:25

Неверный тип аргумента: VLA-OBJECT nil

VVA · 15.10.2007, 17:04

Исправил код в №2

DEM · 15.10.2007, 17:20

Огромное спасибо.
Дальше уж esconvert.lsp Я смогу подправить

DEM · 15.10.2007, 21:16

Программка получилась отличная

Чертежи отлично читаются, а расечатать не получается.

VVA · 16.10.2007, 09:31

Еще выключи слой 0, перестанет выделяться.
Вообще для большинства пользователей достаточно простейших средств защиты. Я провел эксперимент: попросил своих юзеров распечатать чертеж. Из 5 человек один полез туда куда нужно.

DEM · 16.10.2007, 09:44

Ну дык эт совсем просто

zenon · 16.10.2007, 09:46

А выложить получившуюся программку полностью можно??? Так называемую ESConvert+
или секрет фирмы

Alaspher · 16.10.2007, 09:49

Единственное замечание к этой утилите - надо учитывать, что она сделает видимыми примитивы лежащие на выключенных и замороженных слоях. С этим "побороться" несложно, есть 2 пути - удалить такие примитивы или сделать их невидимыми, на случай если потребуется всё же их включить (но опять же не стандартными командами автокада, а самописной утилитой), но вот как быть с примитивами невидимыми в отдельных видовых окнах - не знаю. Самый чистый вариант - делать промежуточные спецблоки, вставлять их на дефпоинтс (дабы не допустить распечатки) и только потом делать мультивставной блок, но некрасиво как-то..., коряво.

DEM · 16.10.2007, 10:10

Цитата:

Сообщение от zenon

А выложить получившуюся программку полностью можно??? Так называемую ESConvert+
или секрет фирмы

Ну дык если Эдуард Смолянка и Alaspher
Разрешат то выложу результат.
Причем еще кое что можно до делать в связи с замечаниями Alaspher-а

Alaspher · 16.10.2007, 10:14

Цитата:

Сообщение от DEM

Ну дык если Эдуард Смолянка и Alaspher
Разрешат то выложу результат.
Причем еще кое что можно до делать в связи с замечаниями Alaspher-а

Код:

[Выделить все]

;;;*****************************************************************************************
;;; Разрешается   использовать,  копировать,  изменять,  и  распространять  это  программное
;;; обеспечение бесплатно, при  условии, что программное обеспечение, полностью или частично
;;; включающее данное ПО, будет распространяться  на тех-же условиях, а указанные  выше знак
;;; авторского права и примечания об ограничениях гарантий будут приводиться во всех копиях.
;;;*****************************************************************************************

Отдельного разрешения не требуется.

По замечаниям - надо решить - как сделать лучше и правильнее, тогда можно и кодить.

DEM · 16.10.2007, 10:45

Ну дык вот что получилось

Код:

[Выделить все]

;;;*****************************************************************************************
;;; Copyright ©2004 Эдуард Смолянка, Пётр Лоскутов aka Alaspher
;;; e-mail: [email protected], [email protected]
;;;*****************************************************************************************
;;; ESConvert.LSP версия: 0.8.1 (бета)
;;;*****************************************************************************************
;| Программа предназначена для защиты .dwg файла от редактирования
   В результате работы программы все объекты чертежа преобразовываются в мультивставки
   анонимных блоков (в каждом пространстве по одному блоку) которые невозможно
   расчленить командой  Explode и отредактировать командой Refedit, однако в чертеже
   остается возможным создание новых примитивов , включение\выключение ,
   замораживание\размораживание слоев, печать файла.
   *****************************************************************************************
   Программа не является "панацеей от всех зол" , и сломать данную защиту очень просто
   человеку знакомому с программированием для Autocad или опытному пользователю ,
   знающему структуру DXF файлов.
********************************************************************************************
   Программа написана и тестировалась для версий AutoCad 15-16
********************************************************************************************
Для запуска программы необходимо:
1. Выполнить загрузку файла в рисунок при помощи команды Appload
2. Запуск программы производится набором в командной строке команды - ESConvert
Внимание после завершения работы программы (до сохранения текущего файла)
желательно сохранить обработанный файл под другим именем. 
|;
;;; ОГРАНИЧЕНИЕ ГАРАНТИЙ
;;; ПРОГРАММА РАСПРОСТРАНЯЕТСЯ НА УСЛОВИЯХ "КАК ЕСТЬ".
;;; АВТОРЫ НЕ БЕРУТ НА СЕБЯ И НЕ ПОДРАЗУМЕВАЮТ КАКИХ-ЛИБО ГАРАНТИЙНЫХ ОБЯЗАТЕЛЬСТВ.
;;; ВЫ ИСПОЛЬЗУЕТЕ  ПРОГРАММУ НА СВОЙ РИСК.
;;; АВТОРЫ НЕ БЕРУТ НА СЕБЯ ОТВЕТСТВЕННОСТЬ ЗА ПОТЕРЮ ДАННЫХ, УЩЕРБ, ПОТЕРЮ ПРИБЫЛИ ИЛИ ЛЮБЫЕ
;;; ДРУГИЕ ПОТЕРИ, ПРОИЗОШЕДШИЕ ВО ВРЕМЯ ИСПОЛЬЗОВАНИЯ ИЛИ НЕПРАВИЛЬНОГО ИСПОЛЬЗОВАНИЯ
;;; ДАННОГО ПРОГРАММНОГО ОБЕСПЕЧЕНИЯ.
;;;*****************************************************************************************
;;; Разрешается   использовать,  копировать,  изменять,  и  распространять  это  программное
;;; обеспечение бесплатно, при  условии, что программное обеспечение, полностью или частично
;;; включающее данное ПО, будет распространяться  на тех-же условиях, а указанные  выше знак
;;; авторского права и примечания об ограничениях гарантий будут приводиться во всех копиях.
;;;*****************************************************************************************

(defun c:esconvert (/ acaddoc blocks oldvar layers lay-freeze lay-lock)
(defun change-objects-color&lw ( / lays lay color truecolor doc count mip:layer-status-restore mip:layer-status-save bn)
    (defun mip:layer-status-restore () 
    (foreach item *MIP_LAYER_LST*
      (if (not (vlax-erased-p (car item))) 
        (vl-catch-all-apply 
          '(lambda () 
             (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
             (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
             ) ;_ end of lambda 
          ) ;_ end of vl-catch-all-apply 
        ) ;_ end of if 
      ) ;_ end of foreach
    (setq *MIP_LAYER_LST* nil)
    ) ;_ end of defun 

  (defun mip:layer-status-save ()
    (setq *MIP_LAYER_LST* nil)
    (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) 
      (setq *MIP_LAYER_LST* (cons (list item 
                                  (cons "freeze" (vla-get-freeze item)) 
                                  (cons "lock" (vla-get-lock item)) 
                                  ) ;_ end of cons 
                            *MIP_LAYER_LST* 
                            ) ;_ end of cons 
            ) ;_ end of setq 
      (vla-put-lock item :vlax-false) 
      (vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false))) 
      ) ;_ end of vlax-for 
    ) ;_ end of defun 

  (vl-load-com)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark doc)
  (setq lays (vla-get-layers doc))
  (if (null (tblsearch "layer" "Defpoints"))
    (vla-add lays "Defpoints")
  ) ;_ end of if
  (mip:layer-status-save)
  (vlax-for Blk (vla-get-blocks doc)
    (setq count 0 bn (vla-get-name Blk))
    (vl-catch-all-apply
      '(lambda ()
         (if (= (vla-get-isxref Blk) :vlax-false)
           (vlax-for Obj Blk
             (grtext -1 (strcat bn " Change item N="(rtos (setq count (1+ count)) 2 0)))
             (setq lay (vla-item lays (vla-get-layer obj)))
             (if (= (vla-get-color obj) acbylayer)
               (progn
                 (if (listp
                       (setq
                         color (if (= (vla-get-colormethod
                                        (setq
                                          TrueColor (vla-get-truecolor lay)
                                        ) ;_ end of setq
                                      ) ;_ end of vla-get-ColorMethod
                                      accolormethodbyrgb
                                   ) ;_ end of =
                                 (list (vla-get-red TrueColor)
                                       (vla-get-green TrueColor)
                                       (vla-get-blue TrueColor)
                                 ) ;_ end of list
                                 (vla-get-color lay)
                               ) ;_ end of if
                       ) ;_ end of setq
                     ) ;_ end of listp
                   (progn
                     (setq TrueColor (vla-get-truecolor obj))
                     (vla-setrgb
                       TrueColor
                       (nth 0 color)
                       (nth 1 color)
                       (nth 2 color)
                     ) ;_ end of vla-setRGB
                     (vla-put-truecolor obj TrueColor)
                   ) ;_ end of progn
                   (vla-put-color obj color)
                 ) ;_ end of if
               ) ;_ end of progn
             ) ;_ end of if
             (if (= (vla-get-lineweight obj) aclnwtbylayer)
               (progn
                 (vla-put-lineweight obj (vla-get-lineweight lay))
               ) ;_ end of progn
             ) ;_ end of if
             (vla-put-layer obj "Defpoints")
           ) ;_ end of vlax-for
         ) ;_ end of if
       ) ;_ end of lambda
    ) ;_ end of vl-catch-all-apply
  ) ;_ end of vlax-for
  (mip:layer-status-restore)
  (vla-endundomark doc)
  (princ)
) ;_ end of defun
    (change-objects-color&lw)
  (vl-load-com)
  (setq    acaddoc    (vla-get-activedocument (vlax-get-acad-object))
    blocks    (vla-get-blocks acaddoc)
;;; +7
    oldvar    (list (getvar "celtype"))
    oldvar    (cons (getvar "cmdecho") oldvar)
    oldvar    (cons (getvar "cecolor") oldvar)
    oldvar    (cons (getvar "clayer") oldvar)
    layers    (vla-get-layers acaddoc)
  ) ;_ end of setq
  (xref-bind2 blocks)
;;; +14
  (proxy-explod acaddoc)
;;; -14
  (block-unnamed2 blocks)
  (vlax-for l layers
    (if    (= (vla-get-freeze l) :vlax-true)
      (progn
    (vla-put-freeze l :vlax-false)
    (setq lay-freeze (cons l lay-freeze))
      ) ;_ end of progn
    ) ;_ end of if
    (if    (= (vla-get-lock l) :vlax-true)
      (progn
    (vla-put-lock l :vlax-false)
    (setq lay-lock (cons l lay-lock))
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of vlax-for
;;; -7
  (mapcar (function setvar) '("clayer" "cecolor" "cmdecho" "celtype") '("0" "BYLAYER" 0 "BYLAYER"))
  (vla-purgeall acaddoc)
;;; +1
  (attribute-text2 acaddoc)
  (vlax-for item4 (vla-get-layouts acaddoc)
    (pl:unnblock-from-vlacol acaddoc (vla-get-block item4))
  ) ;_ end of vlax-for
  (vla-purgeall acaddoc)
;;; -1
;;; +8
  (if (vl-catch-all-error-p (vl-catch-all-apply (function vla-item) (list layers (car oldvar))))
    (setq oldvar     (cons "0" (cdr oldvar))
;;; +9
      lay-freeze (vl-remove (vla-item layers "0") lay-freeze)
;;; -9
    ) ;_ end of setq
  ) ;_ end of if
  (mapcar (function setvar) '("clayer" "cecolor" "cmdecho" "celtype") oldvar)
  (foreach l lay-freeze
    (if    (vlax-write-enabled-p l)
      (vla-put-freeze l :vlax-true)
    ) ;_ end of if
  ) ;_ end of foreach
  (foreach l lay-lock
    (if    (vlax-write-enabled-p l)
      (vla-put-lock l :vlax-true)
    ) ;_ end of if
  ) ;_ end of foreach
;;; -8
  (vla-regen acaddoc acallviewports)
  (princ)
) ;_ end of defun

(defun xref-bind2 (blocks / xreflist)
  (vlax-for item blocks
    (if    (= (vla-get-isxref item) :vlax-true)
      (setq xreflist (cons item xreflist))
    ) ;_ end of if
  ) ;_ end of vlax-for
;;; +10
  (if (< 1 (length xreflist))
    (setq xreflist
       (mapcar
         (function vlax-ename->vla-object)
         (mapcar
           (function (lambda (b) (cdr (assoc -1 b))))
           (vl-remove-if-not
         (function
           (lambda (a)
             (assoc 331 a)
           ) ;_ end of lambda
         ) ;_ end of function
         (mapcar (function entget) (mapcar (function vlax-vla-object->ename) xreflist))
           ) ;_ end of vl-remove-if-not
         ) ;_ end of mapcar
       ) ;_ end of mapcar
    ) ;_ end of setq
  ) ;_ end of if
  (foreach i xreflist
    (if    (vl-catch-all-error-p (vl-catch-all-apply (function vla-get-xrefdatabase) (list i)))
      (vla-detach i)
      (vl-catch-all-apply (function vla-bind) (list i :vlax-true))
    ) ;_ end of if
  ) ;_ end of foreach
;;; -10
) ;_ end of defun

;;; +12
(defun ent-obj-select (sel enttype)
  (vla-select
    sel
    acselectionsetall
    nil
    nil
    (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0))
    (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list enttype))
  ) ;_ end of vla-select
) ;_ end of defun
;;; -12

;;; +2
(defun attribute-text2 (doc / attrib sel)
  (vla-clear (setq sel (vla-get-activeselectionset doc)))
;;; +13
  (ent-obj-select sel "ATTDEF")
;;; -13
  (vlax-for j sel
    (pl:obj-attdef-to-text j)
    (setq attrib (cons j attrib))
  ) ;_ end of foreach
  (vla-clear sel)
  (foreach a attrib (vla-delete a))
) ;_ end of defun
;;; -2

;;; +11
(defun proxy-explod (doc / zombie sel actl)
  (vla-clear (setq sel (vla-get-activeselectionset doc)))
  (ent-obj-select sel "ACAD_PROXY_ENTITY")
  (vlax-for j sel
    (setq zombie (cons j zombie))
  ) ;_ end of foreach
  (setq    zombie (sublist-by-prop zombie "OwnerID")
    actl   (vla-get-activelayout doc)
  ) ;_ end of setq
  (foreach l zombie
    (vla-put-activelayout doc (vla-get-layout (vla-objectidtoobject doc (vla-get-ownerid (car l)))))
    (foreach i l
      (vl-cmdf "_.explode" (vlax-vla-object->ename i))
    ) ;_ end of foreach
  ) ;_ end of foreach
  (if (/= (vla-get-activelayout doc) actl)
    (vla-put-activelayout doc actl)
  ) ;_ end of if
  (vla-clear sel)
) ;_ end of defun

(defun sublist-by-prop (lst prop / val tmp)
  (if lst
    (progn
      (setq val    (vlax-get-property (car lst) prop)
        tmp    (vl-remove-if-not (function (lambda (x) (= (vlax-get-property x prop) val))) lst)
      ) ;_ end of setq
      (cons tmp (sublist-by-prop (foreach y tmp (setq lst (vl-remove y lst))) prop))
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of defun
;;; -11

(defun block-unnamed2 (blocks)
  (vlax-for item5 blocks
    (if    (and (/= (vl-string-elt (vla-get-name item5) 0) 42)
         (not (wcmatch (vla-get-name item5) "AVE*"))
    ) ;_ end of and
      (vla-put-name item5 "*U")
    ) ;_ end of if
  ) ;_ end of vlax-for
) ;_ end of defun

;;; +4
;;; Создание копии текста из метки определения атрибута объектным методом
;;; att - объект
(defun pl:obj-attdef-to-text (att / doc lay loc new)
  (setq    doc (vla-get-document att)
    lay (vla-get-activelayer doc)
  ) ;_ end of setq
  (if (= :vlax-true (vla-get-lock lay))
    (progn
      (vla-put-lock lay :vlax-false)
      (setq lay    (list lay :vlax-true)
        loc    t
      ) ;_ end of setq
    ) ;_ end of progn
  ) ;_ end of if
  (setq    new (vla-addtext
          (vla-objectidtoobject doc (vla-get-ownerid att))
          (vla-get-tagstring att)
          (vla-get-insertionpoint att)
          (vla-get-height att)
        ) ;_ end of vla-AddText
    att (list att)
  ) ;_ end of setq
  (foreach a '("alignment"      "color"         "linetype"        "linetypescale"
           "lineweight"      "normal"         "obliqueangle"    "plotstylename"
           "rotation"      "scalefactor"         "stylename"    "textalignmentpoint"
           "textgenerationflag"             "thickness"    "truecolor"
           "upsidedown"      "visible"         "layer"
          )
    (vl-catch-all-apply
      (read (strcat "vla-put-" a))
      (list new (vl-catch-all-apply (read (strcat "vla-get-" a)) att))
    ) ;_ end of vl-catch-all-apply
  ) ;_ end of foreach
  (if loc
    (apply (function vla-put-lock) lay)
  ) ;_ end of if
  new
) ;_ end of defun
;;; -4

;;; +5
(defun pl:unnblock-from-vlacol (doc col / new-bl vl-blks doc insp tmp del)
  (setq    vl-blks    (vla-get-blocks doc)
    insp    (vlax-3d-point '(0.0 0.0 0.0))
  ) ;_ end of setq
  (vlax-for x col
    (if    (= (strcase (vla-get-objectname x)) "ACDBVIEWPORT")
      (setq del (cons x del))
      (setq tmp (cons x tmp))
    ) ;_ end of if
  ) ;_ end of vlax-for
  (foreach d del
    (if    (= (vla-get-clipped d) :vlax-true)
      (setq tmp
         (vl-remove    (vlax-ename->vla-object (cdr (assoc 340 (entget (vlax-vla-object->ename d)))))
            tmp
         ) ;_ end of vl-remove
      ) ;_ end of setq
    ) ;_ end of if
  ) ;_ end of foreach
  (if (and tmp
       (setq new-bl (vla-add vl-blks insp "*U"))
      ) ;_ end of and
    (progn
      (vla-copyobjects
    doc
    (vlax-make-variant
      (vlax-safearray-fill
        (vlax-make-safearray vlax-vbobject (cons 0 (1- (length tmp))))
        tmp
      ) ;_ end of vlax-safearray-fill
    ) ;_ end of vlax-make-variant
    new-bl
      ) ;_ end of vla-copyobjects
      (vla-addminsertblock
    (vla-objectidtoobject doc (vla-get-ownerid (car tmp)))
    insp
    (vla-get-name new-bl)
    1.0
    1.0
    1.0
    0.0
    1
    1
    0
    0
      ) ;_ end of vla-insertblock
      (foreach x tmp (vla-delete x))
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of defun
;;; -5

(princ
  "\nПеред использованием команды ознакомтесь с её описанием!\nДля запуска команды введите в командной строке: esconvert"
) ;_ end of princ

(princ)

Alaspher · 17.10.2007, 14:54

Набросал код, надо бы потестить, но некогда. Уже замечен не большой косяк при обработке ссылок содержащих ошибки. Пока не придумал, как побороть программно. Руками обходится путём предварительного внедрения ссылок с аудитом.

Собственно код:
(использован модернизированый кусок кода VVA, сенкс!)

Код:

[Выделить все]

;;;*****************************************************************************************
;;; ©2004, 2007
;;; Эдуард Смолянка - e-mail: [email protected]
;;; Пётр Лоскутов aka Alaspher - e-mail: [email protected]
;;;*****************************************************************************************
;;; ESConvert.LSP версия: 1.5 (бета)
;;;*****************************************************************************************
;| Программа предназначена для защиты .dwg файла от редактирования
   В результате работы программы все объекты чертежа преобразовываются в мультивставки
   анонимных блоков (в каждом пространстве по одному блоку) которые невозможно
   расчленить командой  Explode и отредактировать командой Refedit, однако в чертеже
   остается возможным создание новых примитивов, включение\выключение,
   замораживание\размораживание слоев. Печать файла штатными средствами AutoCAD невозможна.
   *****************************************************************************************
   Программа не является "панацеей от всех зол", и сломать данную защиту очень просто
   человеку знакомому с программированием для Autocad или опытному пользователю,
   знающему структуру DXF файлов.
********************************************************************************************
   Программа написана и тестировалась для версии AutoCad 17 (2008)
********************************************************************************************
Для запуска программы необходимо:
1. Выполнить загрузку файла в рисунок при помощи команды Appload
2. Запуск программы производится набором в командной строке команды - ESConvert
Внимание после завершения работы программы (до сохранения текущего файла)
желательно сохранить обработанный файл под другим именем. 
|;
;;; ОГРАНИЧЕНИЕ ГАРАНТИЙ
;;; ПРОГРАММА РАСПРОСТРАНЯЕТСЯ НА УСЛОВИЯХ "КАК ЕСТЬ".
;;; АВТОРЫ НЕ БЕРУТ НА СЕБЯ И НЕ ПОДРАЗУМЕВАЮТ КАКИХ-ЛИБО ГАРАНТИЙНЫХ ОБЯЗАТЕЛЬСТВ.
;;; ВЫ ИСПОЛЬЗУЕТЕ  ПРОГРАММУ НА СВОЙ РИСК.
;;; АВТОРЫ НЕ БЕРУТ НА СЕБЯ ОТВЕТСТВЕННОСТЬ ЗА ПОТЕРЮ ДАННЫХ, УЩЕРБ, ПОТЕРЮ ПРИБЫЛИ ИЛИ ЛЮБЫЕ
;;; ДРУГИЕ ПОТЕРИ, ПРОИЗОШЕДШИЕ ВО ВРЕМЯ ИСПОЛЬЗОВАНИЯ ИЛИ НЕПРАВИЛЬНОГО ИСПОЛЬЗОВАНИЯ
;;; ДАННОГО ПРОГРАММНОГО ОБЕСПЕЧЕНИЯ.
;;;*****************************************************************************************
;;; Разрешается   использовать,  копировать,  изменять,  и  распространять  это  программное
;;; обеспечение бесплатно, при  условии, что программное обеспечение, полностью или частично
;;; включающее данное ПО, будет распространяться  на тех-же условиях, а указанные  выше знак
;;; авторского права и примечания об ограничениях гарантий будут приводиться во всех копиях.
;;;*****************************************************************************************
(defun c:esconvert (/ acaddoc blocks oldvar layers lay-freeze lay-lock lay-off)
    (setq acaddoc (vla-get-activedocument (vlax-get-acad-object))
          blocks  (vla-get-blocks acaddoc)
          oldvar  (list (getvar "celtype"))
          oldvar  (cons (getvar "cmdecho") oldvar)
          oldvar  (cons (getvar "cecolor") oldvar)
          oldvar  (cons (getvar "clayer") oldvar)
          layers  (vla-get-layers acaddoc)
    )
    (vla-startundomark acaddoc)
    (if (null (tblsearch "layer" "Defpoints"))
        (vla-add layers "Defpoints")
    )
    (vlax-for l layers
        (if (= (vla-get-freeze l) :vlax-true)
            (progn (vla-put-freeze l :vlax-false) (setq lay-freeze (cons l lay-freeze)))
        )
        (if (= (vla-get-lock l) :vlax-true)
            (progn (vla-put-lock l :vlax-false) (setq lay-lock (cons l lay-lock)))
        )
        (if (= (vla-get-layeron l) :vlax-false)
            (setq lay-off (cons l lay-off))
        )
    )
    (xref-bind2 blocks)
    (proxy-explod acaddoc)
    (delete-invisible
        blocks
        (mapcar (function vla-get-name) lay-freeze)
        (mapcar (function vla-get-name) lay-off)
    )
    (change-objects-color&lw_m blocks layers)
    (block-unnamed2 blocks)
    (mapcar (function setvar)
            '("clayer" "cecolor" "cmdecho" "celtype")
            '("0" "BYLAYER" 0 "BYLAYER")
    )
    (vla-purgeall acaddoc)
    (attribute-text2 acaddoc)
    (vlax-for item4 (vla-get-layouts acaddoc)
        (pl:unnblock-from-vlacol acaddoc (vla-get-block item4))
    )
    (vla-purgeall acaddoc)
    (if (vl-catch-all-error-p
            (vl-catch-all-apply (function vla-item) (list layers (car oldvar)))
        )
        (setq oldvar     (cons "0" (cdr oldvar))
              lay-freeze (vl-remove (vla-item layers "0") lay-freeze)
        )
    )
    (mapcar (function setvar) '("clayer" "cecolor" "cmdecho" "celtype") oldvar)
    (foreach l lay-freeze
        (if (vlax-write-enabled-p l)
            (vla-put-freeze l :vlax-true)
        )
    )
    (foreach l lay-lock
        (if (vlax-write-enabled-p l)
            (vla-put-lock l :vlax-true)
        )
    )
    (vla-regen acaddoc acallviewports)
    (vla-endundomark acaddoc)
    (princ)
)
(defun xref-bind2 (blocks / xreflist)
    (vlax-for item blocks
        (if (= (vla-get-isxref item) :vlax-true)
            (setq xreflist (cons item xreflist))
        )
    )
    (if (< 1 (length xreflist))
        (setq xreflist
                 (mapcar
                     (function vlax-ename->vla-object)
                     (mapcar
                         (function (lambda (b) (cdr (assoc -1 b))))
                         (vl-remove-if-not
                             (function (lambda (a) (assoc 331 a)))
                             (mapcar (function entget)
                                     (mapcar (function vlax-vla-object->ename) xreflist)
                             )
                         )
                     )
                 )
        )
    )
    (foreach i xreflist
        (if (vl-catch-all-error-p
                (vl-catch-all-apply (function vla-get-xrefdatabase) (list i))
            )
            (vla-detach i)
            (vl-catch-all-error-p
                (vl-catch-all-apply (function vla-bind) (list i :vlax-true))
            )
        )
    )
)
(defun ent-obj-select (sel enttype)
    (vla-select
        sel
        acselectionsetall
        nil
        nil
        (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0))
        (vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) (list enttype))
    )
)
(defun attribute-text2 (doc / attrib sel)
    (vla-clear (setq sel (vla-get-activeselectionset doc)))
    (ent-obj-select sel "ATTDEF")
    (vlax-for j sel (pl:obj-attdef-to-text j) (setq attrib (cons j attrib)))
    (vla-clear sel)
    (foreach a attrib (vla-delete a))
)
(defun proxy-explod (doc / zombie sel actl)
    (vla-clear (setq sel (vla-get-activeselectionset doc)))
    (ent-obj-select sel "ACAD_PROXY_ENTITY")
    (vlax-for j sel (setq zombie (cons j zombie)))
    (setq zombie (sublist-by-prop zombie "OwnerID")
          actl   (vla-get-activelayout doc)
    )
    (foreach l zombie
        (vla-put-activelayout
            doc
            (vla-get-layout (vla-objectidtoobject doc (vla-get-ownerid (car l))))
        )
        (foreach i l (vl-cmdf "_.explode" (vlax-vla-object->ename i)))
    )
    (if (/= (vla-get-activelayout doc) actl)
        (vla-put-activelayout doc actl)
    )
    (vla-clear sel)
)
(defun sublist-by-prop (lst prop / val tmp)
    (if lst
        (progn (setq val (vlax-get-property (car lst) prop)
                     tmp (vl-remove-if-not
                             (function (lambda (x) (= (vlax-get-property x prop) val)))
                             lst
                         )
               )
               (cons tmp (sublist-by-prop (foreach y tmp (setq lst (vl-remove y lst))) prop))
        )
    )
)
(defun block-unnamed2 (blocks / name)
    (vlax-for item5 blocks
        (if (and (/= (vl-string-elt (vla-get-name item5) 0) 42)
                 (not (wcmatch (setq name (vla-get-name item5)) "AVE*"))
                 (not (wcmatch name "`**"))
            )
            (vl-catch-all-apply (function vla-put-name) (list item5 "*U"))
        )
    )
)
 
(defun pl:obj-attdef-to-text (att / doc lay loc new)
    (setq doc (vla-get-document att)
          lay (vla-get-activelayer doc)
    )
    (if (= :vlax-true (vla-get-lock lay))
        (progn (vla-put-lock lay :vlax-false)
               (setq lay (list lay :vlax-true)
                     loc t
               )
        )
    )
    (setq new (vla-addtext
                  (vla-objectidtoobject doc (vla-get-ownerid att))
                  (vla-get-tagstring att)
                  (vla-get-insertionpoint att)
                  (vla-get-height att)
              )
          att (list att)
    )
    (foreach a '("alignment"        "color"            "linetype"
                 "linetypescale"    "lineweight"       "normal"
                 "obliqueangle"     "plotstylename"    "rotation"
                 "scalefactor"      "stylename"        "textalignmentpoint"
                 "textgenerationflag"                  "thickness"
                 "truecolor"        "upsidedown"       "visible"
                 "layer"
                )
        (vl-catch-all-apply
            (read (strcat "vla-put-" a))
            (list new (vl-catch-all-apply (read (strcat "vla-get-" a)) att))
        )
    )
    (if loc
        (apply (function vla-put-lock) lay)
    )
    new
)
(defun pl:unnblock-from-vlacol (doc col / new-bl vl-blks doc insp tmp del own tmp-bl)
    (setq vl-blks (vla-get-blocks doc)
          insp    (vlax-3d-point '(0.0 0.0 0.0))
    )
    (vlax-for x col
        (if (= (strcase (vla-get-objectname x)) "ACDBVIEWPORT")
            (setq del (cons x del))
            (setq tmp (cons x tmp))
        )
    )
    (foreach d del
        (if (= (vla-get-clipped d) :vlax-true)
            (setq tmp (vl-remove (vlax-ename->vla-object
                                     (cdr (assoc 340 (entget (vlax-vla-object->ename d))))
                                 )
                                 tmp
                      )
            )
        )
    )
    (if (and tmp (setq new-bl (vla-add vl-blks insp "*U")))
        (progn (vla-copyobjects
                   doc
                   (vlax-make-variant
                       (vlax-safearray-fill
                           (vlax-make-safearray vlax-vbobject (cons 0 (1- (length tmp))))
                           tmp
                       )
                   )
                   new-bl
               )
               (setq own    (vla-objectidtoobject doc (vla-get-ownerid (car tmp)))
                     tmp-bl (vla-insertblock own insp (vla-get-name new-bl) 1.0 1.0 1.0 0.0)
               )
               (vla-put-layer tmp-bl "Defpoints")
               (setq new-bl (vla-add vl-blks insp "*U"))
               (vla-copyobjects
                   doc
                   (vlax-make-variant
                       (vlax-safearray-fill
                           (vlax-make-safearray vlax-vbobject '(0 . 0))
                           (list tmp-bl)
                       )
                   )
                   new-bl
               )
               (vla-addminsertblock own insp (vla-get-name new-bl) 1.0 1.0 1.0 0.0 1 1 0 0)
               (foreach x (cons tmp-bl tmp) (vla-delete x))
        )
    )
)
(defun change-objects-color&lw_m (blocks lays / lay truecolor)
    (vlax-for obj blocks
        (if (= (vla-get-objectname obj) "AcDbBlockTableRecord")
            (change-objects-color&lw_m obj lays)
            (progn (setq lay (vla-item lays (vla-get-layer obj)))
                   (if (= (vla-get-color obj) acbylayer)
                       (if (setq truecolor (vla-get-truecolor lay))
                           (vl-catch-all-apply
                               (function vla-put-truecolor)
                               (list obj truecolor)
                           )
                           (vl-catch-all-apply
                               (function vla-put-color)
                               (list obj (vla-get-color lay))
                           )
                       )
                   )
                   (if (= (vla-get-lineweight obj) aclnwtbylayer)
                       (vl-catch-all-apply
                           (function vla-put-lineweight)
                           (list obj (vla-get-lineweight lay))
                       )
                   )
                   (if (= (vla-get-linetype obj) "ByLayer")
                       (vl-catch-all-apply
                           (function vla-put-linetype)
                           (list obj (vla-get-linetype lay))
                       )
                   )
            )
        )
    )
)
(defun delete-invisible (blocks lay-fr lay-of / obj-name)
    (vlax-for i blocks
        (setq obj-name (vla-get-objectname i))
        (cond ((= obj-name "AcDbBlockTableRecord") (delete-invisible i lay-fr lay-of))
              ((= obj-name "AcDbViewport"))
              ((or (vl-position (vla-get-layer i) lay-fr)
                   (and (vl-position (vla-get-layer i) lay-of)
                        (/= obj-name "AcDbBlockReference")
                   )
               )
               (vl-catch-all-apply (function vla-delete) (list i))
              )
        )
    )
)

(vl-load-com)
(princ
    "\nПеред использованием команды ознакомтесь с её описанием!\nДля запуска команды введите в командной строке: esconvert"
)
(princ)

О замеченых ошибках пишите - по мере сил постараемся править.

Cartman · 03.11.2015, 16:07

говорят где-то есть лисп который снимает данную защиту.
подскажите если кто видел такое.
спасибо

Кулик Алексей aka kpblc · 03.11.2015, 16:14

FAQ чем не устраивает? Насколько я помню, там был соответствующий ответ.

Cartman · 03.11.2015, 16:36

спасибо, плохо искал.
нашел bgtools2.38.lsp, помогло.

15.10.2007, 15:10		#1
до работка конвектора(защита файла) DEM YngIngKllr СПб Регистрация: 29.03.2005 Сообщений: 12,968 Задача состоит в следующем. Есть конвектор "ESConvert" от Эдуарда Смолянка и Пётр Лоскутова. Требуется несколько доработать его т.к. есть возможность распечатки. Хотелось бы перевести все примитивы черт. в слой Defpoints, при этом сохранив цвет и вес примитива как в исходном слое, если же что то изменили то в присвоеном значении. __________________ Работаю за еду. Working for food. Für Essen arbeiten. العمل من أجل الغذاء Працую за їжу. Последний раз редактировалось DEM, 15.10.2007 в 15:10. Причина: Где заглавные буквы
Просмотров: 10094

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
структурированный список	Holon	Программирование	22	11.09.2007 14:09
пример простейшего dxf файла, содержащего SPLINE	hidjab	Программирование	2	16.02.2007 10:29
Открытие файла	Hohotun	AutoCAD	5	11.12.2006 10:34
Частичное открытие файла - не активно при открытии файла	ADik	AutoCAD	4	22.06.2006 07:35
Размер файла dwg	alex-alex	Прочее. Архитектура и строительство	5	10.09.2004 00:28