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

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

Подкиньте лиспик или подскажите как это сделать.

Ответ
Поиск в этой теме
Непрочитано 15.09.2005, 11:51 #1
Подкиньте лиспик или подскажите как это сделать.
{Smirnoff}
 
Инженер по системам безопасности
 
Рига
Регистрация: 23.11.2003
Сообщений: 1,099

Перекинуть объекты из примерно 200 слоёв в один, но с сохранением внешнего вида примитивов (в смысле и цвета и веса линий как они были по соответствующему слою). Самому времени писать сейчас нет да и на поиск тоже.
Просмотров: 4073
 
Непрочитано 15.09.2005, 12:46
#2
Лентяй

Project Engineer
 
Регистрация: 05.01.2005
Лос Анджелес
Сообщений: 1,150


В первом приближении для цвета и типа линии:
Код:
[Выделить все]
(defun L2L (nlay / lys)
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))
        lys (vla-get-layers adoc))
  (prompt "\nSelect Objects to Transfer")
  (ssget)
  (setq ass (vla-get-ActiveSelectionSet adoc))
  (vlax-for obj ass
    (vlax-for lay lys
      (if (= (vla-get-name lay) (vla-get-layer obj))
        (progn
          (vla-put-color obj (vla-get-ColorIndex (vla-get-TrueColor lay)))
          (vla-put-linetype obj (vla-get-linetype lay))
          (vla-put-layer obj nlay))))
  );vlax-for
);end
Лентяй вне форума  
 
Автор темы   Непрочитано 15.09.2005, 18:23
#3
{Smirnoff}

Инженер по системам безопасности
 
Регистрация: 23.11.2003
Рига
Сообщений: 1,099


>Лентяй
Спасибо что откликнулся. Правда требовалось еще чтобы объекты которые имели свойства не ByLayer их сохраняли а не брали их из свойств слоя. В общем задача чтобы выглядело как было, но на одном слое. Накатал тут по быстрому свой вариант, немного непродуманно но работает:
Код:
[Выделить все]
(defun c:olay(/ actSet actDoc actLay curLay layCol errCount)
  (vl-load-com)
  (if
    (not
      (setq actSet(ssget "_I")))
      (setq actSet(ssget))
    ); end if
  (if actSet
    (progn
    (setq actSet
	   (mapcar 'vlax-ename->vla-object
                    (vl-remove-if 'listp
                     (mapcar 'cadr(ssnamex actSet))))
	  actDoc(vla-get-ActiveDocument
		    (vlax-get-acad-object))
	  layCol(vla-get-Layers actDoc)
	  actLay(vla-get-ActiveLayer actDoc)
	  errCount 0
	  ); end setq
    (vla-StartUndoMark actDoc)
    (foreach ent actSet
       (setq curLay
	   (vla-item layCol(vla-get-Layer ent)))
      (if
	(equal "ByLayer"(vla-get-Linetype ent))
	(if
	  (not
	    (vl-catch-all-error-p
	      (vl-catch-all-apply
	 'vla-put-Linetype (list ent(vla-get-Linetype curLay)))))
	  t); end if
	); end if
      (if
	(equal acLnWtByLayer(vla-get-Lineweight ent))
	(if
	  (not
	    (vl-catch-all-error-p
	      (vl-catch-all-apply
	 'vla-put-Lineweight(list ent(vla-get-Lineweight curLay)))))
	  t); end if
	); end if
      (if
	(equal 256(vla-get-Color ent))
	(if
	  (not
	    (vl-catch-all-error-p
	      (vl-catch-all-apply
	'vla-put-Color (list ent(vla-get-Color curLay)))))
	      t); end if
	); end if
      (if
	(vl-catch-all-error-p
	  (vl-catch-all-apply 'vla-put-Layer
	                         (list ent(vla-get-Name actLay))))
	(setq errCount(1+ errCount))
    ); end if
   ); end foreach
    (if(/= 0 errCount)
      (princ(strcat "\n"(itoa errCount)" were on locked layer!"))
      ); end if
     ); end progn
    (vla-EndUndoMark actDoc)
    ); end if
    (princ)
    ); end of c:olay
Надо бы дописать обработку примитивов в блоках, потому что если у них к примеру толщина линии ByLayer то при переносе в другй слой они будут выглядеть иначе. Ну да ладно, для решения моей задачи меня и это удовлетворяет.
{Smirnoff} вне форума  
 
Непрочитано 16.09.2005, 00:21
#4
Лентяй

Project Engineer
 
Регистрация: 05.01.2005
Лос Анджелес
Сообщений: 1,150


Все выгладит нормально, за исключением (vla-put-color). Не помню, как в пердыдущих версиях, но в 2005 вытаскивание цвета из описания слоя впрямую невозможно за отсутствием свойсва Color. Вместо него существует объект TrueColor, имеющий свойство ColorIndex, соотв-е номеру цвета в Color Palette. Потому вместо (vla-get-Color curLay) сдудует использовать (vla-get-ColorIndex (vla-get-TrueColor curLay)). А в остальном, прекрасная маркиза...
Цитата:
Надо бы дописать обработку примитивов в блоках, потому что если у них к примеру толщина линии ByLayer то при переносе в другй слой они будут выглядеть иначе.
(setq bks (vla-get-Blocks actDoc))
(vlax-for blk bks..., и далее, как уже сказано выше.
Лентяй вне форума  
 
Автор темы   Непрочитано 16.09.2005, 01:14
#5
{Smirnoff}

Инженер по системам безопасности
 
Регистрация: 23.11.2003
Рига
Сообщений: 1,099


Цитата:
но в 2005 вытаскивание цвета из описания слоя впрямую невозможно за отсутствием свойсва Color
Я до сих пор работаю в 2004-м, потому что на работе всё строго лицензионное. А дома особой потребности в следующих версиях нет, потому что как ты понимаешшь у "людей лиспа" есть куча всяких комбинаций на клаве и если не лениво кнопочек которые с лихвой окупают последующие версии. Но изучать их конечно надо, ломаю шефа на апгрейд до 2006-го. Спасибо за ценные замечания.
Цитата:
А в остальном, прекрасная маркиза...
В данном варианте полное "Г" и именно потому что необрабатыват блоки, я кстати это дописал, но оставил на работе. Сейчас запарка, поэтому решил задачу и ладно, не сликом полезный для широкой публики липик. Да притом и опасный, запустил из интереса-непонял что произошло-сохранился-закрылся-при следующем откытии начал рвать волосы на одном месте :shock:
{Smirnoff} вне форума  
 
Непрочитано 16.09.2005, 02:50
#6
Лентяй

Project Engineer
 
Регистрация: 05.01.2005
Лос Анджелес
Сообщений: 1,150


Я тоже не помню каких-либо проблем с (vla-get-color *LAYER*) в 2000-2002. Более того, не понимаю этого извращения с TrueColor ваще.
Цитата:
...начал рвать волосы на одном месте
А какой программой ты для этого пользовался? Или обошелся аппарвтными средствами? Paldies.
Лентяй вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Подкиньте лиспик или подскажите как это сделать.

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

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