Размерный стиль по своему слою
| Правила | Регистрация | Пользователи | Сообщения за день |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Размерный стиль по своему слою

Размерный стиль по своему слою

Ответ
Поиск в этой теме
Непрочитано 25.09.2006, 10:19 #1
Размерный стиль по своему слою
Krieger
 
инженер (КМ)
 
Красноярск
Регистрация: 30.10.2004
Сообщений: 3,837

Здравствуйте.
Такая просьба мне нужна прога, которая бы при смене размерного стиля для размерности меняла ей соответственно и слой. Слой назван в соответсвии с размерным стилем, т.е. если размерный стиль имеет имя PSK_M_S1_R1, то соответствующий слой будет называться Размерные_M_S1_R1.
Размерные стили градуются по масштабу и округлению и каждому стилю свой слой, кроме исключений - но их я потом сам доделаю.
Просмотров: 6261
 
Непрочитано 25.09.2006, 10:55
#2
Кулик Алексей aka kpblc
Moderator

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


Наверное, надо писать реактор на изменение системной переменной...
Сервисная функция:
Код:
[Выделить все]
;|
*    Создание слоя
*    Параметры вызова:
	lst	список вида
      '(("name" . "test")	; имя слоя
	("color" . 1)		; цвет. nil -> 7
	("ltype" . "Continuous"); тип линии. nil -> Continuous
	("ltypefile" . "acadiso.lin")	; файл, с которого грузить описание.
				; Если nil, то ищется в acadiso.lin
				; Требуется для "нестандартных" типов линий
				; Недостающая функция - см.
				; http://www.autocad.ru/cgi-bin/f1/board.cgi?t=22730iW
	("lw" . 25)		; Вес линии нового слоя. nil -> 0
	("lock" . t)		; заблокированность слоя
	("plot" . t)		; печатаемость слоя
	("freeze" . t)		; замороженность слоя
	("on" . t)		; выключенность слоя
	)
*    Возвращает указатель на созданный слой
|;
(defun _kpblc-layer-create (lst / res)
  (setq	res
	 (vla-add (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
		  (cdr (assoc "name" lst))
		  ) ;_ end of vla-add
	) ;_ end of setq
  (vla-put-color
    res
    (cond
      (cdr (assoc "color" lst))
      (t 7)
      ) ;_ end of cond
    ) ;_ end of vla-put-color
  (vla-put-linetype
    res
    (cond
      ((cdr (assoc "ltype" lst))
       (t (_kpblc-linetype-load
	    (cdr (assoc "ltype" lst))
	    (cdr (assoc "ltypefile" lst))
	    ) ;_ end of _kpblc-linetype-load
	  ) ;_ end of t
       )
      "Continuous"
      ) ;_ end of cond
    ) ;_ end of vla-put-linetype
  (vla-put-lineweight
    res
    (cond (cdr (assoc "lw" lst))
	  (t aclnwt000)
	  ) ;_ end of cond
    ) ;_ end of vla-put-lineweight
  (vla-put-lock
    res
    (cond
      ((cdr (assoc "lock" lst)) :vlax-true)
      (t :vlax-false)
      ) ;_ end of cond
    ) ;_ end of vla-put-lock
  (vla-put-plottable
    res
    (cond
      ((cdr (assoc "plot" lst))
       :vlax-true
       )
      (t :vlax-false)
      ) ;_ end of cond
    ) ;_ end of vla-put-Plottable
  (vla-put-layeron
    res
    (cond
      ((cdr (assoc "on" lst))
       :vlax-true
       )
      (t :vlax-false)
      ) ;_ end of cond
    ) ;_ end of vla-put-LayerOn
  (vl-catch-all-apply
    '(lambda ()
       (vla-put-freeze
	 res
	 (cond
	   ((cdr (assoc "freeze" lst))
	    :vlax-true
	    )
	   (t :vlax-false)
	   ) ;_ end of cond
	 ) ;_ end of vla-put-freeze
       ) ;_ end of lambda
    ) ;_ end of vl-catch-all-apply
  res
  ) ;_ end of defun
На сам реактор что-то не срослось сразу Чуток попозже
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 25.09.2006, 12:28
#3
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


>kpblc Ругается на загрузку кода
Цитата:
; ошибка: неверный синтаксис COND: ("Continuous")
>Krieger Пробуй. Сервисная ф-ция _dwgru-layer-create аналогична _kpblc-layer-create с небольшими дополнениями. Можно использовать и ее
Код:
[Выделить все]
;;;================== Сервисные ф-ции BEGIN

;|
* Ф-ция str-str-lst
* Сервисная ф-ция извлечения из строки данных, разделенных
* каким либо символом или строкой символов
* Возвращает список строк
* Аргументы [Type]:
  str - строка для разбора [STRING]
  pat - разделитель [STRING]
*  Пример запуска
  (setq str "мы;изучаем;рекурсии" pat ";")
  (setq str "мы — изучаем — рекурсии" pat " — ")
  (str-str-lst str pat)
* Читать подробнее http://www.autocad.ru/cgi-bin/f1/board.cgi?t=25113OT
|;
(defun str-str-lst (str pat / i)
  (cond ((= str "") nil)
        ((setq i (vl-string-search pat str))
         (cons (substr str 1 i)
               (str-str-lst (substr str (+ (strlen pat) 1 i)) pat)
         ) ;_  cons
        )
        (t (list str))
  ) ;_  cond
) ;_  defun
;;;================== Сервисные ф-ции
    ;|=============================================================================
*   На основе ф-ции _kpblc-layer-create
*   Добавлен новый  параметр  suff - суффикс слоя, если он есть, то имя слоя получается путем
*   добавления к имени существующего слоя суффикса suff
*   Создание слоя с указанными параметрами.
*   Параметры вызова:
*   layer-list   список параметров слоя вида:
   '(("name" . "TestLayer")   ; имя слоя. может быть пропущено, если указан suff
     ("color" . 3)         ; номер цвета. nil -> 7
     ("lw" . 50)         ; вес линии слоя. nil -> 25
