[Pilot]

Уже довольно давно пользуюсь удобной программой Fdr для поиска неассоциативных размеров.
Она находит такие размеры, выдает сообщение об их количестве и для наглядности меняет их цвет на magenta.
Однако почему-то цвет она меняет не всегда.
Где баг? - не могу найти.
Наблюдалось и наблюдается в Акад-ах 2000, 2005, 2008рус.
Есть подозрение, что это происходит при наличии в чертеже размеров типа спдс или чего-то в этом роде.
(Программа не моя, откуда взялась уже не помню. Изначально программа Михаила Сорокина.)

Код:

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

 
(defun c:Fdr ( / na n in l en lw )
(setvar "cmdecho" 0)
(if (not (setq na (ssget "x" '((0 . "DIMENSION")))))
   (progn (alert "В чертеже нет размерных примитивов.")(exit)))
(setq n (sslength na)
      in 0
      l 0)
(repeat n
   (setq en (entget (ssname na in)))
   (if (and (/= (cdr (assoc 1 en)) "")
            (not (TinT "<>" (cdr (assoc 1 en)))))
      (progn (setq lw (subst (cons 62 6)(assoc 8 en) en) l (+ 1 l))
             (entmod lw));progn
   );if
   (setq in (1+ in))
);repeat
(if (= l 0)
   (alert "\nНеассоциативные размеры не найдены.")
   (alert (strcat "Найдено неассоциативных размеров - " (rtos l 2 0))));if
(princ));c:Fdr

(defun TinT (t1 t2 / c1 v1)
(if (= t2 0)(setq t2 nil))
(if (and t1 t2)
   (progn
      (setq t1 (strcase t1)
            t2 (strcase t2)
            c1 1)
      (repeat (strlen t2)
         (if (= t1 (substr t2 c1 (strlen t1)))(setq v1 c1))
         (setq c1 (1+ c1)))));if
v1);TinT

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

Файл, на котором не срабатывает, приложи.

[VVA]

Особо в логику не вникал, но большие подозрения вызывает этот фрагмент

Код:

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

(setq lw (subst (cons 62 6)(assoc 8 en) en) l (+ 1 l))

Т.е. заменяем поле 8 (Слой) на поле 62 (Цвет)
Немного переделанный код

Код:

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

(defun c:Fdr ( / na n in l en lw obj Color)
  (vl-load-com)
(setvar "cmdecho" 0)
(if (not (setq na (ssget "_x" '((0 . "DIMENSION")))))
   (progn (alert "В чертеже нет размерных примитивов.")(exit)))
(setq n (sslength na)
      in 0
      l 0
      Color 6
      )
(repeat n
   (setq en (entget (setq obj (ssname na in))))
   (if (and (/= (cdr (assoc 1 en)) "")
            (not (TinT "<>" (cdr (assoc 1 en)))))
      (progn
	(if (and  (setq obj (vlax-ename->vla-object obj))
	          (vlax-write-enabled-p Obj)
		  (wcmatch (vla-get-Objectname Obj)  "*Dimension*")
	     ) ;_ end of and
	   (progn
     	     (vl-catch-all-apply 'vla-put-Color (list Obj Color))
	     (vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj Color))
	     (vl-catch-all-apply 'vla-put-TextColor (list Obj Color))
	     (vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj Color))
	   ) ;_ end of progn
	 )
	 (setq l (+ 1 l))
             );progn
   );if
   (setq in (1+ in))
);repeat
(if (= l 0)
   (alert "\nНеассоциативные размеры не найдены.")
   (alert (strcat "Найдено неассоциативных размеров - " (rtos l 2 0))));if
(princ));c:Fdr

(defun TinT (t1 t2 / c1 v1)
(if (= t2 0)(setq t2 nil))
(if (and t1 t2)
   (progn
      (setq t1 (strcase t1)
            t2 (strcase t2)
            c1 1)
      (repeat (strlen t2)
         (if (= t1 (substr t2 c1 (strlen t1)))(setq v1 c1))
         (setq c1 (1+ c1)))));if
v1);TinT

[Pilot]

Сообщение от Кулик Алексей aka kpblc Файл, на котором не срабатывает, приложи.

Например этот. В нем программа находит 32 неассоциативных размера, а подсвечивает только 20.

[VVA]

Делал быстро, поэтому не оптимальною Код в #3. У тебя цвета размерным элементам (линиям, текстам) заданы явно.

[Pilot]

> VVA

Прошу прощения, но только сегодня дошли руки проверить на практике твой код.
Пока вроде работает корректно.
Спасибо!