Новая задачка для ЛИСП умельцев

Новая задачка для ЛИСП умельцев · 06.08.2005, 19:23

Коллеги!!!
Предлагаю немного разьмяться и соорудить небольшой ЛИСПик, способный облегчить жизнь инженеру. Требуется прога, способная проставлять значения из переменной "меаsurement"размера в "text override" этого же размера. Другими словами - есть прочерченная деталь в масштабе 1:1 с нанесенными на нее размерами, такая картинка никак не тянет на чертеж КМД, ее нужно немного поджать и растянуть местами, и как правило многие размеры забываешь "перебить" и они начинают "уменьшаться". Хотелось бы все выделить и дальше смело править чертеж, не боясь что где то на изделии появяться глупые размеры. Жду ваших предложений.

Лентяй · 07.08.2005, 01:36

Г-н Gostushev,
Сегодня я не ленив. но добр. А посему - ловите лсипу, пользуйтесе на здровье и сугубо и трегубо благодарите меня за то. что я есть.

Код:

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

(defun C:mes2txt ( / ass flag)
  (prompt "\nВыберите размеры для перезаписи")
  (ssget)
  (setq ass (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object))))
  (vlax-for dmob ass
    (if (wcmatch (vla-get-ObjectName dmob) "*Dimension")
      (progn (vla-put-TextOverride dmob (rtos (vla-get-measurement dmob)))
	(setq flag 1))));vlax-for
  (if (null flag) (alert "Не то выбралб дубина! Будь внимательнее!"))
);end

{Smirnoff} · 07.08.2005, 02:37

>Лентяй

1. А как же значки радиусов и диаметров?
2. А как же количество десятичных знаков которое для размеров устанавливается отдельно?
3. А если слой случайно заблокирован, то выскочит непонятная для пользователя ошибка и что уже "надписано" а что нет совершенно непонятно.

>Gostushev
Должен переписывать размеры "как есть". Я подумал что нелишне такие размеры временно метить и они красятся в цвет №22 (если конечно в определении стиля цвета ByBlock). Чтобы убрать покраску, сотрите строчку (vla-put-Color dim 22).

Код:

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