*                          Оно выражается в сотых долях миллиметра и может быть любым
*                          из следующего ряда: 0, 5, 9, 13, 15, 18, 20, 25, 30, 35, 40, 50, 53, 60, 70,
*                          80, 90, 100, 106, 120, 140, 158, 200 и 211.
     ("lt" . "hidden")      ; тип линии слоя. nil -> Continuous
               ; Если описания типа линии в acadiso.lin
               ; нет, обязательно указывать следующий
               ; параметр
   ("ltfile" . "c:\\cad\\ltypes\\lt.lin")   ; полный путь к файлу с описанием
               ; типа линии. Если файл находится в путях
               ; поддержки, путь можно не указывать
   ("plot" . "y")         ; Печатать ("y") или нет ("n") слой.
                  ; nil -> "y"
   ("lock" . t)         ; Блокировать t  или нет nil слой.
   ("suff" . "_Размеры")  ;_Добавляемый суффикс с текущему слою. Если задан, поле "name" игнорируется            
   )
*    Возвращает vla-указатель на созданный слой. Если слой существует, его
* настройки приводятся в соответствие с переданным списком.
*    Слой размораживается, разблокируется и включается. Не активируется.
* Примеры:
  (_dwgru-layer-create '(("name" . "Test")("color" . 1)("lw" . 50)))
* создать если нет и слой Test цветом 1 (красный) весом линии 0.5
;;;(_dwgru-layer-create layer-list)
=========================================================================|;

    (defun _dwgru-layer-create (layer-list / vla_layer buf)
      (setq layer-list
             (mapcar
               '(lambda (x) (cons (strcase (car x) t) (cdr x)))
               layer-list
             ) ;_ end of mapcar
      ) ;_ end of setq
      (setq *MIP-LAYER-PROP-SETTING*
             (list (cons "layer"
                         (vla-get-activelayer
                           (vla-get-activedocument (vlax-get-acad-object))
                         ) ;_ end of vla-get-activelayer
                   ) ;_ end of cons 
                   (cons "color" (getvar "cecolor"))
                   (cons "lw" (getvar "celweight"))
                   (cons "lt" (getvar "celtype"))
             ) ;_ end of list 
      ) ;_ end of setq 

;;;Если есть suff добавляем в начало списка, 
;;;чтобы assoc нашел раньше 
      (if (cdr (assoc "suff" layer-list))
        (progn
          (setq layer-list
                 (vl-remove (assoc "name" layer-list) layer-list)
          ) ;_ end of setq
          (setq layer-list
                 (append
                   (list
                     (cons "name"
                           (strcat (getvar "clayer")
                                   (cdr (assoc "suff" layer-list))
                           ) ;_ end of strcat
                     ) ;_ end of cons
                   ) ;_ end of list
                   layer-list
                 ) ;_ end of append
          ) ;_ end of setq
        ) ;_ end of progn
      ) ;_ end of if
      (setq buf (if (snvalid (cdr (assoc "name" layer-list)))
                 (cdr (assoc "name" layer-list))
                 (getvar "CLAYER")
               ) ;_ end of if
            )
      (if (member (strcase buf)(mapcar 'strcase (tablelist "Layer")))
        (setq vla_layer (vla-item (vla-get-layers
                 (vla-get-activedocument (vlax-get-acad-object))
               ) ;_ end of vla-get-layers
                                  buf))
      (setq vla_layer
             (vla-add
               (vla-get-layers
                 (vla-get-activedocument (vlax-get-acad-object))
               ) ;_ end of vla-get-layers
                buf
             ) ;_ end of vla-add 
      ) ;_ end of setq
        )
      (if (setq buf (cdr (assoc "color" layer-list)))
        (vla-put-color
          vla_layer
          (if buf
            buf
            7
          ) ;_ end of if
        ) ;_ end of vla-put-color
      ) ;_ end of if
      (if (setq buf (cdr (assoc "lw" layer-list)))
        (vla-put-lineweight
          vla_layer
          (if buf
            (if (member buf
                        (list aclnwt000     aclnwt030     aclnwt090
                              aclnwt005     aclnwt035     aclnwt100
                              aclnwt009     aclnwt040     aclnwt106
                              aclnwt013     aclnwt050     aclnwt120
                              aclnwt015     aclnwt053     aclnwt140
                              aclnwt018     aclnwt060     aclnwt158
                              aclnwt020     aclnwt070     aclnwt200
                              aclnwt025     aclnwt080     aclnwt211
                             ) ;_ end of list
                ) ;_ end of member
              buf
              aclnwtbylwdefault
            ) ;_ end of if
            aclnwtbylwdefault
          ) ;_ end of if 
        ) ;_ end of vla-put-lineweight 
      ) ;_ end of if
      (if (and (setq buf (cdr (assoc "lt" layer-list)))
               (setq buf
                      (_kpblc-linetype-load
                        buf
                        (cdr (assoc "ltfile" layer-list))
                      ) ;_ end of _kpblc-linetype-load
               ) ;_ end of setq
          ) ;_ end of and 
        (vla-put-linetype vla_layer (vla-get-name buf))
        (vla-put-linetype vla_layer "Continuous")
      ) ;_ end of if 
      (if (setq buf (cdr (assoc "plot" layer-list)))
        (vla-put-plottable
          vla_layer
          (if (= (cdr (assoc "plot" layer-list)) "n")
            :vlax-false
            :vlax-true
          ) ;_ end of if 
        ) ;_ end of vla-put-Plottable 
      ) ;_ end of if
      (setq buf (cdr (assoc "lock" layer-list)))
      (vla-put-lock
        vla_layer
        (if buf
          :vlax-true
          :vlax-false
        ) ;_ end of if
      ) ;_ end of vla-put-lock
      (vla-put-layeron vla_layer :vlax-true)
      (if (and
            (not
              (equal (vla-get-activelayer
                       (vla-get-activedocument (vlax-get-acad-object))
                     ) ;_ end of vla-get-activelayer
                     vla_layer
              ) ;_ end of equal 
            ) ;_ end of not
            (equal (vla-get-freeze vla_layer) :vlax-true)
          ) ;_ end of and
        (vla-put-freeze vla_layer :vlax-false)
      ) ;_ end of if 
      vla_layer
    ) ;_ end of defun
;;;================================================================================
;;;Written By Michael Puckett. 
;;;Список элементов символьных таблиц АвтоКАДа 
;;; - s- имя таблицы
;;;Пример - список всех слоев - (setq all_layers (tablelist "LAYER"))
;;;(setq all_layers (tablelist "LAYER"))
;;;
;;;AutoLisp should return something like this :
;;;Start Coding Here 
    (defun tablelist (s / d r)
      (while (setq d (tblnext s (null d)))
        (setq r (cons (cdr (assoc 2 d)) r))
      )                                           ;while
    )                                             ;defun

;;;================== Сервисные ф-ции END

;;; Реактор

(or *kpblc-activedoc*
  (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object))))

(setq VLR-react (VLR-SysVar-Reactor nil (list '(:VLR-sysVarChanged . chrzmstyle)))) 
(defun chrzmstyle (name event / nstyle)
  (if (= (car event) "DIMSTYLE")
    (progn
      (setq nstyle (getvar "DIMSTYLE")
	    nstyle (str-str-lst nstyle "_")
	    nstyle (VL-STRING-RIGHT-TRIM "_" (apply 'strcat (mapcar '(lambda (x) (strcat x "_"))(cdr nstyle)))))
      (if (snvalid nstyle)
	(progn
	  (setq nstyle (strcat "Размерные_" nstyle))
	  (vla-put-activelayer *kpblc-activedoc*
          (_dwgru-layer-create (list (cons "name" nstyle))))
	  )
	)
      )
    )
  (princ) 
  )

Последний раз редактировалось VVA, 19.09.2015 в 22:49. Причина: Более правильная _dwgru-layer-create
VVA вне форума  
 
Автор темы   Непрочитано 25.09.2006, 12:56
#4
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837


VVA
Спасибо. Тоже пригодится. Просил маленько другое. Если у меня уже вычерчен размер и вот я хочу ему сменить размерный стиль - выделяю и меняю либо в окошке стилей либо через свойства. Стиль меняется, а слой нет. Вот, а надо чтоб менялся.
Krieger вне форума  
 
Непрочитано 25.09.2006, 13:03
#5
Кулик Алексей aka kpblc
Moderator

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


Получается, что надо объектный реактор, да еще и постоянный разрабатывать?
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 25.09.2006, 14:00
#6
Om81

Хочу быть фотографом :)
 
Регистрация: 21.10.2005
Москва, Кисловодск
Сообщений: 2,538
<phrase 1=


Цитата:
Сообщение от Krieger
Если у меня уже вычерчен размер и вот я хочу ему сменить размерный стиль - выделяю и меняю либо в окошке стилей либо через свойства. Стиль меняется, а слой нет. Вот, а надо чтоб менялся.
А можно просто потом выбрать QuickSelect'ом размеры заданного стиля и послать их на свой слой
__________________
Камень на камень, кирпич на кирпич..
Om81 вне форума  
 
Непрочитано 25.09.2006, 18:16
#7
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Немного доделал свой лисп, чтобы не повторять все ф-ции - все в архиве. Здесь пояснения
Там набор реакторов, которые работают на
1. Появление блока в чертеже
2. Выполнение той или иной команды
3. Добавлено появление размеров
Суть их в разбрасывании объектов по слоям.
Провила задаются на основе списков вида
Для блоков

Код:
[Выделить все]
(setq *DWGRU_BLOCK* '(
 ("KV"                       ;_Имя блока KV
  (
   ("name" . "$водопровод")  ;_Имя слоя $водопровод
  )
 )
;;;-------------------Начало описания блока --------------------------------- 
 ("*_P"                       ;Шаблон Блоки типа krug_p, kvadrat_p
   (("name" . "Проектируемые") ;_Слой Проектируемые
   ("color" . 1)              ;_Цвет 1
   ("lw" . 50)                ;_Вес 05
   )
 )
;-------------------Конец описания блока -------------------------------------
))
Для команд вида
Код:
[Выделить все]
(setq *DWGRU_CMD* '(
        ("DIM*"                       ;_Если выполнается команда DIM*
	 (("name" . 'KriegerMakeDimLayerName))
         )
        ("*TEXT"
	 (("name" . "Текст") ;_Если выполнается команда *TEXT (TEXT DTEXT)
           ("color" . 3)
           ("lw" . 50)
          )
         )
        ("*hatch*" ;_Если выполнается команда *HATCH*
         (("suff" . "_Штриховка") 
         ("color" . 5)
         ("lw" . 50)
         )
         )
        )
      );_setq
Ключи к списку
(("name" . "Проектируемые")
("color" . 1)
("lw" . 50)
...
)
как в списке вызова команды _dwgru-layer-create
Слой для размеров задается вызовом ф-ции из реактора
Код:
[Выделить все]
  (foreach dim *DWGRU_DIMENSION*
    (setq nstyle (KriegerMakeDimLayerNamebyStyle (vla-get-StyleName dim)))
    (vla-put-Layer dim 
       (vla-get-Name(_dwgru-layer-create (list(cons "name" nstyle)))))
    )
Короче это я к чему, можно через списки *DWGRU_CMD* и *DWGRU_BLOCK* настроить создание определенных слоев при выполнении той или иной команды или появоения блока.
Для примера зарузи архив и создай в чертеже блоки с именами "KV", krug_p. А так же посмотри куда разносятся примитивы при выполнении команд DIM* *TEXT *HATCH.

Если этого не надо, просто присвой переменным nil
(setq *DWGRU_BLOCK* nil)
(setq *DWGRU_CMD* nil)
Немного сумбурно, но получилось так
[ATTACH]1159194425.rar[/ATTACH]
VVA вне форума  
 
Непрочитано 25.09.2006, 19:23
#8
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Что-то все в одном у меня вываливается.
Пробуй так
Код:
[Выделить все]
;;;================== Сервисные ф-ции
;| 
* Ф-ция str-str-lst 
* Сервисная ф-ция извлечения из строки данных, разделенных 
* каким либо символом или строкой символов 
* Возвращает список строк 
* Аргументы [Type]: 
  str - строка для разбора [STRING] 
  pat - разделитель [STRING] 
*  Пример запуска 
  (setq str "мы;изучаем;рекурсии" pat ";") 
  (setq str "мы — изучаем — рекурсии" pat " — ") 
  (str-str-lst str pat) 
* Читать подробнее http://www.caduser.ru/forum/index.php?PAGE_NAME=message&FID=23&TID=25197&MID=143539#message143539 
|; 
(defun str-str-lst (str pat / i) 
  (cond ((= str "") nil) 
        ((setq i (vl-string-search pat str)) 
         (cons (substr str 1 i) 
               (str-str-lst (substr str (+ (strlen pat) 1 i)) pat) 
         ) ;_  cons 
        ) 
        (t (list str)) 
  ) ;_  cond 
) ;_  defun 

;;;Возвращает имя слоя по имени dimstyle
(defun KriegerMakeDimLayerNamebyStyle ( stl / nstyle )
(setq  nstyle stl 
       nstyle (str-str-lst nstyle "_") 
       nstyle (VL-STRING-RIGHT-TRIM "_" (apply 'strcat (mapcar '(lambda (x) (strcat x "_"))(cdr nstyle)))))
  (if (snvalid nstyle)
    (strcat "Размерные_" nstyle)
    (getvar "CLAYER")))


;|=============================================================================
*   На основе ф-ции _kpblc-layer-create
*   Добавлен новый  параметр  suff - суффикс слоя, если он есть, то имя слоя получаестся путем
*   добавления к имени существующего слоя суффикса suff
*   Создание слоя с указанными параметрами.
*   Параметры вызова:
*   layer-list   список параметров слоя вида:
   '(("name" . "TestLayer")   ; имя слоя. может быть пропущено, если указан suff
     ("color" . 3)         ; номер цвета. nil -> 7
     ("lw" . 50)         ; вес линии слоя. nil -> 25
*                          Оно выражается в сотых долях миллиметра и может быть любым
*                          из следующего ряда: 0, 5, 9, 13, 15, 18, 20, 25, 30, 35, 40, 50, 53, 60, 70,
*                          80, 90, 100, 106, 120, 140, 158, 200 и 211.
     ("lt" . "hidden")      ; тип линии слоя. nil -> Continuous
               ; Если описания типа линии в acadiso.lin
               ; нет, обязательно указывать следующий
               ; параметр
   ("ltfile" . "c:\\cad\\ltypes\\lt.lin")   ; полный путь к файлу с описанием
               ; типа линии. Если файл находится в путях
               ; поддержки, путь можно не указывать
   ("plot" . "y")         ; Печатать ("y") или нет ("n") слой.
               ; nil -> "y"
   ("suff" . "_Размеры")  ;_Добавляемый суффикс с текущему слою. Если задан, поле "name" игнорируется            
   )
