Как переместить отрезки различных слоев из одного слоя в другие слои по цветам?

Dyuk · 25.03.2013, 20:46

Здравствуйте. Помогите с решением такой задачи:

Имеется чертеж, в котором все отрезки находятся в нулевом слое. Различные отрезки имеют свой цвет. (например синий, красный и зеленый).

Необходимо переместить эти отрезки из нулевого слоя в отдельные слои соответствующие цветам отрезкам.
например отрезки с цветом "синий" переместить в "слой 1", "красный" в "слой 2" и зеленый соответственно в "слой 3".

Всё это нужно сделать в автоматизированном режиме.

Может быть есть какой плагин подходящий? : Помощь: Спасибо за внимание.

Зачем мне это надо?
Я обнаружил, что из Sketchup можно экспортировать в автокад любые виды и разрезы (аналог команды flatshot, sectionplane).
Но преимущество Sketchup в том, что при экспорте в автокад можно задать линиям цвет соответствующий определенному слою.

более подробно об этом можно посмотреть ссылке в видео ниже
http://youtu.be/0Qd4z5t0Ns8

sasha_lif · 25.03.2013, 21:31

изучай команду
QSELECT
выбираешь там color
задаешь цвет
В итоге получаешь выделенными все примитивы одного цвета - и их закидываешь на нужный слой

Дальше опять QSELECT, и выбираешь другой цвет

Dyuk · 25.03.2013, 21:44

Спасибо за ответ, эту команду я знаю.
Если так нужно в 10-20 слоев перекинуть линии, то это очень неудобно.

maratovich · 25.03.2013, 23:29

Цитата:

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

Но преимущество Sketchup в том, что при экспорте в автокад можно задать линиям цвет соответствующий определенному слою.

Ну уж если совсем сильно хочется, может поможет "Model Studio CS" ("Трубопроводы" точно), там при разрезах все примитивы по своим родным слоям располагаются и все свойства наследуют. Только мудрёно всё слишком.

bargool · 25.03.2013, 23:30

Посмотрите Selsim от Александра Ривилиса, можно в макросе забить выбор по образцу, а потом переброс на новый слой

Astartes · 26.03.2013, 05:02

bargool, Автор не указал версию када.
Но, с 2011 (может и раньше) появилась своя команда _SelectSimilar подобная Selsim.

bargool · 26.03.2013, 09:43

Цитата:

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

с 2011 (может и раньше) появилась своя команда _SelectSimilar подобная Selsim.

У меня 2010, такой команды нет

Profan · 26.03.2013, 10:02

Цитата:

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

например отрезки с цветом "синий" переместить в "слой 1", "красный" в "слой 2" и зеленый соответственно в "слой 3".

А если цвет объекта RGB 20,50,100?

Dyuk · 26.03.2013, 12:20

Цитата:

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

Ну уж если совсем сильно хочется, может поможет "Model Studio CS"

Спасибо, нужно всё же это в ACAD реализовать.

Цитата:

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

Но, с 2011 (может и раньше) появилась своя команда _SelectSimilar подобная Selsim.

Действительно, есть такая команда - уже веселее =)

Цитата:

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

У меня 2010, такой команды нет

у меня 2013-ый

Цитата:

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

А если цвет объекта RGB 20,50,100?

Да, нужно, чтобы можно было и по такой кодировке цвета перенести на нужный слой.

VVA · 26.03.2013, 13:54

Код:

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

