[Залётный]

Задача:
Необходимо перенести любой текст в файле (текст, мултилайн текст, атрибуты, текст в блоках и т.д.) на отдельный слой, или просто удалить любой текст из файла.

Описание проблемы.

Получены чертёжи от смежников в которых всё находится на одном слое. Все элементы блоков находятся на слое 0. Необходимо перенести любые текстовые объекты, в том числе входящие в состав блоков на отдельный слой, или просто удалить их.

Нужно решение для групповой обработки файлов - возможность запускать программу из командной строки т.е. для включения её в скрипт.

Первоначально задача выглядела очень просто -

1. сделать explode(burst) всех блоков два или три раза т.к. блоки содержат внутри себя другие блоки.
2. создать отдельный слой.
3. селектировать text(mtext) объекты.
4. перенести их на новый слой.

При быполнении burst появлялись новые видимые объекты.
Причина - в череже использовались блоки одной длины (состоящие из нескольких более коротких блоков) и при необходимости они клипались. При выполнении explode(burst) проявлялась невидимая часть этих блоков.
В блоки в качестве элементов включены атрибуты, обычный текст и мультилайн текст. С атрибутами проблема решается довольно просто - команда find и заменить текст помаске * на пробел. Кроме того можно воспользоваться attstrip.vlx от DotSoft:
http://www.dotsoft.com/freestuff.htm

Имеется ли возможность перенести все текстовые элементы на отдельный слой, или полностью удалить их из файла или обнулить, чтобы он стал нивидимым?

[Евгений А.]

Пробуй лиспик, может чего не учёл...

Код:

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

 ;команда   del-txt