*    Возвращает vla-указатель на созданный слой. Если слой существует, его
* настройки приводятся в соответствие с переданным списком.
*    Слой размораживается, разблокируется и включается. Не активируется.


=========================================================================|;

(defun _dwgru-layer-create (layer-list / vla_layer buf)
       (setq *MIP-LAYER-PROP-SETTING*
     (list (cons "layer"
   (vla-get-activelayer (vla-get-activedocument (vlax-get-acad-object)))
   ) ;_ end of cons
    (cons "color" (getvar "cecolor"))
    (cons "lw" (getvar "celweight"))
    (cons "lt" (getvar "celtype"))
    ) ;_ end of list
    ) ;_ end of setq

  ;;;Если есть suff добавляем в начало списка,
  ;;;чтобы assoc нашел раньше
  (if (cdr(assoc "suff" layer-list))
    (progn
     (setq layer-list (vl-remove (assoc "name" layer-list) layer-list))
     (setq layer-list (append (list(cons "name" (strcat (getvar "clayer") (cdr(assoc "suff" layer-list))))) layer-list))
    )
  )
  (setq vla_layer
  (vla-add
    (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
    (if (snvalid (cdr (assoc "name" layer-list)))
        (cdr (assoc "name" layer-list))
        "0"
      )
    ) ;_ end of vla-add
 ) ;_ end of setq
  (if (setq buf (cdr (assoc "color" layer-list)))
  (vla-put-color vla_layer (if buf buf 7)))
  (if (setq buf (cdr (assoc "lw" layer-list)))
  (vla-put-lineweight
    vla_layer
    (if buf
      (if (member buf (list acLnWt000  acLnWt030  acLnWt090
    acLnWt005  acLnWt035  acLnWt100
    acLnWt009  acLnWt040  acLnWt106
    acLnWt013  acLnWt050  acLnWt120
    acLnWt015  acLnWt053  acLnWt140
    acLnWt018  acLnWt060  acLnWt158
    acLnWt020  acLnWt070  acLnWt200
    acLnWt025  acLnWt080  acLnWt211
    )
    )
    buf
    acLnWtByLwDefault
 )
      acLnWtByLwDefault
      ) ;_ end of if
    ) ;_ end of vla-put-lineweight
    )
  (if (and (setq buf (cdr (assoc "lt" layer-list)))
    (_kpblc-linetype-load
      buf
      (cdr (assoc "ltfile" layer-list))
      ) ;_ end of _kpblc-linetype-load
    ) ;_ end of and
    (vla-put-linetype vla_layer (cdr (assoc "lt" layer-list)))
    (vla-put-linetype vla_layer "Continuous")
    ) ;_ end of if
 (if (setq buf (cdr (assoc "plot" layer-list)))
  (vla-put-plottable
    vla_layer
    (if (= (cdr (assoc "plot" layer-list)) "n")
      :vlax-false
      :vlax-true
      ) ;_ end of if
    ) ;_ end of vla-put-Plottable
   )
  (vla-put-lock vla_layer :vlax-false)
  (vla-put-layeron vla_layer :vlax-true)
  (if (not (equal (vla-get-activelayer (vla-get-activedocument (vlax-get-acad-object)))
    vla_layer
    ) ;_ end of equal
    ) ;_ end of not
    (vla-put-freeze vla_layer :vlax-false)
    ) ;_ end of if
  vla_layer
  ) ;_ end of defun




;;=============== Реакторы =======================

(defun r-acdb-mod (react  cmd / blk_obj cmd_name tset)
  (setq blk_obj (vlax-ename->vla-object (cadr cmd)))
  (cond ((wcmatch (vla-get-ObjectName blk_obj) "*Dimension*")
	 (setq *DWGRU_DIMENSION* (append *DWGRU_DIMENSION* (list blk_obj))))
       (t nil)))
(defun chrzmstyle (name event / nstyle)
  (foreach dim *DWGRU_DIMENSION*
    (setq nstyle (KriegerMakeDimLayerNamebyStyle (vla-get-StyleName dim)))
    (vla-put-Layer dim 
       (vla-get-Name(_dwgru-layer-create (list(cons "name" nstyle)))))
    )
  (setq *DWGRU_DIMENSION* nil))
  
;;;==================
(or *kpblc-activedoc*
  (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object))))