(defun C:C2L (/ tmp txt count TrueColor layFilter lay _makelayer)
;;; Color To Layer
;;; layFilter - список фильтров слоев
;;; Как переместить отрезки различных слоев из одного слоя в другие слои по цветам?
;;; http://forum.dwg.ru/showthread.php?p=1067614#post1067614
(defun _makelayer ( name color)
    (cond
      ((not (numberp color))(setq color 7))
      ((minusp color)(setq color 7))
      ((zerop color)(setq color 7))
      ((> color 255)(setq color 7))
      (t nil)
      )
     (or (tblobjname "LAYER" name)
     (entmakex
                (list
                    (cons 0 "LAYER")
                    (cons 100 "AcDbSymbolTableRecord")
                    (cons 100 "AcDbLayerTableRecord")
                    (cons 2 name)
                    (cons 70 0)
                    (cons 62 color)
                )
            )
     )
)
  (setq layFilter
         (list
           '((143 134 112) "МойСлой1") ;_ (143 134 112) - примитив с цветом R=143 G=134 B=112 перенесется на слой Мойслой1
           '((110 87 168) "МойСлой2") ;_ (110 87 168) - примитив с цветом R=110 G=87 B=168 перенесется на слой Мойслой2
           '((1) "Красный") ;_ (1) - примитив с цветом ACI=1 перенесется на слой Красный
           '((2) "Желтый") ;_ (2) - примитив с цветом ACI=2 перенесется на слой Желтый
           '((3) "Зеленый") ;_ (3) - примитив с цветом ACI=3 перенесется на слой Зеленый
) ;_ end of list
  ) ;_ end of setq
  (vl-load-com)
  (vlax-for Blk (vla-get-blocks
                  (vla-get-activedocument (vlax-get-acad-object))
                ) ;_ end of vla-get-Blocks
    (if (eq (vla-get-isxref Blk) :vlax-false)
      (progn
        (setq count 0
              txt   (strcat "Changed " (vla-get-name Blk))
        ) ;_ end of setq
        (grtext -1 txt)
        (vlax-for Obj Blk
          (setq count (1+ count))
          (if (zerop (rem count 10))
            (grtext -1 (strcat txt " : " (itoa count)))
          ) ;_ end of if
          (if (and (vlax-write-enabled-p Obj)
                   (vlax-property-available-p Obj 'Color)
              ) ;_ end of and
            (setq tmp
                   (if
                     (= (vla-get-colormethod
                          (setq TrueColor (vla-get-truecolor Obj))
                        ) ;_ end of vla-get-ColorMethod
                        accolormethodbyrgb
                     ) ;_ end of =
                      (list (vla-get-red TrueColor)
                            (vla-get-green TrueColor)
                            (vla-get-blue TrueColor)
                      ) ;_ end of list
                      (cond ((eq (vla-get-color obj) acbyblock)
                             nil
                            )
                            ((eq (vla-get-color obj) acbylayer)
                             nil
                            )
                            (t (list (vla-get-color obj)))
                      ) ;_ end of cond
                   ) ;_ end of if
            ) ;_ end of setq
            (setq tmp nil)
          ) ;_ end of if
          (or (setq lay (cadr (assoc tmp layFilter)))
              (setq
                lay (strcat
                      "Color"
                      (apply
                        'strcat
                        (mapcar '(lambda (x) (strcat "_" (itoa x))) tmp)
                      ) ;_ end of apply
                    ) ;_ end of strcat
              ) ;_ end of setq
          ) ;_ end of or
          (_makelayer lay (car tmp))
          (if (and tmp (listp tmp) (vlax-write-enabled-p Obj))
            (progn
            (entmod
              (subst
                (cons
                  8
                  lay
                ) ;_ end of cons
                (assoc 8 (entget (vlax-vla-object->ename obj)))
                (entget (vlax-vla-object->ename obj))
              ) ;_ end of subst
            ) ;_ end of entmod
            (vla-put-Color obj acByLayer) ;_Color
            ;;; (vla-put-linetype obj "BYLAYER") ;_LineType
            )
          ) ;_ end of if
        ) ;_ end of vlax-for
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of vlax-for
  (vl-cmdf "_regenall")
  (princ)
) ;_ end of defun

sertor · 26.03.2013, 14:02

VVA, у меня почему-то программа не запускается.
Прошу прощения, не досмотрел. Все работает.

Dyuk · 26.03.2013, 16:03

Цитата:

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

Особо не тестировал

Здорово! Лисп работает.
Перемещает отрезки с цветом "R" "G" "B" в слой с названием: Color_"R"_"G"_"B".
А возможно сделать так, чтобы можно было заранее назначать свои названия слоёв соответствующее определенному цвету?

Profan · 26.03.2013, 16:04

А цвета фиксированные, что ли?

Dyuk · 26.03.2013, 16:23

Цитата:

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

А цвета фиксированные, что ли?

Да, я могу при экспорте из sketchup назначить любой нужный мне цвет, т.е. цвета могут быть фиксированными.

VVA · 28.03.2013, 14:16

Цитата:

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

А возможно сделать так, чтобы можно было заранее назначать свои названия слоёв соответствующее определенному цвету?

Описал в комментариях. Должно быть понятно

Код:

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

(defun C:C2L (/ tmp txt count TrueColor layFilter lay)
;;; Color To Layer
;;; layFilter - список фильтров слоев
  (setq layFilter
         (list
           '((143 134 112) "МойСлой1") ;_ (143 134 112) - примитив с цветом R=143 G=134 B=112 перенесется на слой Мойслой1
           '((110 87 168) "МойСлой2") ;_ (110 87 168) - примитив с цветом R=110 G=87 B=168 перенесется на слой Мойслой2
           '((1) "Красный") ;_ (1) - примитив с цветом ACI=1 перенесется на слой Красный
           '((2) "Желтый") ;_ (2) - примитив с цветом ACI=2 перенесется на слой Желтый
           '((3) "Зеленый") ;_ (3) - примитив с цветом ACI=3 перенесется на слой Зеленый
) ;_ end of list
  ) ;_ end of setq
  (vl-load-com)
  (vlax-for Blk (vla-get-blocks
                  (vla-get-activedocument (vlax-get-acad-object))
                ) ;_ end of vla-get-Blocks
    (if (eq (vla-get-isxref Blk) :vlax-false)
      (progn
        (setq count 0
              txt   (strcat "Changed " (vla-get-name Blk))
        ) ;_ end of setq
        (grtext -1 txt)
        (vlax-for Obj Blk
          (setq count (1+ count))
          (if (zerop (rem count 10))
            (grtext -1 (strcat txt " : " (itoa count)))
          ) ;_ end of if
          (if (and (vlax-write-enabled-p Obj)
                   (vlax-property-available-p Obj 'Color)
              ) ;_ end of and
            (setq tmp
                   (if
                     (= (vla-get-colormethod
                          (setq TrueColor (vla-get-truecolor Obj))
                        ) ;_ end of vla-get-ColorMethod
                        accolormethodbyrgb
                     ) ;_ end of =
                      (list (vla-get-red TrueColor)
                            (vla-get-green TrueColor)
                            (vla-get-blue TrueColor)
                      ) ;_ end of list
                      (cond ((eq (vla-get-color obj) acbyblock)
                             nil
                            )
                            ((eq (vla-get-color obj) acbylayer)
                             nil
                            )
                            (t (list (vla-get-color obj)))
                      ) ;_ end of cond
                   ) ;_ end of if
            ) ;_ end of setq
            (setq tmp nil)
          ) ;_ end of if
          (or (setq lay (cadr (assoc tmp layFilter)))
              (setq
                lay (strcat
                      "Color"
                      (apply
                        'strcat
                        (mapcar '(lambda (x) (strcat "_" (itoa x))) tmp)
                      ) ;_ end of apply
                    ) ;_ end of strcat
              ) ;_ end of setq
          ) ;_ end of or
          (if (and tmp (listp tmp) (vlax-write-enabled-p Obj))
            (entmod
              (subst
                (cons
                  8
                  lay
                ) ;_ end of cons
                (assoc 8 (entget (vlax-vla-object->ename obj)))
                (entget (vlax-vla-object->ename obj))
              ) ;_ end of subst
            ) ;_ end of entmod
          ) ;_ end of if
        ) ;_ end of vlax-for
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of vlax-for
  (vl-cmdf "_regenall")
  (princ)
) ;_ end of defun

Dyuk · 28.03.2013, 17:21

Цитата:

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

Описал в комментариях. Должно быть понятно

круто, огромное спасибо, буду проверять =)

pers2 · 23.05.2013, 12:32

Работает отлично!
Вот если б сразу, кроме цвета, присваивать вес и тип линии по слою? Пожалуйста!!!!

VVA · 23.05.2013, 13:00

Добавочку выделил красным

Код:

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

(defun C:C2L1 (/ tmp txt count TrueColor layFilter lay)
;;; Color To Layer
;;; layFilter - список фильтров слоев
  (setq layFilter
         (list
           '((143 134 112) "МойСлой1") ;_ (143 134 112) - примитив с цветом R=143 G=134 B=112 перенесется на слой Мойслой1
           '((110 87 168) "МойСлой2") ;_ (110 87 168) - примитив с цветом R=110 G=87 B=168 перенесется на слой Мойслой2
           '((1) "Красный") ;_ (1) - примитив с цветом ACI=1 перенесется на слой Красный
           '((2) "Желтый") ;_ (2) - примитив с цветом ACI=2 перенесется на слой Желтый
           '((3) "Зеленый") ;_ (3) - примитив с цветом ACI=3 перенесется на слой Зеленый
) ;_ end of list
  ) ;_ end of setq
  (vl-load-com)
  (vlax-for Blk (vla-get-blocks
                  (vla-get-activedocument (vlax-get-acad-object))
                ) ;_ end of vla-get-Blocks
    (if (eq (vla-get-isxref Blk) :vlax-false)
      (progn
        (setq count 0
              txt   (strcat "Changed " (vla-get-name Blk))
        ) ;_ end of setq
        (grtext -1 txt)
        (vlax-for Obj Blk
          (setq count (1+ count))
          (if (zerop (rem count 10))
            (grtext -1 (strcat txt " : " (itoa count)))
          ) ;_ end of if
          (if (and (vlax-write-enabled-p Obj)
                   (vlax-property-available-p Obj 'Color)
              ) ;_ end of and
            (setq tmp
                   (if
                     (= (vla-get-colormethod
                          (setq TrueColor (vla-get-truecolor Obj))
                        ) ;_ end of vla-get-ColorMethod
                        accolormethodbyrgb
                     ) ;_ end of =
                      (list (vla-get-red TrueColor)
                            (vla-get-green TrueColor)
                            (vla-get-blue TrueColor)
                      ) ;_ end of list
                      (cond ((eq (vla-get-color obj) acbyblock)
                             nil
                            )
                            ((eq (vla-get-color obj) acbylayer)
                             nil
                            )
                            (t (list (vla-get-color obj)))
                      ) ;_ end of cond
                   ) ;_ end of if
            ) ;_ end of setq
            (setq tmp nil)
          ) ;_ end of if
          (or (setq lay (cadr (assoc tmp layFilter)))
              (setq
                lay (strcat
                      "Color"
                      (apply
                        'strcat
                        (mapcar '(lambda (x) (strcat "_" (itoa x))) tmp)
                      ) ;_ end of apply
                    ) ;_ end of strcat
              ) ;_ end of setq
          ) ;_ end of or
          (if (and tmp (listp tmp) (vlax-write-enabled-p Obj))
            (progn
            (entmod
              (subst
                (cons
                  8
                  lay
                ) ;_ end of cons
                (assoc 8 (entget (vlax-vla-object->ename obj)))
                (entget (vlax-vla-object->ename obj))
              ) ;_ end of subst
            ) ;_ end of entmod
            (vla-put-Color obj acByLayer) ;_Color
            (vla-put-linetype obj "BYLAYER") ;_LineType
           (vla-put-lineweight obj acLnWtByLayer) ;_LineWeight

            )
          ) ;_ end of if
        ) ;_ end of vlax-for
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of vlax-for
  (vl-cmdf "_regenall")
  (princ)
) ;_ end of defun

pers2 · 23.05.2013, 13:46

Цитата:

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

Добавочку выделил красным

Ай да человек, Человечище!! Спасибо Огромное!!!
А раз пошла такая пьянка...

нельзя ли и вес тоже по слою?...

Кулик Алексей aka kpblc · 23.05.2013, 13:53

там же добавь (vla-put-lineweight obj acLnWtByLayer)

pers2 · 23.05.2013, 14:02

Цитата:

Сообщение от Кулик Алексей aka kpblc

там же добавь (vla-put-lineweight obj acLnWtByLayer)

и Вам поклон низкий!!!

Ну и что б два раза не вставать (сам-то уже пробывал - не получилось...)
Всё в слой 0, цвет остаётся, тип и вес линий по слою... Можно??? Пожалуйста

Bjarki · 27.11.2015, 11:32

Огромное человеческое спасибо, необходимость в подобной функции была очень давно.
И еще большая просьба, может кто помочь модернизировать код, чтобы цвет слоя был от отрезка.

VVA · 27.11.2015, 12:35

Так там вроде так и делается?

Bjarki · 28.11.2015, 06:35

Дома autocad нет под рукой, у меня несколько расширенная задача.
Так же постоянно экспортируем в dfx из горно-геологического программного комплекса, все вылезает отрезками, для своего удобства выгоняем различными цветами (зачастую более одного десятка цветов), потом ручками разносим послоям и дальше работаем. Времени уходит уйма.
Пробовал Lisp из сообщения #18 работает идеально, создает слои Color_"номер цвета", все разносит, но цвет слоя белый.
Только сейчас увидел, что нужно был попробовать нужно код из #10. На работе все попробую.
Еще раз огромное спасибо, сократили нам огромный объем работы.

VVA · 30.11.2015, 15:01

Цитата:

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

что нужно был попробовать нужно код из #10. На работе все попробую

Обрати внимание, я внес в #10 небольшие изменения.

sergeev_2005 · 03.06.2016, 10:44

К VVA
А вот можно ли переименовать слой, но не в соответствии с цветом объекта, а в соответствии с цветом самого слоя?

VVA · 03.06.2016, 11:08

sergeev_2005,
Кратко - можно.
А дальше одни вопросы.
Есть слой "0", цвет слоя "красный", его нужно переименовать в "0_1", где 1 - красный?
Есть слой "Стена", цвет слоя "синий",его нужно переименовать в "Стена_5"?
Есть слой "Оси", цвет слоя "119,213,34",его нужно переименовать в "Оси_119_213_34"?
Что делать, если есть слой "Стена", цвет слоя "синий" и слой "Стена_5" так же еcть в перечне слоев?

sergeev_2005 · 03.06.2016, 11:29

VVA, спасибо!
Нет, не так.
Как в твоей программе C2L иметь возможность самому давать название слоя для переименования в зависимости от цвета.
Если цвет слоя с любым названием "119,213,34", то дать слою новое название (вручную), например "Мойслой1", как в твоей программе C2L.
Если цвет слоя с любым названием "4", то дать слою новое название (вручную), например "Мойслой2".

VVA · 03.06.2016, 11:41

Ну так а чем #18 не устраивает?
В коде есть коментарии. Создаешь layFilter по своим правилам и все

 
Код:

[Выделить все]
(defun C:L2LC (/ tmp txt count TrueColor layFilter lay)
;;; Layer To Layer by Color
;;; layFilter - список фильтров слоев
  (setq layFilter
         (list
           '((207 42 213) "МойСлой1") ;_ (207 42 213) - слой с цветом R=143 G=134 B=112 переименуется в слой Мойслой1
           '((5) "Синий")             ;_ (2) - слой с цветом 5 переименуется в слой Синий
         ) ;_ end of list
  ) ;_ end of setq
  (vl-load-com)
  (vlax-for Layer (vla-get-layers
                    (vla-get-activedocument (vlax-get-acad-object))
                  ) ;_ end of vla-get-layers
    (if (snvalid (vla-get-name Layer))
      (progn
        (setq tmp
               (if
                 (= (vla-get-colormethod
                      (setq TrueColor (vla-get-truecolor Layer))
                    ) ;_ end of vla-get-ColorMethod
                    accolormethodbyrgb
                 ) ;_ end of =
                  (list (vla-get-red TrueColor)
                        (vla-get-green TrueColor)
                        (vla-get-blue TrueColor)
                  ) ;_ end of list
                  (cond ((eq (vla-get-color Layer) acbyblock)
                         nil
                        )
                        ((eq (vla-get-color Layer) acbylayer)
                         nil
                        )
                        (t (list (vla-get-color Layer)))
                  ) ;_ end of cond
               ) ;_ end of if
        ) ;_ end of setq
        (or (setq lay (cadr (assoc tmp layFilter)))
;;;            (setq
;;;              lay (strcat
;;;                    "Color"
;;;                    (apply
;;;                      'strcat
;;;                      (mapcar '(lambda (x) (strcat "_" (itoa x))) tmp)
;;;                    ) ;_ end of apply
;;;                  ) ;_ end of strcat
;;;            ) ;_ end of setq
        ) ;_ end of or
        (if (and lay (not (tblobjname "Layer" lay)))
          (vl-catch-all-apply 'vla-put-name (list Layer lay))
        ) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of vlax-for
  (princ)
) ;_ end of defun

sergeev_2005 · 03.06.2016, 12:01

Все бы устраивало, но примитивы имеют цвет "по слою".
А в этом случае ничего не происходит.
А мне нужно все слои с цветом 119,213,34 назвать "Мойслой1" и т.д.
То есть все примитивы, "лежащие" на разный слоях с одним и тем же цветом, оказались на новом слое, название которому я сам могу дать.

----- добавлено через ~38 мин. -----
Да, именно это и нужно!
Но, наверное, я много хочу.
По программе L2LC самопроизвольно создались новые слои типа "Color_182_181_180" и "Color_7". Это не нужно.
А вот два "старых" слоя с одинаковым цветом повели себя следующим образом: первый получил новое название, которое я задал, а вот второй как был, так и остался с прежним названием.
А хотелось бы, чтобы слои с одинаковым цветом слились в один слой. И объекты с этих слоев попали на один новый слой.
Ну очень надо!

----- добавлено через ~58 мин. -----
VVA, можно надеяться на помощь?

VVA · 03.06.2016, 13:08

Цитата:

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

"Color_182_181_180" и "Color_7". Это не нужно

Исправил в #29

Цитата:

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

два "старых" слоя с одинаковым цветом повели себя следующим образом

Это требует пояснения. Как появляются два слоя с одинаковым цветом?

sergeev_2005 · 03.06.2016, 13:20

Нет, они не появились. Они были. Конкретно, их названия были "A-WALL-PATT1" с цветом "133,169,214" и слой "A-WALL-PATT4" с цветом "133,169,214".
На первом и втором слое лежали "одинаковые" объекты (полилинии с заливкой). И мне надо в идеале, чтобы эти объекты перешли на новый слой "Мой слой...", а "A-WALL-PATT1" и "A-WALL-PATT4" удалились.
Фактически сейчас получается, что объекты, лежавшие на слое "A-WALL-PATT1" перешли на новый слой "Мой слой...", причем слой "A-WALL-PATT1" удалился. А вот слой "A-WALL-PATT4" остался, и объекты на нем остались.

----- добавлено через ~4 мин. -----
Может быть сформулировать иначе?
Все объекты, лежащие на слоях с одинаковым цветом, должны перейти на новый слой, название которому я задам вручную, а слои, на которых они лежали, удаляются.

Composter · 23.10.2019, 10:25

немногог добавил чтобы в новом слое было имя исходного слоя и цвет нового слоя являлся цветом примитива

Код:

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

(defun C:C2L (/ tmp txt count TrueColor layFilter lay tmp_L_N)
;;;http://forum.dwg.ru/showthread.php?p=1069183
;;;http://www.cadtutor.net/forum/showthread.php?533-Lisp-colour-change-for-all-layers-and-blocks/page10
;;; Color To Layer
;;; layFilter - Layer List
;;;If the colors are not in the list of layers, the layer will be called Color_Number.
;;;For example, for 123 colors -> Layer name "Color _123"
;;;color R = 12 G = 32 B = 65  -> Layer name "Color _12_32_65"
 (setq layFilter
        (list
          '((143 134 112) "MyLay1") ;_entity with color R = 143 G = 134 B = 112 is transferred to the layer "MyLay1"
          '((110 87 168) "MyLay2")  ;_entity with color R = 110 G = 87 B = 168 is transferred to the layer "MyLay2"
          '((1) "Red")  ;_entity with color ACI = 1 is transferred to the layer "Red"
          '((2) "Yellow") ;_entity with color ACI = 2 is transferred to the layer "Yellow"
          '((3) "Green")  ;_entity with color ACI = 3 is transferred to the layer "Green"
) ;_ end of list
 ) ;_ end of setq
 (vl-load-com)
 (vlax-for Blk (vla-get-blocks
                 (vla-get-activedocument (vlax-get-acad-object))
               ) ;_ end of vla-get-Blocks
   (if (eq (vla-get-isxref Blk) :vlax-false)
     (progn
       (setq count 0
             txt   (strcat "Changed " (vla-get-name Blk))
       ) ;_ end of setq
       (grtext -1 txt)
       (vlax-for Obj Blk
         (setq count (1+ count))
         (if (zerop (rem count 10))
           (grtext -1 (strcat txt " : " (itoa count)))
         ) ;_ end of if
         (if (and (vlax-write-enabled-p Obj)
                  (vlax-property-available-p Obj 'Color)
             ) ;_ end of and
           (setq tmp
                  (if
                    (= (vla-get-colormethod
                         (setq TrueColor (vla-get-truecolor Obj))
                       ) ;_ end of vla-get-ColorMethod
                       accolormethodbyrgb
                    ) ;_ end of =
                     (list (vla-get-red TrueColor)
                           (vla-get-green TrueColor)
                           (vla-get-blue TrueColor)
                     ) ;_ end of list
                     (cond ((eq (vla-get-color obj) acbyblock)
                            nil
                           )
                           ((eq (vla-get-color obj) acbylayer)
                            nil
                           )
                           (t (list (vla-get-color obj)))
                     ) ;_ end of cond
                  ) ;_ end of if
				  tmp_L_N
						(vla-get-Layer Obj)
           ) ;_ end of setq
           (setq tmp nil)
         ) ;_ end of if
         (or (setq lay (cadr (assoc tmp layFilter)))
             (setq
               lay (strcat
                      tmp_L_N "_" "Color"
                     (apply
                       'strcat
                       (mapcar '(lambda (x) (strcat "_" (itoa x))) tmp)
                     ) ;_ end of apply
                   ) ;_ end of strcat
             ) ;_ end of setq
         ) ;_ end of or
         (if (and tmp (listp tmp) (vlax-write-enabled-p Obj))
           (entmod
             (subst
               (cons
                 8
                 lay
               ) ;_ end of cons
               (assoc 8 (entget (vlax-vla-object->ename obj)))
               (entget (vlax-vla-object->ename obj))
             ) ;_ end of subst
           ) ;_ end of entmod
         ) ;_ end of if
		 (setq tmp_L_N nil)
		 (vla-put-truecolor (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) (vla-get-layer obj)) (vla-get-truecolor obj))
		(vla-put-Color obj acByLayer)
       ) ;_ end of vlax-for
     ) ;_ end of progn
   ) ;_ end of if
 ) ;_ end of vlax-for
 (vl-cmdf "_regenall")
 (princ)
) ;_ end of defun

AntonFox · 06.05.2020, 20:22

Уже несколько дней бьюсь с задачей и никак не найду решение. VBA занимаюсь по случаю, поэтому самое сложное - понять почему выскочила ошибка. Долго искал в интернете в итоге нашел эту ветку.
Задача: есть чужой чертеж с множеством слоев разного (иногда и одинакового) цвета. Необходимо разместить все примитивы цвета Х или с цветом по слою и расположенных на слое с цветом Х на отдельном слое "sloi_x" где х - цвет (1...255).
Попробовал код выше. Если у примитива конкретный цвет - все нормально. Но если цвет по слою - примитивы никуда не переносятся. В итоге у меня куча слоев, по 2-6 шт одного цвета.
То есть после работы программы у меня 4 желтых слоя осталось, 6 красных, два зеленых.
AutoCAD2007

Кулик Алексей aka kpblc · 07.05.2020, 12:26

Если у примитива цвет "по слою" - читай, какой у него слой, определяй цвет слоя и вперед.

AntonFox · 08.05.2020, 14:25

Если бы все было так просто... У меня перебираются все примитивы, 3 ветки условий.
1. Если цвет примитива по слою, примитиву присваивается цвет слоя.
2. Если цвет примитива по блоку, присваивается цвет белый
3. Если цвет примитива какой-то другой (1...255), создается слой "sloi_X", где Х- цифра цвета (проверка на существование слоя тоже есть) и примитив переносится на этот слой, цвет делается по слою. Примитивы по первым двум веткам так же проходят через ветку 3, поскольку мы им поменяли цвет на "цифру"
В большинстве случаев все срабатывает на ура. Но примерно 10% файлов ведут себя иначе. Если удаляю часть чертежа, я получаю новые ошибки в других местах. Предполагаю, что дело в каких-то примитивах, но почему ошибки скачут с места на место, не понимаю.

Код:

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

Option Explicit

Dim sele As AcadSelectionSet                ' рабочий набор примитивов
Dim AnyObj As AcadEntity                    ' примитив (любой)
Dim layerObj As AcadLayer                   ' слой
Dim i As Integer                            ' счетчик



Sub pos()
' Программа упрощает чертеж.
' Программа создает слои типа sloi_X, где Х - номер цвета и переносит все примитивы чертежа
' на эти слои согласно цветам примитивов и цветам слоев. При этом:
' *************************
' Таким образом в идеале в чертеже остаются только слои вида sloi_X, Defpoints, 0
  
   Call createall3 ' создание слоев

  '**********************************************************************************
  '********************************Создание рабочего набора**************************
  '**********************************************************************************
    On Error GoTo 1
    Set sele = ThisDrawing.SelectionSets.Add("test")    ' Рабочий набор будет называться ТЕСТ
1:  Set sele = ThisDrawing.SelectionSets.Item("test")   ' Если при создании набора ошибка (набор уже есть такой), то просто присваиваем
    sele.Select acSelectionSetAll                       ' Добавление в рабочий набор всех примитивов

  '**********************************************************************************
  '********************************Обработка примитивов в чертеже********************
  '**********************************************************************************
  Dim schetchik
  schetchik = 1
  
  For Each AnyObj In sele
    Call chistka3(AnyObj)
    schetchik = schetchik + 1
  Next
  '**********************************************************************************
  '********************************Завершение работы*********************************
  '**********************************************************************************
  sele.Clear        ' обнуление рабочего набора примитивов
  ThisDrawing.Regen acActiveViewport        ' регенерация активного окна
  MsgBox ("Нормализация чертежа завершена!")
  
End Sub

Sub chistka3(AnyObj As AcadEntity)

Dim kolor
Dim snewname
          '*******************ЦВЕТА*************************
  
        If AnyObj.color = acByLayer Then                ' если цвет примитива по слою, то есть 256
           For i = 0 To ThisDrawing.Layers.Count - 1    ' то пробегая по всем слоям чертежа
              If ThisDrawing.Layers.Item(i).Name = AnyObj.Layer Then  ' выясняем на каком слое находится примитив
                 kolor = ThisDrawing.Layers.Item(i).TrueColor.ColorIndex
              End If
           Next i
           AnyObj.color = kolor   ' и указываем как цвет примитива по цвету слоя
        End If
        '**************
        
        
        If AnyObj.color = acByBlock Then  'по блоку, то есть 0
           AnyObj.color = 7
        End If
        '**************
        
        
        'НЕ по слою  и не по блоку
         kolor = AnyObj.color
         snewname = ("sloi_" & kolor)
           
        On Error GoTo Ex3
        Set layerObj = ThisDrawing.Layers.Add(snewname)   ' создание слоя
        layerObj.color = kolor                           ' задание слою цвета
Ex3:
           AnyObj.Layer = snewname
           AnyObj.color = acByLayer
        '****************************************
        
Exit1: End Sub


Sub createall3()

  '**********************************************************************************
  '********************************Создание слоев*********************
  '**********************************************************************************

      ' разморозка, разблокировка и включение всех слоев в чертеже
    For Each layerObj In ThisDrawing.Layers
       If layerObj.Freeze = True Then layerObj.Freeze = False   ' разморозка замороженных слоев
       If layerObj.Lock = True Then layerObj.Lock = False       ' разблокировка блокированных слоев
       If layerObj.LayerOn = False Then layerObj.LayerOn = True ' включение слоев
    Next
 ' создание слоев "sloi_X" где Х - номер цвета слоя
 '   Dim sname
 '   Dim i As Integer
 '   sname = "sloi_"
 '   For i = 1 To 255
 '       On Error GoTo Ex1
 '       Set layerObj = ThisDrawing.Layers.Add(sname & i)   ' создание слоя
 '      layerObj.color = i                                     ' задание слою цвета
'Ex1:    Next i
    
End Sub

Boxa · 08.05.2020, 14:58

Наборы нужно чистить перед использованием.
Глобальные переменные - зло.
Строить логику работы программы на обработчиках ошибок - еще большее зло

Про остальное писать не буду, я не пишу на VBA и мог подзабыть многое...
То что я изваял из Вашего кода, лично мне не нравится, но за неимением времени... пойдет.

Код:

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

Option Explicit
Sub pos()
    Call UnLockAllLayers
    Dim block As AcadBlock
    Dim AnyObj As AcadEntity
    
    For Each block In ThisDrawing.blocks
        For Each AnyObj In block
            Call chistka3(AnyObj)
        Next
    Next
    
    ThisDrawing.Regen acActiveViewport        ' регенерация активного окна
    MsgBox ("Нормализация чертежа завершена!")
End Sub

Sub chistka3(AnyObj As AcadEntity)
    Dim kolor As Integer
    Dim snewname As String
    
    If AnyObj.color = acByLayer Then
        ' если цвет примитива по слою, то есть 256
        kolor = ThisDrawing.Layers.Item(AnyObj.Layer).TrueColor.ColorIndex
        'AnyObj.color = kolor
    ElseIf AnyObj.color = acByBlock Then
        'по блоку, то есть 0
        kolor = 7
        'AnyObj.color = kolor
    Else
        'НЕ по слою  и не по блоку
        kolor = AnyObj.color
    End If
    
    snewname = "sloi_" & kolor
    Call CreateLayer(snewname, kolor)
    
    AnyObj.Layer = snewname
    AnyObj.color = acByLayer
End Sub

' Проверка наличия в чертеже слоя с заданным именем
Private Function ValidateLayer(strName As String) As Boolean
  Dim objLayer As AcadLayer
  Dim objLayers As AcadLayers
  Set objLayers = ThisDrawing.Layers
  For Each objLayer In objLayers
    If objLayer.Name = strName Then
      ValidateLayer = True
      Exit For
    End If
  Next objLayer
End Function

Sub CreateLayer(layerName As String, kolor As Integer)
    If ValidateLayer(layerName) = False Then
        Dim layerObj As AcadLayer
        Set layerObj = ThisDrawing.Layers.Add(layerName)   ' создание слоя
        layerObj.color = kolor                           ' задание слою цвета
    End If
End Sub


Sub UnLockAllLayers()
    Dim layerObj As AcadLayer
    ' разморозка, разблокировка и включение всех слоев в чертеже
    For Each layerObj In ThisDrawing.Layers
       If layerObj.Freeze = True Then layerObj.Freeze = False   ' разморозка замороженных слоев
       If layerObj.Lock = True Then layerObj.Lock = False       ' разблокировка блокированных слоев
       If layerObj.LayerOn = False Then layerObj.LayerOn = True ' включение слоев
    Next
End Sub

AntonFox · 08.05.2020, 20:45

Не все понял что вы сделали и написали - буду еще разбираться, НО.... (см. картинку)

PS: Некоторые вещи у вас уже увидел - проще и красивее сделали. Увы, из-за редкого программирования почти не совершенствуюсь, от того и казусы.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Какой язык перспективен для инженера-конструктора с условием	The_Mercy_Seat	Программирование	705	17.03.2021 14:19
1000 слоев. Нормально или плохо? И другие аспекты правильного черчения в автокаде	Vova	AutoCAD	96	07.09.2019 16:26
Для чего нужны фильтры слоев?Как ими пользоваться?	Aysulu	AutoCAD	43	17.04.2019 10:59
Unreconciled new layers при Xref	Red Nova	AutoCAD	17	10.01.2019 13:00
Почему не проходит теплорасчет?	Suom	Конструкции зданий и сооружений	15	10.08.2011 17:22

25.03.2013, 20:46		#1
Как переместить отрезки различных слоев из одного слоя в другие слои по цветам? Dyuk ПГС Санкт-Петербург Регистрация: 25.11.2007 Сообщений: 282 Здравствуйте. Помогите с решением такой задачи: Имеется чертеж, в котором все отрезки находятся в нулевом слое. Различные отрезки имеют свой цвет. (например синий, красный и зеленый). Необходимо переместить эти отрезки из нулевого слоя в отдельные слои соответствующие цветам отрезкам. например отрезки с цветом "синий" переместить в "слой 1", "красный" в "слой 2" и зеленый соответственно в "слой 3". Всё это нужно сделать в автоматизированном режиме. Может быть есть какой плагин подходящий? : Помощь: Спасибо за внимание. Зачем мне это надо? Я обнаружил, что из Sketchup можно экспортировать в автокад любые виды и разрезы (аналог команды flatshot, sectionplane). Но преимущество Sketchup в том, что при экспорте в автокад можно задать линиям цвет соответствующий определенному слою. более подробно об этом можно посмотреть ссылке в видео ниже http://youtu.be/0Qd4z5t0Ns8
Просмотров: 21607