Архитектору и проектировщику|Тепло- и звукоизоляция URSA.RU
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Нужен Лисп для перевода цвета объекта

Нужен Лисп для перевода цвета объекта

Ответ
Поиск в этой теме
Непрочитано 19.10.2004, 10:52 #1
Нужен Лисп для перевода цвета объекта
ilka_t
 
Москва
Регистрация: 20.01.2004
Сообщений: 154

Нет ли у кого нибудь Лиспа чтобы можно было сделать следующе:

Есть разные объекты которые находятся в разных слоях и цвет у них стоит "по слою", а сделать чтобы у них стал цвет не "по слою" а стал цветом слоя.
Просмотров: 6448
 
Непрочитано 19.10.2004, 11:36
#2
Эдуард

строительство
 
Регистрация: 16.01.2004
Петербург
Сообщений: 164
<phrase 1=


Так его и написать несложно.Только зачем???
Код:
[Выделить все]
(defun color-bylayer ()
  (vl-load-com)
  (setq	database (mapcar 'vlax-ename->vla-object
			 (vl-remove-if
			   'listp
			   (mapcar 'cadr
				   (ssnamex (ssget "x")
				   )
			   )
			 )
		 )
  )
  (foreach item	database
    (if
      (= (vla-get-color item) 256)
       (vla-put-color
	 item
	 (vla-get-color
	   (vla-item (vla-get-layers
		       (vla-get-activedocument (vlax-get-acad-object))
		     )
		     (vla-get-layer item)
	   )
	 )
       )
    )
  )
)
Эдуард вне форума  
 
Автор темы   Непрочитано 19.10.2004, 12:10
#3
ilka_t


 
Регистрация: 20.01.2004
Москва
Сообщений: 154


Спасибо что откликнулись,но

у меня в одном файле работает а в другом не хочет пишет ошибку

"_color-bylayer ; error: An error has occurred inside the *error*
functionAutoCAD variable setting rejected: "OSMODE" nil"


и если бы еще можно было выбирать объекты, которым он менял цвета


У архитекторов там такая куча мала со слоями и цветами, проще все в один слой кинуть чем в них разбираться....
ilka_t вне форума  
 
Непрочитано 19.10.2004, 13:07
#4
Эдуард

строительство
 
Регистрация: 16.01.2004
Петербург
Сообщений: 164
<phrase 1=