(if *vlr-AcDb*
  (progn
    (setq *vlr-AcDb* nil)
    (vlr-remove-all :VLR-AcDb-Reactor)
    ) ;_ end of progn
  ) ;_ end of if

(if (not *vlr-AcDb*)
(setq *vlr-AcDb* (VLR-AcDb-Reactor
     "AcDb"
     '((:VLR-objectModified . r-acdb-mod)))))
(setq VLR-react (VLR-SysVar-Reactor nil (list '(:VLR-sysVarChanged . chrzmstyle))))

Последний раз редактировалось VVA, 19.09.2015 в 22:47.
VVA вне форума  
 
Автор темы   Непрочитано 26.09.2006, 07:25
#9
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837


VVA - это все хорошо, но я хотел отследить не появление приметива или выполнение команды, а изменение свойства (стиль) отдельного примитива (размер) и поменять ему в купе другое свойство (слой).
А вот что делают код из поста №8? У меня не работает.
Krieger вне форума  
 
Непрочитано 26.09.2006, 10:22
#10
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Так код из поста №8 это и делает.
Устанавливает реактор на изменение объектов, отлавливает размеры, и при изменении системной переменной изменяет слой отловленных размеров на слой, возвращаемой ф-цией KriegerMakeDimLayerNamebyStyle. А она берет размерный стиль и возвращает имя слоя для него. Если в тиле есть _, то возвращается имя слой "Размерные_XX", если нет текущий слой.
1.(KRIEGERMAKEDIMLAYERNAMEBYSTYLE "A_B_C")->"Размерные_B_C"
2.(KRIEGERMAKEDIMLAYERNAMEBYSTYLE "ABC") ->"0" (текущий)
У меня работает.
Отрисуй размер, измени его стиль на "A_B_C_D". Слой должен изменится на "Размерные_B_C_D"
VVA вне форума  
 
Автор темы   Непрочитано 26.09.2006, 10:42
#11
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837


Цитата:
Сообщение от VVA
Отрисуй размер, измени его стиль на "A_B_C_D". Слой должен изменится на "Размерные_B_C_D"
Вообще никакой реакции. :cry:
Krieger вне форума  
 
Непрочитано 26.09.2006, 11:46
#12
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


[sm3518]
Код с поста №8 работал в 2004.
Этот должен работать
Код:
[Выделить все]
;;;================== Сервисные ф-ции 
;| 
* Ф-ция str-str-lst 
* Сервисная ф-ция извлечения из строки данных, разделенных 
* каким либо символом или строкой символов 
* Возвращает список строк 
* Аргументы [Type]: 
  str - строка для разбора [STRING] 
  pat - разделитель [STRING] 
*  Пример запуска 
  (setq str "мы;изучаем;рекурсии" pat ";") 
  (setq str "мы — изучаем — рекурсии" pat " — ") 
  (str-str-lst str pat) 
* Читать подробнее http://www.caduser.ru/forum/index.php?PAGE_NAME=message&FID=23&TID=25197&MID=143539#message143539 
|; 
(defun str-str-lst (str pat / i) 
  (cond ((= str "") nil) 
        ((setq i (vl-string-search pat str)) 
         (cons (substr str 1 i) 
               (str-str-lst (substr str (+ (strlen pat) 1 i)) pat) 
         ) ;_  cons 
        ) 
        (t (list str)) 
  ) ;_  cond 
) ;_  defun 

;;;Возвращает имя слоя по имени dimstyle 
(defun KriegerMakeDimLayerNamebyStyle ( stl lay / nstyle ) 
(setq  nstyle stl 
       nstyle (str-str-lst nstyle "_") 
       nstyle (VL-STRING-RIGHT-TRIM "_" (apply 'strcat (mapcar '(lambda (x) (strcat x "_"))(cdr nstyle))))) 
  (if (snvalid nstyle) 
    (strcat "Размерные_" nstyle) 
    lay)) 


;|============================================================================= 
*   На основе ф-ции _kpblc-layer-create 
*   Добавлен новый  параметр  suff - суффикс слоя, если он есть, то имя слоя получаестся путем 
*   добавления к имени существующего слоя суффикса suff 
*   Создание слоя с указанными параметрами. 
*   Параметры вызова: 
*   layer-list   список параметров слоя вида: 
   '(("name" . "TestLayer")   ; имя слоя. может быть пропущено, если указан suff 
     ("color" . 3)         ; номер цвета. nil -> 7 
     ("lw" . 50)         ; вес линии слоя. nil -> 25 
*                          Оно выражается в сотых долях миллиметра и может быть любым 
*                          из следующего ряда: 0, 5, 9, 13, 15, 18, 20, 25, 30, 35, 40, 50, 53, 60, 70, 
*                          80, 90, 100, 106, 120, 140, 158, 200 и 211. 
     ("lt" . "hidden")      ; тип линии слоя. nil -> Continuous 
               ; Если описания типа линии в acadiso.lin 
               ; нет, обязательно указывать следующий 
               ; параметр 
   ("ltfile" . "c:\\cad\\ltypes\\lt.lin")   ; полный путь к файлу с описанием 
               ; типа линии. Если файл находится в путях 
               ; поддержки, путь можно не указывать 
   ("plot" . "y")         ; Печатать ("y") или нет ("n") слой. 
               ; nil -> "y" 
   ("suff" . "_Размеры")  ;_Добавляемый суффикс с текущему слою. Если задан, поле "name" игнорируется            
   ) 
*    Возвращает vla-указатель на созданный слой. Если слой существует, его 
* настройки приводятся в соответствие с переданным списком. 
*    Слой размораживается, разблокируется и включается. Не активируется. 


=========================================================================|; 

(defun _dwgru-layer-create (layer-list / vla_layer buf) 
       (setq *MIP-LAYER-PROP-SETTING* 
     (list (cons "layer" 
   (vla-get-activelayer (vla-get-activedocument (vlax-get-acad-object))) 
   ) ;_ end of cons 
    (cons "color" (getvar "cecolor")) 
    (cons "lw" (getvar "celweight")) 
    (cons "lt" (getvar "celtype")) 
    ) ;_ end of list 
    ) ;_ end of setq 

  ;;;Если есть suff добавляем в начало списка, 
  ;;;чтобы assoc нашел раньше 
  (if (cdr(assoc "suff" layer-list)) 
    (progn 
     (setq layer-list (vl-remove (assoc "name" layer-list) layer-list)) 
     (setq layer-list (append (list(cons "name" (strcat (getvar "clayer") (cdr(assoc "suff" layer-list))))) layer-list)) 
    ) 
  ) 
  (setq vla_layer 
  (vla-add 
    (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) 
    (if (snvalid (cdr (assoc "name" layer-list))) 
        (cdr (assoc "name" layer-list)) 
        "0" 
      ) 
    ) ;_ end of vla-add 
 ) ;_ end of setq 
  (if (setq buf (cdr (assoc "color" layer-list))) 
  (vla-put-color vla_layer (if buf buf 7))) 
  (if (setq buf (cdr (assoc "lw" layer-list))) 
  (vla-put-lineweight 
    vla_layer 
    (if buf 
      (if (member buf (list acLnWt000  acLnWt030  acLnWt090 
    acLnWt005  acLnWt035  acLnWt100 
    acLnWt009  acLnWt040  acLnWt106 
    acLnWt013  acLnWt050  acLnWt120 
    acLnWt015  acLnWt053  acLnWt140 
    acLnWt018  acLnWt060  acLnWt158 
    acLnWt020  acLnWt070  acLnWt200 
    acLnWt025  acLnWt080  acLnWt211 
    ) 
    ) 
    buf 
    acLnWtByLwDefault 
 ) 
      acLnWtByLwDefault 
      ) ;_ end of if 
    ) ;_ end of vla-put-lineweight 
    ) 
  (if (and (setq buf (cdr (assoc "lt" layer-list))) 
    (_kpblc-linetype-load 
      buf 
      (cdr (assoc "ltfile" layer-list)) 
      ) ;_ end of _kpblc-linetype-load 
    ) ;_ end of and 
    (vla-put-linetype vla_layer (cdr (assoc "lt" layer-list))) 
    (vla-put-linetype vla_layer "Continuous") 
    ) ;_ end of if 
 (if (setq buf (cdr (assoc "plot" layer-list))) 
  (vla-put-plottable 
    vla_layer 
    (if (= (cdr (assoc "plot" layer-list)) "n") 
      :vlax-false 
      :vlax-true 
      ) ;_ end of if 
    ) ;_ end of vla-put-Plottable 
   ) 
  (vla-put-lock vla_layer :vlax-false) 
  (vla-put-layeron vla_layer :vlax-true) 
  (if (not (equal (vla-get-activelayer (vla-get-activedocument (vlax-get-acad-object))) 
    vla_layer 
    ) ;_ end of equal 
    ) ;_ end of not 
    (vla-put-freeze vla_layer :vlax-false) 
    ) ;_ end of if 
  vla_layer 
  ) ;_ end of defun 

;;=============== Реакторы ======================= 

(defun r-acdb-mod (react  cmd / blk_obj cmd_name tset)
  (setq blk_obj (vlax-ename->vla-object (cadr cmd))) 
  (cond ((wcmatch (vla-get-ObjectName blk_obj) "*Dimension*")
    (setq *DWGRU_DIMENSION* (append *DWGRU_DIMENSION* (list blk_obj))))
	(setvar "ortho" 0)
       (t nil))) 
  
;;;================== 
(or *kpblc-activedoc* 
  (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))) 
(if *vlr-AcDb* 
  (progn 
    (setq *vlr-AcDb* nil) 
    (vlr-remove-all :VLR-AcDb-Reactor) 
    ) ;_ end of progn 
  ) ;_ end of if 

(if (not *vlr-AcDb*) 
(setq *vlr-AcDb* (VLR-AcDb-Reactor 
     "AcDb" 
     '((:VLR-objectModified . r-acdb-mod)))))

(if *vlr-mis* 
  (progn 
    (setq *vlr-mis* nil) 
    (vlr-remove-all :vlr-miscellaneous-reactor)))
(if (not *vlr-mis*) 
  (setq   *vlr-mis* (vlr-miscellaneous-reactor 
          nil 
          '((:vlr-pickfirstmodified . selchange)))))

(defun selchange (reactor event / selset sum_len item_name nstyle)
  (if (null *MIP-MODEMACRO-OLD*)(setq *MIP-MODEMACRO-OLD* (getvar "MODEMACRO")))
  (setq sum_len 0.0) 
  (if (and (setq selset   (vla-get-pickfirstselectionset 
           (vla-get-activedocument (vlax-get-acad-object))))
      (> (vla-get-count selset) 0))
  (progn
   (setq *DWGRU_DIMENSION* nil) 
   (vlax-for   item selset 
   (if (vlax-property-available-p item 'length) 
     (setq sum_len (+ sum_len (vla-get-length item))) 
     (setq   item_name (strcase (vla-get-objectname item) t) 
      sum_len (+ sum_len
	(cond ((= item_name "acdbcircle")(* 2 pi (vla-get-radius item)))
	      ((= item_name "acdbarc")(vla-get-ArcLength item))
	      ((member item_name '("acdbellipse" "acdbspline"))
	       (vlax-curve-getDistAtParam item (vlax-curve-getEndParam item)))
	      (t 0.0))))
     ) ;_ end of if 
   ) ;_ end of vlax-for
   (if (member (type *MIP-MODEMACRO-SCALE*) '(INT REAL))
	(progn
	(setq item_name (strcat " (K=" (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*) ")"))
	(setq sum_len (* sum_len *MIP-MODEMACRO-SCALE*))
	)
	(setq item_name " (K=1)" *MIP-MODEMACRO-SCALE* 1)
	)
      (setvar "modemacro" (strcat "Выбрано=" (itoa (vla-get-count selset)) " Длина=" (rtos sum_len 2 4) (strcat item_name " MM-изм. масштаб")))
      ) ;_ end of progn
     (progn
      (setvar "modemacro" (if (= (type *MIP-MODEMACRO-OLD*) 'STR) *MIP-MODEMACRO-OLD* ""))
      (setq *MIP-MODEMACRO-OLD* nil)
      (foreach dim *DWGRU_DIMENSION* 
    (setq nstyle (KriegerMakeDimLayerNamebyStyle (vla-get-StyleName dim)(vla-get-Layer dim))) 
    (vla-put-Layer dim 
       (vla-get-Name(_dwgru-layer-create (list(cons "name" nstyle))))) 
    ) 
  (setq *DWGRU_DIMENSION* nil)
      )
    ) ;_ end of if 
  ) ;_ end of defun
(defun c:MM ( )
  (initget 7)
  (setq *MIP-MODEMACRO-SCALE* (getint "\nНовый масштабный коэффициент: "))(princ))
(defun C:MC ()(setvar "modemacro" "")(princ))
Я модифицировал KriegerMakeDimLayerNamebyStyle, если стиль не типа A_B_C, то слой размера не меняется (раньше менялся на текущий)
Попутно считает длину всех выделенных объектов. Командой MM можно установить масштаб.

Добавлено
Слой размера изменится при отмене предварительного выбора (ESC)

Последний раз редактировалось VVA, 19.09.2015 в 20:45.
VVA вне форума  
 
Непрочитано 26.09.2006, 12:18
#13
Эдуард

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


Навскидку почти без проверок
Код:
[Выделить все]
(defun dimst-layer-reactor ()
  (if
    (not
      (tblsearch "layer"
		 (setq lname (strcat "Размерные_" (getvar "dimstyle")))
      )
    )
     (progn
       (vla-add	(vla-get-layers
		  (vla-get-ActiveDocument (vlax-get-acad-object))
		)
		lname
       )
       (setvar "clayer" lname)
     )
  )

  (if (not dimreactor)
    (setq dimreactor
	   (VLR-SysVar-Reactor
	     ""
	     '((:VLR-sysVarChanged . chang_layer))
	   )
    )
  )
)
(defun chang_layer (a b / lname)
  (if (= (strcase (car b)) "DIMSTYLE")
    (progn
      (if
	(not
	  (tblsearch
	    "layer"
	    (setq lname (strcat "Размерные_" (getvar "dimstyle")))
	  )
	)
	 (vla-add (vla-get-layers
		    (vla-get-ActiveDocument (vlax-get-acad-object))
		  )
		  lname
	 )
      )
      (setvar "clayer" lname)
    )
  )
  (princ)
)
Эдуард вне форума  
 
Автор темы   Непрочитано 26.09.2006, 12:27
#14
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837


[sm155] Спасибо, работает!
Подсчет суммы - классное побочное явление.
Тока один маленький нюанс - к названию дописываются нулики с баксами (номера подстилей я так пологаю)
Вместо слоя:
Код:
[Выделить все]
Размерные_M_S100_R10
получается:
Код:
[Выделить все]
Размерные_M_S100_R10$0
Krieger вне форума  
 
Непрочитано 26.09.2006, 12:55
#15
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Замени ф-цию KriegerMakeDimLayerNamebyStyle
На эту. Артефакт должен исчезнуть.
Код:
[Выделить все]
;;;Возвращает имя слоя по имени dimstyle
;;;stl - имя размерного стиля
;;;lay - текущее имя слоя размера
(defun KriegerMakeDimLayerNamebyStyle ( stl lay / nstyle ) 
(setq  nstyle (car (str-str-lst stl "$"))
       nstyle (str-str-lst nstyle "_") 
       nstyle (VL-STRING-RIGHT-TRIM "_" (apply 'strcat (mapcar '(lambda (x) (strcat x "_"))(cdr nstyle))))) 
  (if (snvalid nstyle) 
    (strcat "Размерные_" nstyle) 
    lay))
VVA вне форума  
 
Автор темы   Непрочитано 27.09.2006, 08:06
#16
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837


Всем спасибо.
Krieger вне форума  
 
Автор темы   Непрочитано 27.09.2006, 10:40
#17
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837


Не долго я радовался.
При попытки сохранить чертеж в версии ниже 2007 выдаёт следуюее:
Цитата:
Command: _saveas ; error: Automation Error. Description was not provided.
; error: Automation Error. Description was not provided.
; error: Automation Error. Description was not provided.
; error: Automation Error. Description was not provided.
; error: Automation Error. Description was not provided.
И в конце концов вылетает.
Без этих реакторов все нормально. Как загружаю проги из поста№12 происходит такоя вот фигня.
Krieger вне форума  
 
Непрочитано 27.09.2006, 13:05
#18
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,996


Переписано без реакторов модели, только miscellaneous реактор.
Возникала и возникает ошибка (vla-get-pickfirstselectionset
(vla-get-activedocument (vlax-get-acad-object))), если в чертеже есть RTEXT. Пришлось обернуть в vl-catch-all-apply. В общем пробуй
Код:
[Выделить все]
;;;Возвращает имя слоя по имени dimstyle
;;;stl - имя размерного стиля
;;;lay - текущее имя слоя размера
(vl-load-com)
(defun KriegerMakeDimLayerNamebyStyle ( stl lay / nstyle )
(defun str-str-lst (str pat / i) 
(cond ((= str "") nil)((setq i (vl-string-search pat str))
(cons (substr str 1 i)(str-str-lst (substr str (+ (strlen pat) 1 i)) pat))) 
(t (list str))))
(setq  nstyle (car (str-str-lst stl "$"))
       nstyle (str-str-lst nstyle "_") 
       nstyle (VL-STRING-RIGHT-TRIM "_" (apply 'strcat (mapcar '(lambda (x) (strcat x "_"))(cdr nstyle))))) 
  (if (snvalid nstyle)(strcat "Размерные_" nstyle) lay)) 
;|============================================================================= 
*   На основе ф-ции _kpblc-layer-create 

*   Добавлен новый  параметр  suff - суффикс слоя, если он есть, то имя слоя получаестся путем 
*   добавления к имени существующего слоя суффикса suff 
*   Создание слоя с указанными параметрами. 
*   Параметры вызова: 
*   layer-list   список параметров слоя вида: 
   '(("name" . "TestLayer")   ; имя слоя. может быть пропущено, если указан suff 
     ("color" . 3)         ; номер цвета. nil -> 7 
     ("lw" . 50)         ; вес линии слоя. nil -> 25 
*                          Оно выражается в сотых долях миллиметра и может быть любым 
*                          из следующего ряда: 0, 5, 9, 13, 15, 18, 20, 25, 30, 35, 40, 50, 53, 60, 70, 
*                          80, 90, 100, 106, 120, 140, 158, 200 и 211. 
     ("lt" . "hidden")      ; тип линии слоя. nil -> Continuous 
               ; Если описания типа линии в acadiso.lin 
               ; нет, обязательно указывать следующий 
               ; параметр 
   ("ltfile" . "c:\\cad\\ltypes\\lt.lin")   ; полный путь к файлу с описанием 
               ; типа линии. Если файл находится в путях 
               ; поддержки, путь можно не указывать 
   ("plot" . "y")         ; Печатать ("y") или нет ("n") слой. 
               ; nil -> "y" 
   ("suff" . "_Размеры")  ;_Добавляемый суффикс с текущему слою. Если задан, поле "name" игнорируется            
   ) 
*    Возвращает vla-указатель на созданный слой. Если слой существует, его 
* настройки приводятся в соответствие с переданным списком. 
*    Слой размораживается, разблокируется и включается. Не активируется. 
=========================================================================|; 

(defun _dwgru-layer-create (layer-list / vla_layer buf) 
 (setq *MIP-LAYER-PROP-SETTING* 
 (list (cons "layer" (vla-get-activelayer (vla-get-activedocument (vlax-get-acad-object))))
 (cons "color" (getvar "cecolor"))(cons "lw" (getvar "celweight"))(cons "lt" (getvar "celtype"))))
  ;;;Если есть suff добавляем в начало списка, чтобы assoc нашел раньше 
  (if (cdr(assoc "suff" layer-list)) 
    (progn 
     (setq layer-list (vl-remove (assoc "name" layer-list) layer-list)) 
     (setq layer-list (append (list(cons "name" (strcat (getvar "clayer") (cdr(assoc "suff" layer-list))))) layer-list)) 
    )) 
  (setq vla_layer 
  (vla-add (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) 
    (if (snvalid (cdr (assoc "name" layer-list)))(cdr (assoc "name" layer-list)) "0")))
  (if (setq buf (cdr (assoc "color" layer-list)))(vla-put-color vla_layer (if buf buf 7))) 
  (if (setq buf (cdr (assoc "lw" layer-list)))(vla-put-lineweight vla_layer 
  (if buf 
   (if (member buf (list acLnWt000  acLnWt030  acLnWt090 acLnWt005  acLnWt035  acLnWt100
    acLnWt009  acLnWt040  acLnWt106 acLnWt013  acLnWt050  acLnWt120 acLnWt015  acLnWt053  acLnWt140 
    acLnWt018  acLnWt060  acLnWt158 acLnWt020  acLnWt070  acLnWt200 acLnWt025  acLnWt080  acLnWt211)) 
    buf acLnWtByLwDefault) acLnWtByLwDefault ))) 
  (if (and (setq buf (cdr (assoc "lt" layer-list))) 
    (_kpblc-linetype-load buf (cdr (assoc "ltfile" layer-list))))
    (vla-put-linetype vla_layer (cdr (assoc "lt" layer-list)))
    (vla-put-linetype vla_layer "Continuous"))
 (if (setq buf (cdr (assoc "plot" layer-list))) 
  (vla-put-plottable vla_layer 
    (if (= (cdr (assoc "plot" layer-list)) "n") :vlax-false :vlax-true))) 
  (vla-put-lock vla_layer :vlax-false)(vla-put-layeron vla_layer :vlax-true) 
  (if (not (equal (vla-get-activelayer (vla-get-activedocument (vlax-get-acad-object))) 
    vla_layer))
    (vla-put-freeze vla_layer :vlax-false)) vla_layer)
;;=============== Реакторы ======================= 

(if *vlr-mis* 
  (progn 
    (setq *vlr-mis* nil) 
    (vlr-remove-all :vlr-miscellaneous-reactor))) 
(if (not *vlr-mis*) 
  (setq   *vlr-mis* (vlr-miscellaneous-reactor 
          nil 
          '((:vlr-pickfirstmodified . selchange))))) 

(defun selchange (reactor event / selset sum_len item_name nstyle err) 
  (if (null *MIP-MODEMACRO-OLD*)(setq *MIP-MODEMACRO-OLD* (getvar "MODEMACRO"))) 
  (setq sum_len 0.0)
  (setq err (vl-catch-all-apply '(lambda ()(and (setq selset   (vla-get-pickfirstselectionset 
           (vla-get-activedocument (vlax-get-acad-object))))
      (> (vla-get-count selset) 0)))))
  (if (and (not (vl-catch-all-error-p err))
	   err)
  (progn 
   (setq *DWGRU_DIMENSION* nil) 
   (vlax-for   item selset
     (cond ((wcmatch (vla-get-objectname item) "*Dimension*")
	  (setq *DWGRU_DIMENSION* (append *DWGRU_DIMENSION* (list item))))
	 (t nil)
     )
   (if (vlax-property-available-p item 'length) 
     (setq sum_len (+ sum_len (vla-get-length item))) 
     (setq   item_name (strcase (vla-get-objectname item) t) 
      sum_len (+ sum_len 
   (cond ((= item_name "acdbcircle")(* 2 pi (vla-get-radius item))) 
         ((= item_name "acdbarc")(vla-get-ArcLength item)) 
         ((member item_name '("acdbellipse" "acdbspline")) 
          (vlax-curve-getDistAtParam item (vlax-curve-getEndParam item))) 
         (t 0.0)))) 
     ) ;_ end of if 
   ) ;_ end of vlax-for 
   (if (member (type *MIP-MODEMACRO-SCALE*) '(INT REAL)) 
   (progn 
   (setq item_name (strcat " (K=" (VL-PRINC-TO-STRING *MIP-MODEMACRO-SCALE*) ")")) 
   (setq sum_len (* sum_len *MIP-MODEMACRO-SCALE*)) 
   ) 
   (setq item_name " (K=1)" *MIP-MODEMACRO-SCALE* 1) 
   )
   (setq *MIP-LENGTH* sum_len)
      (setvar "modemacro" (strcat "Выбрано=" (itoa (vla-get-count selset)) " Длина=" (rtos sum_len 2 4) (strcat item_name " MM-масштаб LP-печать")))
      ) ;_ end of progn 
     (progn 
      (setvar "modemacro" (if (= (type *MIP-MODEMACRO-OLD*) 'STR) *MIP-MODEMACRO-OLD* "")) 
      (setq *MIP-MODEMACRO-OLD* nil)
      (vl-catch-all-apply '(lambda ()
      (foreach dim *DWGRU_DIMENSION* 
    (setq nstyle (KriegerMakeDimLayerNamebyStyle (vla-get-StyleName dim)(vla-get-Layer dim))) 
    (vla-put-Layer dim 
       (vla-get-Name(_dwgru-layer-create (list(cons "name" nstyle)))))))) 
  (setq *DWGRU_DIMENSION* nil))))
(defun c:MM ( )(initget 7)(setq *MIP-MODEMACRO-SCALE* (getint "\nНовый масштабный коэффициент: "))(princ))
(defun C:MC ()(setvar "modemacro" "")(princ))
(defun c:LP ( / txtpoint )(if (and (= (type *MIP-LENGTH*) 'REAL)
(setq txtpoint (getpoint "\n Введите точку вставки текста:")))
(vla-addtext(vla-get-block(vla-get-ActiveLayout(vla-get-ActiveDocument(vlax-get-acad-object)))) 
(rtos *MIP-LENGTH* 2 (getvar "LUPREC"))(vlax-3d-point (trans txtpoint 1 0))3))(princ))

Последний раз редактировалось VVA, 20.09.2015 в 11:33.
VVA вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Размерный стиль по своему слою