(defun C:del-txt (/ adoc item block)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (vlax-for block (vla-get-blocks adoc)
    (vlax-for item block
      (cond ((member (setq typ (vla-get-objectname item))
                     '("AcDbText" "AcDbMText" "AcDbAttributeDefinition")
                     ) ;_ end member
             (vl-catch-all-apply 'vla-delete (list item))
             )
            ((= typ "AcDbBlockReference")
             (if (or (setq var (vla-getattributes item))
                     (setq var (vla-GetConstantAttributes item))
                     ) ;_ end or
               (foreach atr (vlax-safearray->list (vlax-variant-value var))
                 (vl-catch-all-apply 'vla-delete (list atr))
                 ) ;_ end foreach
               ) ;_ end if
             )
            ) ;_ end cond
      ) ;_ end vlax-for
    ) ;_ end vlax-for
  ) ;_ end defun

[Кулик Алексей aka kpblc]

Евгений А., может, проще установить тогда свойство Visible в :vlax-false?

[Евгений А.]

Проще, но этого не просили

[Залётный]

Сообщение от Евгений А. Пробуй лиспик, может чего не учёл...

Получил:

; error: ActiveX Server returned an error: Invalid index

[Евгений А.]

Вот немного переделал

Код:

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

 ;êîìàíäà   del-txt
(defun C:del-txt (/ item block atr)
  (vlax-for block (vla-get-blocks
                    (vla-get-activedocument (vlax-get-acad-object))
                    ) ;_ end vla-get-blocks
    (vlax-for item block
      (cond ((member (setq typ (vla-get-objectname item))
                     '("AcDbText" "AcDbMText" "AcDbAttributeDefinition")
                     ) ;_ end member
             (vl-catch-all-apply 'vla-delete (list item))
             )
            ((= typ "AcDbBlockReference")
             (if (equal (vla-get-hasattributes item) :vlax-true)
               (foreach atr (vlax-safearray->list
                              (vlax-variant-value (vla-GetAttributes item))
                              ) ;_ end vlax-safearray->list
                 (vl-catch-all-apply 'vla-delete (list atr))
                 ) ;_ end foreach
               ) ;_ end if
             )
            ) ;_ end cond
      ) ;_ end vlax-for
    ) ;_ end vlax-for
  ) ;_ end defun
;(C:del-txt)

Но! Сам столкнулся с этой ошибкой - очень похоже на глюк Автокада. Ошибка появляется при повторном включении программы (конкретно (vla-get-hasattributes item) выдаёт true даже если аттрибутов уже нету. Если файл сохранить, закрыть и открыть заново - то ошибки уже нету. Странно...????

[Евгений А.]

Вот лови - сделал отлов ошибки (???), вроде не вылетает теперь.

Код:

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

;команда   del-txt
(defun C:del-txt (/ item block atr msg)
  (vlax-for block (vla-get-blocks
                    (vla-get-activedocument (vlax-get-acad-object))
                    ) ;_ end vla-get-blocks
    (vlax-for item block
      (cond ((member (setq typ (vla-get-objectname item))
                     '("AcDbText" "AcDbMText" "AcDbAttributeDefinition")
                     ) ;_ end member
             (vl-catch-all-apply 'vla-delete (list item))
             )
            ((= typ "AcDbBlockReference")
             (and (equal (vla-get-hasattributes item) :vlax-true)
                  (not
                    (vl-catch-all-error-p
                      (setq msg (vl-catch-all-apply
                                  'vlax-safearray->list
                                  (list (vlax-variant-value (vla-GetAttributes item)))
                                  ) ;_ end vl-catch-all-apply
                            ) ;_ end setq
                      ) ;_ end vl-catch-all-error-p
                    ) ;_ end not
                  (foreach atr msg
                    (vl-catch-all-apply 'vla-delete (list atr))
                    ) ;_ end foreach
                  ) ;_ end and
             )
            ) ;_ end cond
      ) ;_ end vlax-for
    ) ;_ end vlax-for
  ) ;_ end defun
;(C:del-txt)

[Залётный]

Сообщение от Евгений А. Вот немного переделал

Спасибо!

Великолепно работает. Остаётся сделать регенерацию.

[VVA]

>Евгений А. Есть еще 2 момента. Рассуждения сугубо теоретические и для Залетного может быть роли не играют.
Проходя по блокам, ты не преверяешь обрабатываемый блок на предмет не внешняя ли это ссылка и еще у блоков могут быть постоянные атрибуты.

Код:

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

;;;Сохранение состояния слоев с разморозкой и разблокировкой
;;;Документа Doc
(defun mip:layer-status-save (Doc)
    (setq *MIP_LAYER_LST* nil)
    (vlax-for item (vla-get-layers Doc) 
      (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
;;;Восстановление состояния слоев
(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
;;; Удаление текстов из документа
;;;Doc - указатель на обрабатываемый объект
(defun DellAllTextObjects (Doc / Count DelObjList)
(setq Count 0)
(vlax-for Blk (vla-get-Blocks Doc)
 (if (= (vla-get-IsXref Blk) :vlax-false)
  (vlax-for Obj Blk
    (setq DelObjList (list Obj))
   (if (or
         (member (vla-get-objectname Obj)
                 '("AcDbText" "AcDbMText" "AcDbAttributeDefinition" "AcDbAttribute")
                 ) ;_ end member
         (and
           (= (vla-get-objectname Obj) "AcDbBlockReference")
           (vlax-property-available-p obj 'Hasattributes)
    (eq :vlax-true (vla-get-HasAttributes obj))
           (setq DelObjList (append (vlax-invoke obj 'Getattributes)
     (vlax-invoke obj 'Getconstantattributes)
                             )
                 )
           )
         )
         
    (progn
      (foreach itm DelObjList
        (vl-catch-all-apply 'vla-delete (list itm))
        (setq count (1+ count))
        ) ;_ end foreach
    )
    )
  )
 )
  )
  count
)
;команда   del-txt
(defun C:del-txt ( / *error* Doc)
  (vl-load-com)
  (defun *error* (msg)(princ msg)
    (mip:layer-status-restore)(princ))
  (setq Doc (vla-get-activedocument (vlax-get-acad-object)))
  ;;Размораживаем, разблокируем слои, сохранив их сосотяние
  (mip:layer-status-save Doc)
  (princ "\nУдалено ")(princ (DellAllTextObjects Doc))
  (princ " из ")(princ (vla-get-name Doc))(terpri)
  (mip:layer-status-restore)
  (vla-Regen Doc acAllViewports)
  (princ)
  )

[Евгений А.]

VVA, я так глобально и не хотел даже думать, а делать... и так устаю. Всё сказанное верно и нужно - снимаю шляпу.
Непонравилась только эта строка:
(vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false)))
так Крыс всегда делает, а мне нравится так
(vl-catch-all-apply 'vla-put-freeze (list item :vlax-false))

[Pastor]

Единственно, если нет уверенности, что функция определена, то вариант
(vl-catch-all-apply (function (lambda () .....)))
абсолютно надежен.

[Евгений А.]

Сообщение от Pastor Единственно, если нет уверенности, что функция определена, то вариант (vl-catch-all-apply (function (lambda () .....))) абсолютно надежен.

Я имею в виду конкретный случай, когда получается "маслянное масло". Про надёжность ничего против не имею, но бесполезную избыточность не приветствую. Конкретно к VVA - только уважуха !

[Кулик Алексей aka kpblc]

Отвлеченно: а если надо защищать не одно действие, а несколько? Я несколько раз втупую вбил "не то", с тех пор просто привык использовать неименованные функции в catch-error.

[VVA]

так Крыс всегда делает, а мне нравится так (vl-catch-all-apply 'vla-put-freeze (list item :vlax-false))

Так они в свое время и были сделаны на основе его ф-ций Хотя я тоже в большинстве случаев предпочитаю lambda

[Евгений А.]

Сообщение от Кулик Алексей aka kpblc Отвлеченно: а если надо защищать не одно действие, а несколько?

Вот именно в этом случае надо использовать Lambda, а получается что всё под одну гребёнку - мол не надо ДУМАТЬ. Я понимаю, что процессору пофигу чего обрабатывать, но ведь бред например придумывать такой код:
(defun main_put-freeze (layer flag / )
(vla-put-freeze layer flag)
)
Или это нормально??? Всего несколько лишних байтов...

[Кулик Алексей aka kpblc]

Ага, именно "под одну гребенку". Зато все параллельно, перпендикулярно и покрашено в зеленый цвет.
Кстати, вот именно так код и приводит к ошибкам. ИМХО надо:

Код:

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

(defun main_put-freeze (layer freeze)
  (if (not
	(equal (vla-get-activelayer (vla-get-document layer)) layer)
	) ;_ end of not
    (vla-put-freeze
      layer
      (if freeze
	:vlax-true
	:vlax-false
	) ;_ end of if
      ) ;_ end of vla-put-freeze
    ) ;_ end of if
  ) ;_ end of defun

[Евгений А.]

кто о чём....

[Кулик Алексей aka kpblc]

Да ладно тебе, не бушуй. Я только-только отвлекся от ADT...

[Евгений А.]

Да я воще месяцев 6 не программировал....

[Pastor]

Небось, ObjectARX учил?

[Евгений А.]

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