(defun c:dimr(/ COPYDIM CURLAY DELSET DIMLST
	      DIMSET ERRCOUNT LAYCOL LENT
	      NEXTENT OVTEXT *ERROR* ACTDOC
	      OLDECHO)

  (defun *ERROR* (msg)
    (setvar "CMDECHO" oldEcho)
    ); end of error

  (vl-load-com)
  (setq oldEcho(getvar "CMDECHO")
	actDoc(vla-get-ActiveDocument
		      (vlax-get-acad-object))
	layCol(vla-get-Layers actDoc)
	); end setq
  (setvar "CMDECHO" 0)
  (if
    (setq dimSet
	   (ssget '((0 . "DIMENSION"))))
    (progn
      (setq dimLst
	     (mapcar 'vlax-ename->vla-object 
                    (vl-remove-if 'listp 
                     (mapcar 'cadr(ssnamex dimSet))))
	    errCount 0
	    ); end setq
      (vla-StartUndoMark actDoc)
      (foreach dim dimLst
	(setq curLay(vla-get-Layer dim))
	(if
	  (/= :vlax-true
	      (vla-get-Lock(Col_Item_Find layCol curLay)))
	  (progn
	(setq lEnt(entlast)
	      delSet(ssadd)
	      copyDim(vla-Copy dim)
	      ); end setq
	(command "_.Explode"(entlast))
	 (setq nextEnt(entnext lEnt))
	(while nextEnt
	  (ssadd nextEnt delSet)
	  (if
	    (member
	      (cdr(assoc 0(entget nextEnt)))
	      '("TEXT" "MTEXT")); end member
	    (setq ovText
		   (cdr(assoc 1(entget nextEnt))))
	    ); end if
	  (command "_.erase" nextEnt "")
	  (setq nextEnt(entnext nextEnt))
	    ); end whlie
	(vla-put-TextOverride dim ovText)
	(vla-put-Color dim 22)
	); end progn
	  (setq errCount(1+ errCount))
	  ); end if
	); end foreach
      (if(/= 0 errCount)
	(princ
	  (strcat "\n"
		  (itoa errCount)" were on locked layer!"))
	); end if
      (vla-EndUndoMark actDoc)
      ); end progn
    ); end if
  (setvar "CMDECHO" oldEcho)
  (princ)
  ); end of c:dimr

(defun Col_Item_Find (Collection Item / result)
  (if
    (not
      (vl-catch-all-error-p  
	(setq result
	       (vl-catch-all-apply 'vla-item
		 (list Collection Item))))) 
    result
    ); end if
  ); end of Col_Item_Find

Лентяй · 07.08.2005, 11:17

Цитата:

Лентяй
1. А как же значки радиусов и диаметров?
2. А как же количество десятичных знаков которое для размеров устанавливается отдельно?
3. А если слой случайно заблокирован, то выскочит непонятная для пользователя ошибка и что уже "надписано" а что нет совершенно непонятно.

Послушайте, Фантомас, вам кто-нибудь говорил, что вы - зануда? :shock: Ладно, так и быть - вот вам апдэйтнутая лиспа, ибо добр аз есмь днесь.

Код:

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

(defun C:mes2txt ( / ass flag pfx) 
  (prompt "\nВыберите размеры для перезаписи") 
  (ssget) 
  (setq ass (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object))))
  (vlax-for dmob ass 
    (if (wcmatch (vla-get-ObjectName dmob) "*Dimension")
      (progn
	(if (= (vla-get-ObjectName dmob) "AcDb2LineAngularDimension")
	  (vla-put-TextOverride dmob (strcat (rtos (/ (* (vla-get-measurement dmob) 180) pi)
		2 (vla-get-TextPrecision dmob)) "%%D"))
	  (progn (cond ((= (vla-get-ObjectName dmob) "AcDbRadialDimension") (setq pfx "R"))
	      ((= (vla-get-ObjectName dmob) "AcDbRotatedDimension") (setq pfx ""))
	      ((= (vla-get-ObjectName dmob) "AcDbDiametricDimension") (setq pfx "%%C")))
	    (vla-put-TextOverride dmob (strcat pfx (rtos (vla-get-measurement dmob)
		(vla-get-UnitsFormat dmob) (vla-get-PrimaryUnitsPrecision dmob)))));progn
	);if
	(setq flag 1))));vlax-for
  (if (null flag) (alert "Не то выбрал, дубина! Будь внимательнее!")) 
);end

Все равно короче. чем у вас.

Да, а заморозками-отморозками - вожжайтесь сами, ибо мне - ЛЕНИВО!

{Smirnoff} · 07.08.2005, 12:16

>Лентяй

Цитата:

Послушайте, Фантомас, вам кто-нибудь говорил, что вы - зануда?

Говорили и не раз. Но у всех свои недостатки. Вы как ни кто меня поймете

Цитата:

Все равно короче. чем у вас. Laughing
Да, а заморозками-отморозками - вожжайтесь сами, ибо мне - ЛЕНИВО! Very Happy

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

Я просто избрал другой "железобетонный", хотя и не элегантный способ забирания текста "как есть" из взорванной копии размера.

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

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

Код:

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

; error: Automation Error. Calling method Clear of interface IAcadSelectionSet

Лентяй · 07.08.2005, 23:33

Цитата:

Говорили и не раз. Но у всех свои недостатки. Вы как ни кто меня поймете

Wanna hug?

Цитата:

Однако тоже неучитывает многих вещей. Например наличие префиксов и суффиксов, альтернативных единий и т. д. и т. п.

Альтернативные единицы в расейском КМД? Пардоньте-с, но это уже не занудство, но просто - извращение. Такова же извратна есть и проверка на кол-во дечятичных знаков, ибо все размеры - сугубо в мм, что есть целочисленны.

Цитата:

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

А это уже у вас компьютер - занудный :shock: Под стать хозяину, наверное

А ежели серьезно, то я полагал, что внесение ass в список параметров автоматически очищает соответствующую запись при завершении прогораммы. Видимо, надежнее добавить строку

Код:

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

(vla-release ass)

С занудским приветом!

Gostushev · 07.08.2005, 23:49

Всем спасибо. Буду тестировать и выказывать недовольство как настоящий заказчик :-). Вы мило друзья общаетесь :-). Всем еще раз спасибо и до новых вам встречь на поле размышлений.

{Smirnoff} · 08.08.2005, 02:39

Разозлил я тебя :?:

Цитата:

Wanna hug?

You think it is time to hug? I not against.

Цитата:

Альтернативные единицы в расейском КМД? Пардоньте-с, но это уже не занудство, но просто - извращение. Такова же извратна есть и проверка на кол-во дечятичных знаков, ибо все размеры - сугубо в мм, что есть целочисленны.

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

Цитата:

(vla-release ass)

Смешно. Очень даже с юмором, учитывая название переменной и суть функции. Только наверное всё таки:

Код:

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

(vlax-release-object ass)

Ну да ладно. Не буду тебя больше доставать. Тем более что самому далеко до совершенства. Я ж не ShaggyDoc чтобы лекции читать.

С занудским приветом Фантомас

serg01 · 26.04.2006, 11:02

а есть такой лисп:
При выделении толпы размеров чтоб значения text override сплюсовались и отобразились в новом размере?

Кулик Алексей aka kpblc · 26.04.2006, 11:15

А если textoverride нет?

Krieger · 26.04.2006, 11:30

to {Smirnoff}
А можно добавить чтоб все размеры, где нет "<>" закрашивались в определенный цвет. Есть чертежи где уже давно размеры перебиты, а также я могу и без проги что-то написать. Надо покрасить.

serg01 · 26.04.2006, 11:41

>>kpblc
вообще все размеры забиты вручную. Но если проскочит размер без override, желательно чтоб он подсветился и НЕ посчитался.
ЗЫ. Подсветка должна сработать не зависимо от размерного стиля (даже если в нем стоит другой цвет).
о как!

Хмурый · 26.04.2006, 11:45

Программа есть Findhanddim.vlx называется от Рипс Э. И erips@yahoo.com Пользуюсь ею.

Скачать можно здесь

http://helpstud.org/load/acad/findhanddim.zip

Кулик Алексей aka kpblc · 26.04.2006, 11:54

> Krieger : Попробуй такое:

Код:

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

;|=============================================================================
*    проверка размеров на правильность проставления. Вручную проставленные
* размеры меняют цвет на 1, вес линии на 2.11 мм. Переназначения текста не
* выполняется
=============================================================================|;
(defun c:kpblc-dimcheck (/ *kpblc-activedoc* selset item temp_text)
  (vl-load-com)
  (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark *kpblc-activedoc*)
  (setq selset (ssget '((0 . "DIMENSION"))))
  (while (and selset
	      (> (sslength selset) 0)
	      (setq item (ssname selset 0))
	      (ssdel item selset)
	      ) ;_ end of and
    (setq item (vlax-ename->vla-object item))
    (if	(and (/= (vla-get-textoverride item) "")
	     (/= (vla-get-textoverride item) "<>")
	     ) ;_ end of and
      (progn
	(vla-put-color item 1)		; цвет - красный
	(vla-put-lineweight item 211)	; вес линии - 2.11
	(setq temp_text (vla-get-textoverride item))
	) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of while
  (vla-endundomark *kpblc-activedoc*)
  (princ)
  ) ;_ end of defun

asys · 26.04.2006, 11:58

руки бы по самые яйца таким людям поотрывал бы, которые размеры ручками вписывают. :evil: :evil: :evil: Потом концов в проекте не найдешь, откуда лишние метры вылезли. :evil: :evil: :evil:

serg01 · 26.04.2006, 12:04

>>Asys
ты по делу бы лучше чего сказал....

Хмурый · 26.04.2006, 12:06

Цитата:

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

руки бы по самые яйца таким людям поотрывал бы, которые размеры ручками вписывают. :evil: :evil: :evil: Потом концов в проекте не найдешь, откуда лишние метры вылезли. :evil: :evil: :evil:

Не забывайте, что есть механики. Чертежи длинномерных деталей выполняются с линиями разрыва. Приходится проставлять размеры вручную...

asys · 26.04.2006, 12:06

Цитата:

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

>>Asys
ты по делу бы лучше чего сказал....

по делу ? :arrow: не фиг руками размеры вписывать !!!! Надо чертить ровно !!!!!!!!!

Krieger · 26.04.2006, 12:11

to kpblc
Спасибо, все нормально, только еще два пожелания (если можно):
1. После ввода команды - чтоб не выбирать ничего, а применить сразу ко всем размерам.
2. Если такая запись: "9x<>=6750" то выделять не надо.

serg01 · 26.04.2006, 12:15

Цитата:

по делу ? Arrow не фиг руками размеры вписывать !!!! Надо чертить ровно !!!!!!!!!

тут модерируется вообще нет? Банить надо всяких шипко умных!

Кулик Алексей aka kpblc · 26.04.2006, 12:32

Цитата:

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

<...>
1. После ввода команды - чтоб не выбирать ничего, а применить сразу ко всем размерам.
2. Если такая запись: "9x<>=6750" то выделять не надо.

Лови

Код:

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

;|=============================================================================
*    проверка размеров на правильность проставления. Вручную проставленные
* размеры меняют цвет на 1, вес линии на 2.11 мм. Переназначения текста не
* выполняется
=============================================================================|;
(defun c:kpblc-dimcheck	(/ *kpblc-activedoc* selset item temp_text)
  (vl-load-com)
  (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark *kpblc-activedoc*)
  (setq selset (ssget "_X" '((0 . "DIMENSION"))))
  (while (and selset
	      (> (sslength selset) 0)
	      (setq item (ssname selset 0))
	      (ssdel item selset)
	      ) ;_ end of and
    (setq item (vlax-ename->vla-object item))
    (if	(and (/= (vla-get-textoverride item) "")
	     (not (wcmatch (vla-get-textoverride item) "*<>*"))
	     ) ;_ end of and
      (progn
	(vla-put-color item 1)		; цвет - красный
	(vla-put-lineweight item 211)	; вес линии - 2.11
	(setq temp_text (vla-get-textoverride item))
	) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of while
  (vla-endundomark *kpblc-activedoc*)
  (princ)
  ) ;_ end of defun

Кулик Алексей aka kpblc · 26.04.2006, 12:36

Цитата:

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

>>kpblc
вообще все размеры забиты вручную. Но если проскочит размер без override, желательно чтоб он подсветился и НЕ посчитался.
ЗЫ. Подсветка должна сработать не зависимо от размерного стиля (даже если в нем стоит другой цвет).
о как!

То бишь "подсветился" - это сменил цвет? Или выделение для него просто установить (как типа "выбран")? И опять же - textoverride может быть разным. Что делать, например, если вколочено "А вот здесь сердечник деревянный"? То есть не цифры? Или вбито "123,4565465,65"?

serg01 · 26.04.2006, 12:47

Цитата:

То бишь "подсветился" - это сменил цвет? Или выделение для него просто установить (как типа "выбран")? И опять же - textoverride может быть разным. Что делать, например, если вколочено "А вот здесь сердечник деревянный"? То есть не цифры? Или вбито "123,4565465,65"?

Да, подсветился значит сменить цвет. Если текст или числа не целые, то впринципе их можно упустить совсем и не обрабатывать вообще (просто нет таких). Но если не лень то на всякий случай можно и их цветом выделить.

forMA · 26.04.2006, 12:48

для {Smirnoff}
---------------------
Отлично. Только хотел в свою очередь развести занудство по поводу допусков. Однако, все работает

Хорошая работа!

Кулик Алексей aka kpblc · 26.04.2006, 13:01

Цитата:

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

Да, подсветился значит сменить цвет. Если текст или числа не целые, то впринципе их можно упустить совсем и не обрабатывать вообще (просто нет таких). Но если не лень то на всякий случай можно и их цветом выделить.

Тогда попробуй:

Код:

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

;|=============================================================================
*    проверка размеров на правильность проставления. Вручную проставленные
* размеры меняют цвет на 1, вес линии на 2.11 мм. Переназначения текста не
* выполняется
=============================================================================|;
(defun c:kpblc-dimsumm (/ *kpblc-activedoc* selset item tmp_sum)

  (vl-load-com)
  (setq	*kpblc-activedoc*
	 (vla-get-activedocument (vlax-get-acad-object))
	tmp_sum	0.0
	) ;_ end of setq
  (vla-startundomark *kpblc-activedoc*)
  (setq selset (ssget "_X" '((0 . "DIMENSION"))))
  (while (and selset
	      (> (sslength selset) 0)
	      (setq item (ssname selset 0))
	      (ssdel item selset)
	      ) ;_ end of and
    (setq item (vlax-ename->vla-object item))
    (if	(and (/= (vla-get-textoverride item) "")
	     (not (wcmatch (vla-get-textoverride item) "*<>*"))
	     ) ;_ end of and
      (progn
	(setq tmp_sum
	       (+ tmp_sum
		  (cond
		    ((vl-string-search "=" (vla-get-textoverride item))
		     (atof
		       (vl-string-subst
			 "."
			 ","
			 (substr
			   (+ 2
			      (vl-string-search "=" (vla-get-textoverride item))
			      ) ;_ end of +
			   ) ;_ end of substr
			 ) ;_ end of vl-string-subst
		       ) ;_ end of atof
		     )
		    (t
		     (atof (vl-string-subst "." "," (vla-get-textoverride item)))
		     )
		    ) ;_ end of cond
		  ) ;_ end of +
	      ) ;_ end of setq
	) ;_ end of progn
      (progn
	(vla-put-color item 1)		; цвет - красный
	(vla-put-lineweight item 211)	; вес линии - 2.11
	) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of while
  (princ tmp_sum)
  (vla-endundomark *kpblc-activedoc*)
  (princ)
  ) ;_ end of defun

Код на работоспособность не проверял, так что если не работает либо работает неправильно - скажи, буду дальше ковырять

v_alex · 26.04.2006, 13:21

Цитата:

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

по делу ? :arrow: не фиг руками размеры вписывать !!!! Надо чертить ровно !!!!!!!!!

к сожалению невсегда возможно чертить ровно... это довольно частое явление в КМД, когда деталь рисуют по высоте в нормальном масштабе, а по длине нет... или вообще рисуют одну деталь, а к ней куча размеров...

asys · 26.04.2006, 13:35

у меня это одна из больных тем

(после черчения в масштабах конечно)

serg01 · 26.04.2006, 15:52

>>kpblc
в целом код, работает, но:
1. он считает все размеры какие есть на чертеже;
2. если вбит размер с текстом он тоже считается;
3. нет возможности выбора считаемых размеров;
4. не отмечается ничего цветом и толщина не меняется;
5. и вначале я просил, чтоб посчитанная цифра вылевалась в новый размер, т.е. отметил несколько размеров, они посчитались, все что "не то" отметилось цветом (об этой
возможности мы говорили, можно ее не делать

) и вылезло бы приглашение об указании 2-х точек нового размера.

В коде для Krieger меняется и цвет и толщина.

Заранее спасибо!

Кулик Алексей aka kpblc · 26.04.2006, 16:17

> serg01 : Давай тогда еще раз ТЗ с самого начала и для тупого. Я уже не могу сегодня нормальный код написать, это факт. Только если завтра.

Елпанов Евгений · 26.04.2006, 16:49

Цитата:

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

>>kpblc
в целом код, работает, но:
1. он считает все размеры какие есть на чертеже;
2. если вбит размер с текстом он тоже считается;
3. нет возможности выбора считаемых размеров;
4. не отмечается ничего цветом и толщина не меняется;
5. и вначале я просил, чтоб посчитанная цифра вылевалась в новый размер, т.е. отметил несколько размеров, они посчитались, все что "не то" отметилось цветом (об этой
возможности мы говорили, можно ее не делать

) и вылезло бы приглашение об указании 2-х точек нового размера.

В коде для Krieger меняется и цвет и толщина.

Заранее спасибо!

Может моя, когда-то, наспех собраная программа подойдет?

Код:

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

(defun d-orig ()
  (if (setq ss (ssget
		 "_X"
		 '((0 . "DIMENSION")
		   (1 . "~*<>*")
		  )
	       ) ;_  ssget
      ) ;_  setq
    (foreach x (vl-remove-if
		 (function listp)
		 (mapcar
		   (function cadr)
		   (ssnamex ss)
		 ) ;_  mapcar
	       ) ;_  vl-remove-if
      (setq en (entget x))
      (entmod
	(subst
	  (cons
	    1
	    (strcat (cdr (assoc 1 en))
		    "{\\C1; (Original: <>) }"
	    ) ;_  strcat
	  ) ;_  cons
	  (assoc 1 en)
	  en
	) ;_  subst
      ) ;_  entmod
      (entupd x)
    ) ;_  foreach
  ) ;_  if
) ;_  defun

Вроде и цвет меняется и старые обозначения сохраняются...
Делалось, чтоб тыкать носом

serg01 · 26.04.2006, 17:04

>>kpblc
Хорошо. Давай заново.
Имеем размеры, которые проставлены вручную. Чтоб на калькуляторе всю цепочку не подсчитывать нужно выделить эти размеры, ввести команду и результатом должно явиться следующее:
1. Все то, что присутствует в поле text override в виде целых чисел (кроме текста, символов, текта+цифры, цифры не целые) посчиталось. Все, что кроме целых чисел должно выделиться красным цветом и в расчетах учавствовать не должно.
2. Следом после этого должно высвятиться приглашение на ввод 2-х точек начала и конца будующего линейного размера, а посчитанный результат должен будет записаться в поле text override этого размера.
Надеюсь теперь понятно объяснил.

serg01 · 03.05.2006, 10:43

так яро все начиналось...

Кулик Алексей aka kpblc · 03.05.2006, 11:24

Ну закрутился по работе, бывает, извини. Пробуй:

Код:

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

(defun c:dimcheck (/ adoc selset item sum ent_dim)
  (vl-load-com)
  (setq	adoc (vla-get-activedocument (vlax-get-acad-object))
	sum  0.
	) ;_ end of setq
  (vla-startundomark adoc)
  (if (not (setq selset (ssget "_I" '((0 . "DIMENSION")))))
    (setq selset (ssget '((0 . "DIMENSION"))))
    ) ;_ end of if
  (while (and selset
	      (> (sslength selset) 0)
	      ) ;_ end of and
    (setq item (ssname selset 0))
    (ssdel item selset)
    (setq item (vlax-ename->vla-object item))
    (if	(and (not (member (vla-get-textoverride item) '("" "<>")))
	     (not (vl-string-search
		    "."
		    (vl-string-subst "." "," (vla-get-textoverride item))
		    ) ;_ end of VL-STRING-SEARCH
		  ) ;_ end of not
	     (/= 0 (atoi (vla-get-textoverride item)))
	     ) ;_ end of and
      (setq sum (+ sum (atoi (vla-get-textoverride item))))
      (vla-put-color item 1)
      ) ;_ end of if
    ) ;_ end of while
  (if (vl-cmdf "_.dimlinear" pause pause pause)
    (progn
      (setq ent_dim (vlax-ename->vla-object (entlast)))
      (vla-put-textoverride ent_dim (rtos sum 2))
      ) ;_ end of progn
    ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

serg01 · 03.05.2006, 11:38

Слушай, ну ты молодец просто! Теперь рутины поменьше! Спасибо!!!

Кулик Алексей aka kpblc · 03.05.2006, 11:49

Работает как надо?

serg01 · 03.05.2006, 12:06

ну почти как надо

Считает все, что забито вручную, включая цифры с текстом. Если стоит цифра впереди текста, то он ее считает, если текст впереди цифры, то не считает. Ну и выделения цветом я понял, что тут нет.
Но этот вариант вполне устраивает!

Кулик Алексей aka kpblc · 03.05.2006, 12:22

Цитата:

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

ну почти как надо

Считает все, что забито вручную, включая цифры с текстом. Если стоит цифра впереди текста, то он ее считает, если текст впереди цифры, то не считает. Ну и выделения цветом я понял, что тут нет.
Но этот вариант вполне устраивает!

Вот насчет цифр перед текстом - это да, тут я промахнулся. Не предусмотрел такого варианта. А цветом выделяло у меня. Можешь приложить вариант "чего есть и чего должно быть"? Именно dwg-файл (ессно, интересует только кусок с размерами)?
Вполне может оказаться, что у тебя в настройках размерного стиля стоит цвет не ByBlock, а ByLayer или какой-то предопределенный. Тогда работать, конечно, не будет.

serg01 · 03.05.2006, 12:39

Цвет стоит в стиле определенного цвета, это да. Удобно это. Поменял на byblock и естественно заработало. А нельзя сделать так, чтоб цвет менялся даже в случае установки его в размерном стиле жестко за определенным цветом ?

ЗЫ. лиспины, ранее проскакивавшие это делали, но функционал у них был не тот.

Кулик Алексей aka kpblc · 03.05.2006, 13:02

В общем несколько вариантов:
1. Меняет цвет внутри размеров на красный (установленный в переменной color)

Код:

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

(defun c:dimcheck (/ adoc selset item sum ent_dim color)
  (vl-load-com)
  (setq	adoc  (vla-get-activedocument (vlax-get-acad-object))
	sum   0.
	color 1
	      ;; Номер цвета для назначения
	) ;_ end of setq
  (vla-startundomark adoc)
  (if (not (setq selset (ssget "_I" '((0 . "DIMENSION")))))
    (setq selset (ssget '((0 . "DIMENSION"))))
    ) ;_ end of if
  (while (and selset
	      (> (sslength selset) 0)
	      ) ;_ end of and
    (setq item (ssname selset 0))
    (ssdel item selset)
    (setq item (vlax-ename->vla-object item))
    (if	(and (not (member (vla-get-textoverride item) '("" "<>")))
	     (not (vl-string-search
		    "."
		    (vl-string-subst "." "," (vla-get-textoverride item))
		    ) ;_ end of VL-STRING-SEARCH
		  ) ;_ end of not
	     (/= 0 (atoi (vla-get-textoverride item)))
	     (=	(strlen (itoa (atoi (vla-get-textoverride item))))
		(strlen (vla-get-textoverride item))
		) ;_ end of =
	     ) ;_ end of and
      (setq sum (+ sum (atoi (vla-get-textoverride item))))
      (foreach sub_item
	       '("color" "extensionlinecolor" "textcolor" "DimensionLineColor")
	(vlax-put-property item sub_item color)
	) ;_ end of foreach
      ) ;_ end of if
    ) ;_ end of while
  (if (vl-cmdf "_.dimlinear" pause pause pause)
    (progn
      (setq ent_dim (vlax-ename->vla-object (entlast)))
      (vla-put-textoverride ent_dim (rtos sum 2))
      ) ;_ end of progn
    ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

2. Все то же, но меняет цвет внутри размера на ByBlock, а сам размер -- на красный:

Код:

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

(defun c:dimcheck (/ adoc selset item sum ent_dim color)
  (vl-load-com)
  (setq	adoc  (vla-get-activedocument (vlax-get-acad-object))
	sum   0.
	color 1
	      ;; Номер цвета для назначения
	) ;_ end of setq
  (vla-startundomark adoc)
  (if (not (setq selset (ssget "_I" '((0 . "DIMENSION")))))
    (setq selset (ssget '((0 . "DIMENSION"))))
    ) ;_ end of if
  (while (and selset
	      (> (sslength selset) 0)
	      ) ;_ end of and
    (setq item (ssname selset 0))
    (ssdel item selset)
    (setq item (vlax-ename->vla-object item))
    (if	(and (not (member (vla-get-textoverride item) '("" "<>")))
	     (not (vl-string-search
		    "."
		    (vl-string-subst "." "," (vla-get-textoverride item))
		    ) ;_ end of VL-STRING-SEARCH
		  ) ;_ end of not
	     (/= 0 (atoi (vla-get-textoverride item)))
	     (=	(strlen (itoa (atoi (vla-get-textoverride item))))
		(strlen (vla-get-textoverride item))
		) ;_ end of =
	     ) ;_ end of and
      (setq sum (+ sum (atoi (vla-get-textoverride item))))
      (progn
	(foreach sub_item
		 '("extensionlinecolor" "textcolor" "DimensionLineColor")
	  (vlax-put-property item sub_item 0)
	  ) ;_ end of foreach
	(vla-put-color item color)
	) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of while
  (if (vl-cmdf "_.dimlinear" pause pause pause)
    (progn
      (setq ent_dim (vlax-ename->vla-object (entlast)))
      (vla-put-textoverride ent_dim (rtos sum 2))
      ) ;_ end of progn
    ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

Если Евгений Елпанов подключится, получится в 2 раза короче и в 4 - быстрее

serg01 · 04.05.2006, 03:51

Работает и тот и другой! Спасибо!

Кулик Алексей aka kpblc · 04.05.2006, 08:03

Ну то, что работает, понятно. Дело в том, что "унутренности" изменивших цвет размеров разные - посмотри ради интересу на них в части цветов текста, выносных и размерных линий.

gest · 02.04.2008, 12:44

Кулик Алексей aka kpblc, не подскажешь, для первого варианта

Цитата:

Команда: dimcheck

Выберите объекты: Противоположный угол: найдено: 1

Выберите объекты:
_.dimlinear
Начало первой выносной линии или <выбрать объект>:
Начало второй выносной линии:
Создан неассоциативный размер.
Положение размерной линии или
[Мтекст/Текст/Угол/Горизонтальный/Вертикальный/Повернутый]:
Размерный текст = 24595
Команда:

То есть надо перемеривать размер?

zenon · 25.02.2009, 11:00

подниму эту тему, ибо нужно немного модифицировать лисп.
1 - при любом изменении вручную размеров в поле текста, нужно просто подчеркнуть текст и все больше никаких телодвижений.

4eh · 11.04.2010, 08:15

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

Andrey.K · 26.10.2010, 17:03

Помогите пожалуйста с решением проблемы. Здешние программы посмотрел, но они почему то не все размеры окрашивают - с чем связано - непонятно.
Задача у меня такая. Есть чертеж с кучей размеров, начерченный в масштабе M. Среди них есть размеры нормальные, размеры, вбитые в ручную (не содержат <>), и размеры чей масштаб не соответствует масштабу М. Нужна программа, которая окрасит нормальные размеры в зеленый цвет, не соответствующие масштабу - в красный, вбитые в ручную - оставит как есть.
Работа программы.
Вводим команду, выделяем мышкой область чертежа, при этом выделяются только размеры: линейные, круговые, угловые. Enter.
Размеры, содержащие "<>" стали зеленые, размеры, чей масштаб не соответствует текущей переменной Dimlfac стали красные, остальные - остались без изменений.
Спасибо, если кто поможет.

ALFMario · 30.11.2010, 20:05

+1 Программа не окрашивает значение текста размера в другой цвет.
Меняеться цвет примитива, и только в окне цвета, сам примитив остаеться чёрным.
Как сделать так что бы менялся цвет текста размера.

Кулик Алексей aka kpblc · 30.11.2010, 21:19

Цитата:

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

Как сделать так что бы менялся цвет текста размера.

Настроить размерный стиль: все примитивы размера должны располагаться на слое "0" и иметь свойства "ByBlock" ("ПоБлоку").

ALFMario · 01.12.2010, 10:22

Спасибо.
Но достаточно сделать в настройках стиля размера цвет текста по блоку.

seregabs · 16.10.2013, 11:18

Добрый день. Извините, что поднимаю.
Есть вопрос по лиспам из постов #3 и #4.
Оба работают.
Но есть еще такое пожелание, чтобы заменяющий текст выделялся цветом (т.е. не весь размер как в одном из лиспов уже сделано, а только текст), например, красным, И был подчеркнутым.

Krieger · 16.12.2013, 11:49

Цитата:

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

Добрый день. Извините, что поднимаю.
Есть вопрос по лиспам из постов #3 и #4.
Оба работают.
Но есть еще такое пожелание, чтобы заменяющий текст выделялся цветом (т.е. не весь размер как в одном из лиспов уже сделано, а только текст), например, красным, И был подчеркнутым.

Код:

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

(defun c:dimr(/ COPYDIM CURLAY DELSET DIMLST
	      DIMSET ERRCOUNT LAYCOL LENT
	      NEXTENT OVTEXT *ERROR* ACTDOC
	      OLDECHO)

  (defun *ERROR* (msg)
    (setvar "CMDECHO" oldEcho)
    ); end of error

  (vl-load-com)
  (setq oldEcho(getvar "CMDECHO")
	actDoc(vla-get-ActiveDocument
		      (vlax-get-acad-object))
	layCol(vla-get-Layers actDoc)
	); end setq
  (setvar "CMDECHO" 0)
  (if
    (setq dimSet
	   (ssget '((0 . "DIMENSION"))))
    (progn
      (setq dimLst
	     (mapcar 'vlax-ename->vla-object 
                    (vl-remove-if 'listp 
                     (mapcar 'cadr(ssnamex dimSet))))
	    errCount 0
	    ); end setq
      (vla-StartUndoMark actDoc)
      (foreach dim dimLst
	(setq curLay(vla-get-Layer dim))
	(if
	  (/= :vlax-true
	      (vla-get-Lock(Col_Item_Find layCol curLay)))
	  (progn
	(setq lEnt(entlast)
	      delSet(ssadd)
	      copyDim(vla-Copy dim)
	      ); end setq
	(command "_.Explode"(entlast))
	 (setq nextEnt(entnext lEnt))
	(while nextEnt
	  (ssadd nextEnt delSet)
	  (if
	    (member
	      (cdr(assoc 0(entget nextEnt)))
	      '("TEXT" "MTEXT")); end member
	    (setq ovText
		   (cdr(assoc 1(entget nextEnt))))
	    ); end if
	  (command "_.erase" nextEnt "")
	  (setq nextEnt(entnext nextEnt))
	    ); end whlie
	(vla-put-TextOverride dim (strcat "%%u" ovText))
	;(vla-put-Color dim 22)
	(vla-put-TextColor dim 6)
	); end progn
	  (setq errCount(1+ errCount))
	  ); end if
	); end foreach
      (if(/= 0 errCount)
	(princ
	  (strcat "\n"
		  (itoa errCount)" were on locked layer!"))
	); end if
      (vla-EndUndoMark actDoc)
      ); end progn
    ); end if
  (setvar "CMDECHO" oldEcho)
  (princ)
  ); end of c:dimr

(defun Col_Item_Find (Collection Item / result)
  (if
    (not
      (vl-catch-all-error-p  
	(setq result
	       (vl-catch-all-apply 'vla-item
		 (list Collection Item))))) 
    result
    ); end if
  ); end of Col_Item_Find

extraneous · 10.02.2014, 10:41

Подниму тему.
Есть файл с кучей перебитых размеров. Они прекрасно находятся через qselect.
Но есть "1292" перебитый на "1300" (кто-то не умеет пользоваться округлением, да), и "2300" перебитый на "3000". Нужно выделить размеры, в которых реальное значение отличается от "перебитого" больше, чем на некоторое значение.
Может быть, такое уже делали, но не нашел. Если есть - ткните носом.
Думаю такая программа будет полезна не только мне в борьбе с "веселыми картинками".

Дима_ · 10.02.2014, 13:29

Как-то так

Код:

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

 (vl-load-com)
(defun digitextract (str / lstdgt digit char i) ;; нарыл в закромах - может и сам написал
  (setq i 1 digit "")
  (repeat (strlen str)
          (setq char (substr str i 1))
          (if 	(and (>= char "0") (<= char "9"))
                (setq digit (strcat digit char))
                (if (or (= char ".") (= char ","))
                    (setq digit (strcat digit "."))
                    (if (= digit ".") (setq digit "") 
                        (if (/= digit "") (setq lstdgt (append lstdgt (list (atof digit))) digit ""))
                        )));end of if*3
          (setq i (1+ i))
          );end of repeat
  (if (and (/= digit ".") (/= digit "")) (setq lstdgt (append lstdgt (list (atof digit)))))
  lstdgt);end of digitextract
(defun test(x)
  ((lambda (ss) 
     (foreach ent 
              (vl-remove-if '(lambda (ent)
                               (or (listp ent)
                                   ((lambda (lst)
                                      ((lambda (dgt)
                                         (or (not dgt)
                                             (<= (abs (- (cdr (assoc 42 lst))
                                                         (car dgt)))
                                                 x)))
                                       (digitextract (cdr (assoc 1 lst)))))
                                    (entget ent))))
                            (mapcar 'cadr (ssnamex (ssget '((0 . "DIMENSION"))))))
              (ssadd ent ss))
     (sssetfirst nil ss)
     (princ))
   (ssadd)))

запускать (test xx) ; где хх - допустимый "разбег"

extraneous · 10.02.2014, 14:18

Дима_, огромное спасибо! Когда будут взвешивать грехи - смело сообщайте, что этот код спас кучу людей от нудного труда

v.psk · 17.07.2017, 17:21

Похожая задача.
Подскажите пожалуйста, есть ли готовое решение для цепочек размеров:
- хотелось бы чтобы в выбранной группе размеров содержимое перебивалось по условию, например:
для значения 1000 перебивалось на "2х500=<>"
для 1500 "3х500=<>"
для 2000 "4х500=<>"
для 2500 "5х500=<>"
... ну и так далее, пускай даже эти условия будут в теле макроса или лиспа, а при необходимости их надо будет там изменить.
Спасибо.

VVA · 17.07.2017, 18:51

v.psk, Как-то так в первом приближении
Размеры должны быть не перебитые, а вычисленные

Код:

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

(defun c:DIM= (/ *kpblc-activedoc* ss item rzm count kr)
;;;Команда проставляет в выбранных размерах запрошенную кратность (по умолчанию 500)
;;; Размер должен быть не перебит и кратен кратности500
;;; Если размер кратен 500, то вставляется текст kx500=<>, где
;;; k - посчитанная кратность
  (vl-load-com)
  (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark *kpblc-activedoc*)
  (initget 6)
  (or (setq kr (getint "\nВведите кратность <500>: "))
      (setq kr 500)
    )
  (setq ss (ssget "_:L" '((0 . "DIMENSION"))) count 0)
  (while (and ss
           (> (sslength ss) 0)
       (setq item (ssname ss 0))
       (ssdel item ss)
       ) ;_ end of and
    ;;;(setq item (vlax-ename->vla-object item))
    (setq rzm (atof(vl-string-subst "." "," (dim-get-text-string item))))
    (if (and
	  (zerop (rem rzm kr));;; Делится на kr (500) без остатка, 
	  (> (fix(/ rzm kr)) 1);;; и кратность больше 1
	)
      (setq rzm
         (strcat
          (itoa(fix(/ rzm kr)))
          "x" (itoa kr) "=<>"
          )
	  count (1+ count)  
	)
      (setq rzm nil)
      )
    (if rzm
      (vl-catch-all-apply 'vla-put-textoverride (list (vlax-ename->vla-object item) rzm))
      )
    )
  (vla-endundomark *kpblc-activedoc*)
  (princ "\n==================================")
  (princ "\nИзменено ")(princ count)(princ " размеров")
  (princ " кратность= ")(princ kr)
  (princ)
  ) ;_ end of defun
(defun mip_MTEXT_Unformat ( Mtext / text Str )
  (setq MM Mtext)
  (setq Text "")
   (while (/= Mtext "")
        (cond
          ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
            (setq Mtext (substr Mtext 3) Text   (strcat Text Str)))
          ((wcmatch (substr Mtext 1 1) "[{}]")(setq Mtext (substr Mtext 2)))
          ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[LO`~]")
	   (setq Mtext (substr Mtext 3)))
          ((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
            (setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
          ((wcmatch (strcase (substr Mtext 1 2)) "\\P")
            (if (or
		   (zerop (strlen Text))
		   (= " " (substr Text (strlen Text)))
		   (= " " (substr Mtext 3 1)))
               (setq Mtext (substr Mtext 3))
               (setq Mtext (substr Mtext 3) Text (strcat Text " "))))
	  ((wcmatch (strcase (substr Mtext 1 2)) "\\S")
            (setq Str   (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
                  Text  (strcat Text (vl-string-translate "#^\\" "/^\\" Str))
                  Mtext (substr Mtext (+ 4 (strlen Str)))))
	  (t (setq Text (strcat Text (substr Mtext 1 1)) Mtext (substr Mtext 2)))))
  Text)
(defun dim-get-text-string  ( dim / str)
 (setq str "")
   (vlax-for item (vla-item (vla-get-blocks
                         (vla-get-activedocument (vlax-get-acad-object))
                       ) ;_ end of vla-get-Blocks
                       (cdr (assoc 2 (entget dim)))
             ) ;_ end of vla-item
     (if (vlax-property-available-p item 'Textstring)
          (setq str (vla-get-textstring item))
       )
     )
(mip_MTEXT_Unformat str)
  )

v.psk · 17.07.2017, 21:54

Цитата:

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

v.psk, Как-то так в первом приближении

Отличная реализация. Спасибо. Багов не нашел.
Хотелось бы из удобства пользования дополнить лисп двумя штуками:
- возможностью ввода из диалогового окна значения этой переменной шага - 500 или другое, удобно если последнее введенное значение будет "по умолчанию"
- подстановка значений выполнялась бы только для выделенных объектов....

Напишу для чего... например при раскладке блоков дополнительного армирования но изополям, их можно наставить примерно, поставив округление в размерах, тогда среди размеров цепочки целые размеры окажутся в габаритных размерах блока, в направлении шага установки арматуры. Их и требуется "перебить". Когда планов много, требуется перебить сотни размеров к виду 5х200=1000 итп..., ну и например образмеривание перфорации теплоизоляционных вкладышей, шага хомутов, закладных, ... итд итп...

Кулик Алексей aka kpblc · 17.07.2017, 22:51

А сам?

v.psk · 17.07.2017, 23:09

Цитата:

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

А сам?

не умею я)))подозреваю, что доработать несложно, поэтому так нагло прошу)
а штука очень полезная
Offtop: был у меня порыв поизучать автолисп несколько лет назад, но увидел эту непонятную структуру со скобками, и перехотел

lenivec · 18.07.2017, 07:08

Offtop:

Цитата:

Сообщение от v.psk

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

Математика тоже с такими же скобками

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

VVA · 18.07.2017, 08:28

Цитата:

Сообщение от v.psk

Хотелось бы из удобства пользования дополнить лисп двумя штуками:
- возможностью ввода из диалогового окна значения этой переменной шага - 500 или другое, удобно если последнее введенное значение будет "по умолчанию"
- подстановка значений выполнялась бы только для выделенных объектов....

Обновил #55

v.psk · 18.07.2017, 08:38

Ещё одна штука всплыла..... Сразу то я не заметил) размеры равные делителю перебивать не требуется, чтобы не появлялись 1*500=500. Спасибо.

VVA · 18.07.2017, 09:45

Цитата:

Сообщение от v.psk

чтобы не появлялись 1*500=500.

Обновил #55

dextron3 · 29.10.2020, 12:56

Цитата:

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

Обновил #55

Здравствуйте, начал пользоваться данным лиспом, все работает спасибо, можно только сделать чтобы выходил результат не 5х200=1000, а 200х5=1000, так как требуют сначала шаг указывать, а потом количество, заранее благодарен!

И почему-то модифицированные размеры, перестают менять масштаб, пока кисточкой только свойства не перенесешь не меняют

AlexCondor · 29.10.2020, 13:10

dextron3, В ГОСТ 2.307—2011 вроде так:
5.48 При нанесении размеров, определяющих расстояние межд)/ равномерно расположенными одинаковыми элементами изделия (например, отверстиями), рекомендуется вместо размерных цепей наносить размер между соседними элементами и размер между крайними элементами в виде произведения количества промежутков между элементами на размер промежутка

06.08.2005, 19:23		#1
Новая задачка для ЛИСП умельцев Gostushev проектирование КМ, КМД Регистрация: 02.05.2005 Сообщений: 25 Коллеги!!! Предлагаю немного разьмяться и соорудить небольшой ЛИСПик, способный облегчить жизнь инженеру. Требуется прога, способная проставлять значения из переменной "меаsurement"размера в "text override" этого же размера. Другими словами - есть прочерченная деталь в масштабе 1:1 с нанесенными на нее размерами, такая картинка никак не тянет на чертеж КМД, ее нужно немного поджать и растянуть местами, и как правило многие размеры забываешь "перебить" и они начинают "уменьшаться". Хотелось бы все выделить и дальше смело править чертеж, не боясь что где то на изделии появяться глупые размеры. Жду ваших предложений.
Просмотров: 34841

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Лисп для копирования данных нескольких мтекстов по принципу расположения.	Red Nova	LISP	14	18.06.2008 22:08