Тогда вот так
Код:
[Выделить все]
(defun color-bylayer ()
  (vl-load-com)
  (if
    (setq database (ssget '((62 . 256))))
     (progn
       (setq database
	      (mapcar 'vlax-ename->vla-object
		      (vl-remove-if
			'listp
			(mapcar	'cadr
				(ssnamex database)
			)
		      )
	      )
       )


       (foreach	item database

	 (vla-put-color
	   item
	   (vla-get-color
	     (vla-item (vla-get-layers
			 (vla-get-activedocument (vlax-get-acad-object))
		       )
		       (vla-get-layer item)
	     )
	   )
	 )
       )
     )
  )
  (princ)
)
Эдуард вне форума  
 
Непрочитано 22.11.2010, 12:11
#5
Lesam


 
Регистрация: 22.11.2010
Сообщений: 5


Решил в этой старой темке вопрос задать, чтобы не плодить лишнего...
Подскажет ли кто-нибудь как извлечь лиспом цвет слоя?
Мой случай: есть куча примитивов, у которых расцветка по слою. Т.е. в явном виде нет цвета. Мне надо узнать цвет слоя каждого примитива, произвести анализ и разбросать примитивы в слои с одинаковым цветом. Лишние слои удалить.
Lesam вне форума  
 
Непрочитано 22.11.2010, 12:19
#6
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,683
Отправить сообщение для Do$ с помощью Skype™


Код:
[Выделить все]
(entget (tblobjname "layer" <имя слоя>))
62 группа - цвет и состояние включен/выключен (если отрицательное число, то выключен)
420 - RGB цвет
Do$ вне форума  
 
Непрочитано 22.11.2010, 12:24
#7
Lesam


 
Регистрация: 22.11.2010
Сообщений: 5


Благодарю! Буду пробовать!
Lesam вне форума  
 
Непрочитано 23.11.2010, 13:12
#8
Lesam


 
Регистрация: 22.11.2010
Сообщений: 5


Попробовал. Блин комом.
Первое: как при помощи entmod присвоить примитиву цвет, если у некоторых примитивов в наборе группа 62 отсутствует (т.е. по умолчанию указана по слою)?
Второе: как грамотно создать логистику выбора примитивов из списка по цвету примитива и цвету слоя?
Код:
Код:
[Выделить все]
(defun c:tcol ();распределение примитивов по слоям
(setq ss (ssget "X")
      n	 0
      na (ssname ss n)
)
(while na
  (progn
	(setq	nam  (entget na)
		pt8 (cdr (assoc 8 nam)); слой в котором находится примитив
		pt62 (cdr (assoc 62 nam)); цвет самого примитива
		col_la (cdr (assoc 62 (entget (tblobjname "layer" pt8)))) ; цвет слоя в котором находится примитив
	)
;в этом месте необходимо встроить логику по отбору примитивов, удовлетворяющим нужным требованиям (цвет примитива 7, или цвет слоя в котором он расположен 7, или и то и другое)
	(setq	var (subst (cons 62 1) (assoc 62 nam) nam)
	  	n    (1+ n)
	  	na   (ssname ss n)
	)
	(entmod var)
  );progn
)
(setq na nil)
);defun
Lesam вне форума  
 
Непрочитано 24.11.2010, 15:31
#9
Lesam


 
Регистрация: 22.11.2010
Сообщений: 5


Наверное криво спросил в предыдущем посту.
Подскажите пожалуйста, как в DXF код
Код:
[Выделить все]
((-1 . <Имя объекта: 7ef03c20>) (0 . LINE) (330 . <Имя объекта: 7ef01cf8>) (5 . 
3FC) (100 . AcDbEntity) (67 . 0) (410 . Model) (8 . 0) (100 . AcDbLine) (10 
4514.04 2437.6 0.0) (11 5568.27 3713.93 0.0) (210 0.0 0.0 1.0))
впихнуть 62 группу, чтобы стало так:
Код:
[Выделить все]
((-1 . <Имя объекта: 7ef03c20>) (0 . LINE) (330 . <Имя объекта: 7ef01cf8>) (5 . 
3FC) (100 . AcDbEntity) (67 . 0) (410 . Model) (8 . 0) (62 . 1) (100 . 
AcDbLine) (10 4514.04 2437.6 0.0) (11 5568.27 3713.93 0.0) (210 0.0 0.0 
1.0))
Lesam вне форума  
 
Непрочитано 24.11.2010, 15:40
#10
TararykovDG

Программист-энтузиаст
 
Регистрация: 17.07.2009
Воронеж
Сообщений: 571


Цитата:
как при помощи entmod присвоить примитиву цвет, если у некоторых примитивов в наборе группа 62 отсутствует (т.е. по умолчанию указана по слою)?
вместо
Код:
[Выделить все]
(setq var (subst (cons 62 1) (assoc 62 nam) nam))
(entmod var)
так
Код:
[Выделить все]
(if (not (assoc 62 var))
  (progn
    (setq var (append var (list (cons 62 1)))) ; или вместо 1 нужный цвет
    (entmod var)
    )
  )
__________________
cadtools
TararykovDG вне форума  
 
Непрочитано 06.10.2011, 09:54
#11
angel-fear

инженер-электрик
 
Регистрация: 21.10.2010
Краснодар
Сообщений: 132


А можно подкорректировать код #4 чтобы не только цвета назначались насильно, но и типы и веса линий тоже?
angel-fear вне форума  
 
Непрочитано 06.10.2011, 14:30
#12
Lesam


 
Регистрация: 22.11.2010
Сообщений: 5


Конечно можно. Просто надо знать какую группу менять. Чтобы не листать книги я вывожу на экран свойства двух идентичных примитивов, отличающихся лишь одним признаком, например:
Command:
Command: test

“Выберите обьект:
((-1 . <Entity name: 7eeb8540>) (0 . LINE) (330 . <Entity name: 7eeb6cf8>) (5 .
220) (100 . AcDbEntity) (67 . 0) (410 . Model) (8 . 0) (6 . Continuous) (100 .
AcDbLine) (10 947.293 1511.57 0.0) (11 2167.95 1514.11 0.0) (210 0.0 0.0
1.0))((-1 . <Entity name: 7eeb8540>) (0 . "LINE") (330 . <Entity name:
7eeb6cf8>) (5 . "220") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")
(6 . "Continuous") (100 . "AcDbLine") (10 947.293 1511.57 0.0) (11 2167.95
1514.11 0.0) (210 0.0 0.0 1.0))

Command:
TEST
“Выберите обьект:
((-1 . <Entity name: 7eeb8548>) (0 . LINE) (330 . <Entity name: 7eeb6cf8>) (5 .
221) (100 . AcDbEntity) (67 . 0) (410 . Model) (8 . 0) (6 . Continuous) (370 .
90)
(100 . AcDbLine) (10 906.605 1140.51 0.0) (11 2091.66 1163.38 0.0) (210 0.0
0.0 1.0))((-1 . <Entity name: 7eeb8548>) (0 . "LINE") (330 . <Entity name:
7eeb6cf8>) (5 . "221") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")
(6 . "Continuous") (370 . 90) (100 . "AcDbLine") (10 906.605 1140.51 0.0) (11
2091.66 1163.38 0.0) (210 0.0 0.0 1.0))

Зная, что второму примитиву я средствами автокада назначил вес линии 0,9 ищу отличия в описании и вычисляю группу. В моём примере - это группа 370. Она появилась во втором примитиве (370 .
90)
и её значение соответствует толщине 0,9мм.
В первом примитиве значение толщины было "по слою", поэтому и не присутствует в описании
Lesam вне форума  
 
Непрочитано 21.11.2011, 23:38
#13
Garand


 
Регистрация: 28.10.2008
Сообщений: 26


Если не затруднит, что конкретно нужно изменить в коде из поста №4, чтобы изменялись еще типы и веса линий? Так и не разобрался с тем, какую группу менять.
Garand вне форума  
 
Непрочитано 21.11.2011, 23:45
#14
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,760


Garand, а что ты хочешь заменить-то?
Как вариант:
Код:
[Выделить все]
(vl-load-com)

(defun normalize (/ adoc)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (vlax-for layout (vla-get-layouts adoc)
    (vlax-for ent (vla-get-block layout)
      (foreach prop '(("color" . 256) ; для замены цвета на "ПоСлою"
                      ("lineweight" . -3) ; то же, вес линии
                      ("linetype" . "ByLayer") ; то же, тип линии
                      )
        (vl-catch-all-apply
          (function
            (lambda ()
              (vlax-put-property ent (car prop) (cdr prop))
              ) ;_ end of lambda
            ) ;_ end of function
          ) ;_ end of vl-catch-all-apply
        ) ;_ end of foreach
      ) ;_ end of vlax-for
    ) ;_ end of vlax-for
  (vla-regen adoc acallviewports)
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 22.11.2011, 00:32
#15
Garand


 
Регистрация: 28.10.2008
Сообщений: 26


Не, не совсем то, а как раз наоборот: не замена цвета на "ПоСлою", а замена с "ПоСлою" на цвет фактический, заданный в менеджере слоев. Так вот, в коде поста №4 это все решается, а я хочу еще менять веса и типы линий с "ПоСлою" на фактические. Хочу, но не получается.
Garand вне форума  
 
Непрочитано 22.11.2011, 02:20
1 | #16
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,760


Код:
[Выделить все]
 (vl-load-com)

(defun unnormalize (/ adoc)
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (vlax-for layout (vla-get-layouts adoc)
    (vlax-for ent (vla-get-block layout)
      (foreach prop '("color" "lineweight" "linetype")
        (vl-catch-all-apply
          (function
            (lambda ()
              (vlax-put-property ent
                                 prop
                                 (vlax-get-property (vla-item (vla-get-layers adoc) (vla-get-layer ent)) prop)
                                 ) ;_ end of vlax-put-property
              ) ;_ end of lambda
            ) ;_ end of function
          ) ;_ end of vl-catch-all-apply
        ) ;_ end of foreach
      ) ;_ end of vlax-for
    ) ;_ end of vlax-for
  (vla-regen adoc acallviewports)
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 22.11.2011, 10:52
#17
Garand


 
Регистрация: 28.10.2008
Сообщений: 26


Спасибо!
То, что надо!
Garand вне форума  
 
Непрочитано 22.11.2011, 11:15
#18
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,801
<phrase 1= Отправить сообщение для VVA с помощью Skype™


Добавлю свои 5 копеек
Color From Layer
Код:
[Выделить все]
(defun C:COLORFL ( / adoc blocks color ent lays ss i)
  ;;;Color From Layer
  (vl-load-com)
    (setq adoc  (vla-get-activedocument (vlax-get-acad-object))
          lays  (vla-get-layers adoc)
    )
    (setvar "errno" 0)
    (vla-startundomark adoc)
   (vl-catch-all-apply
   '(lambda ()
    (while (setq ss (ssget "_:L"))
      (setq i '-1)
      (repeat (sslength ss)
        (setq ent (vlax-ename->vla-object (ssname ss (setq i (1+ i))))
              lay (vla-item lays (vla-get-layer ent))
              color (vla-get-color lay)
              )
        (if (= (vla-get-lock lay) :vlax-true)
          (progn (setq layloc (cons lay layloc))
            (vla-put-lock lay :vlax-false)
            )
          )
        (vl-catch-all-apply (function vla-put-color) (list ent color))
        )
      )
      )
   )
      (foreach i layloc (vla-put-lock i :vlax-true))
     (vla-endundomark adoc)
    (princ)
  )
И Properties From Layer
Код:
[Выделить все]
(defun C:PFL (/ adoc blocks  ent lays ss i color linetype lineweight *error*)
;;;Properties From Layer
    (defun *error* (msg)
    (setvar "MODEMACRO" "")
    (princ msg)
    (vla-regen aDOC acactiveviewport)
    (bg:progress-clear)
    (bg:layer-status-restore)
    (princ)
  ) ;_ end of defun

  (vl-load-com)
  (command "_.UNDO" "_Mark")
  (setvar "CLAYER" "0")
  (pfl)
  (command "_.Regenall")
  (princ "\n*** Command _.UNDO _Back restore previous settings")
  (princ)
  ) ;_ end of defun
(defun pfl ( / layer-list aDOC count  *error* color linetype lineweight lays count)
  (defun *error* (msg)
    (setvar "MODEMACRO" "")
    (princ msg)
    (vla-regen aDOC acactiveviewport)
    (bg:progress-clear)
    (bg:layer-status-restore)
    (princ)
  ) ;_ end of defun
  (defun _loc_fun ()
    (if	(= (vla-get-IsXref Blk) :vlax-false)
      (progn
	(setq count 0)
	(if (> (vla-get-count Blk) 100)
	  (bg:progress-init
	    (strcat (vla-get-name Blk) " :")
	    (vla-get-count Blk)
	  ) ;_ end of bg:progress-init
	  (progn
	    (setvar "MODEMACRO" (vla-get-name Blk))
	  ) ;_ end of progn
	) ;_ end of if
	(vlax-for Obj Blk
          (setq lay        (vla-item lays (vla-get-layer Obj))
                 color      (vla-get-color lay)
                 linetype   (vla-get-linetype lay)
                 lineweight (vla-get-lineweight lay)
           ) ;_ end of setq
          (bg:progress (setq count (1+ count)))
          (vl-catch-all-apply
             '(lambda ()
                (if (eq (vla-get-color Obj) acByLayer)(vla-put-color Obj color))
                (if (eq (vla-get-linetype Obj) "ByLayer") (vla-put-linetype Obj linetype))
                (if (eq (vla-get-lineweight Obj) acLnWtByLayer)(vla-put-lineweight Obj lineweight))
              ) ;_ end of lambda
           ) ;_ end of vl-catch-all-apply
          ) ;_ end of vlax-for
	(bg:progress-clear)
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun
  (setq	aDOC	   (vla-get-activedocument (vlax-get-acad-object))
        lays (vla-get-layers adoc)
  ) ;_ end of setq
;;;  (grtext -1 "Stage 1. Viewing of layers")
  (bg:layer-status-save)
  (vlax-for Blk (vla-get-Blocks aDOC)
    (if (eq (vla-get-IsLayout Blk) :vlax-true)
      (_loc_fun)))
  (bg:layer-status-restore)
 ;;;  ???????
  (setq *PD_LAYER_LST* nil)
)
(defun bg:progress-clear ()
  (setq *BG:PROGRESS:MSG* nil)
  (setq *BG:PROGRESS:MAXLEN* nil)
  (setq *BG:PROGRESS:LPS* nil)
  (setvar "MODEMACRO" (vl-princ-to-string *BG:PROGRESS:OM*))
  ;;;(vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)
  (princ)
  )
(defun bg:progress-init (msg maxlen)
  ;;; msg - message
  ;;; maxlen - max count
  (setq *BG:PROGRESS:OM* (getvar "MODEMACRO"))
  (setq *BG:PROGRESS:MSG* (vl-princ-to-string msg))
  (setq *BG:PROGRESS:MAXLEN* maxlen)
  (setq *BG:PROGRESS:LPS* '-1)(princ)
  )
(defun bg:progress ( currvalue / persent str1 count)
  (if *BG:PROGRESS:MAXLEN*
    (progn
  (setq persent (fix (/ currvalue 0.01 *BG:PROGRESS:MAXLEN*)))
  ;;;Every 5 %
  (setq count (fix(* persent 0.2)))
  (setq str1 "")
  (if (/= count *BG:PROGRESS:LPS*)
    (progn
      ;;(setq str1 "")
      (repeat persent (setq str1 (strcat str1 "|")))
      )
    )
       ;;; currvalue - current value
      (setvar "MODEMACRO"
              (strcat (vl-princ-to-string *BG:PROGRESS:MSG*)
                      " "
                      (itoa persent)
                      " % "
                      str1
                      )
              )
      (setq *BG:PROGRESS:LPS* persent)
  )
    )
  )
(defun bg:layer-status-restore ()
    (foreach item *PD_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 *PD_LAYER_LST* nil)
    ) ;_ end of defun

  (defun bg:layer-status-save ()
    (setq *PD_LAYER_LST* nil)
    (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
      (setq *PD_LAYER_LST* (cons (list item
                                  (cons "freeze" (vla-get-freeze item))
                                  (cons "lock" (vla-get-lock item))
                                  ) ;_ end of cons
                            *PD_LAYER_LST*
                            ) ;_ end of cons
            ) ;_ end of setq
      (vla-put-lock item :vlax-false)
      (if (= (vla-get-freeze item) :vlax-true)
      (vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false))))
      ) ;_ end of vlax-for
    ) ;_ end of defun
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 22.11.2011, 17:52
#19
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 36,760


Я специально не ставил обработку заблокированных и замороженных слоев...
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 18.06.2012, 16:35
#20
A.Hillys


 
Регистрация: 18.06.2012
Сообщений: 8


Отличная программа PFL!
Хотелось бы еще добавить выбор обрабатываемых объектов, это возможно?
A.Hillys вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Нужен Лисп для перевода цвета объекта

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск