[Startrek]

Уважаемые коллеги,
соорудил програмкы для R2005 проставляет AREA цифру, все работает но......
object reactor когда растягиваеш/меняеш полилинию нууууу никак не хочет работать.
Пытаюсь сделать реактор который при изменении полилинии (границы) обновит
FIELD автоматически либо REGEN or FIELDUPDATE.
Подскажите где я маханулся????????
Спасибо заранее.

Код:

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

(defun ufa (notifier-object reactor-object parameter-list)
  (vl-load-com)
  (cond
    (
     (vlax-property-available-p
       notifier-object
       "Area"
     )
      (command "regen" "");;;;;;;problema pomoemu tut???
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun plar(/ pt pt1 pt2)
(setq pt (getpoint"\nStarting Point: "))
(setq pt1 (getpoint pt "\nNext Point: "))
(command "Pline" pt pt1 "")
	(while
 		(setq pt2 (getpoint pt1"\nNext Point: "))
		(command "pline" "" pt2 "")
		(command "pedit" pt "j" pt pt2 "" "")
		(setq pt1 pt2)
	)
(command "pedit" pt "c" "")
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ar5 () 
(vl-load-com) 

  (setq cm (getvar "cmdecho")) 
  (setvar"cmdecho" 0) 
  (setq fd (getvar "fielddisplay")) 
  (if (/= fd 0)(setvar"fielddisplay" 0)) 

    (setq ar1 (entsel "\nSelect Area Boundary: ")) 
    (setq ar2 (car ar1)) 
    (setq tab (vlax-ename->vla-object ar2))
    (setq oba (vla-get-objectid tab)) 

(setq lu (getvar "lunits"))
(setq tpt (getpoint"\nSelect Area Text Point: "))
(cond
((= lu 2) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu6%qf1\">%")))
((= lu 4) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu2%ct4%qf1 SQ. FT.\">%")))
((= lu 5) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu5\">%")))
((= lu 3) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu2%ct4%qf1 SQ. FT.\">%")))
((= lu 1) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu1\">%")))
)
(command "mtext" tpt "w" "0" lin "")

(setq plineReactor (vlr-object-reactor (list tab)  "pline Reactor" '((:vlr-modified . ufa))))

(princ)
)		
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:testarb (/ key)
(initget  1 "Boundary/label-area Label-area")
(setq key (getkword "\nWould you like Boundary/label-area[b] or Label-area<L>: "))
	(cond
	  ((= key "Boundary/label-area")(plar)(ar5))
	  ((= key "Label-area")(ar5))
	)
(princ)
)

[/code]

[{Smirnoff}]

В реагирующих функциях нельзя использовать COMMAND. Есть соответствующий метод через ActiveX.

Код:

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

(setq actDoc
   (vla-get-ActiveDocument
     (vlax-get-acad-object))); получаем VLA-метку активного документа

(vla-Regen actDoc acAllViewports); регенерируем все вьюпорты

(vla-Regen actDoc acActiveViewport) ; или только активный вьпорт

Вообще особо внимательно не смотрел, может еще какая "засада" есть...

[Startrek]

Спасибо, почитал - ты прав, а мне от этой привычки пользоваться kоммандами надо избавлятся.
Попробую..... - посмотрю если сработает, вроде должно
Еще раз спасибо за пинок в нужном направлении.
Может соберусь в Ригу - обязательно вспрыснем

[{Smirnoff}]

Ну ненадо впадать в крайности полностью отказываясь от COMMAND. Если попробуете вычертить например полилинию, то через ActiveX это доставит вам огромные трудности. Или к примеру метод VLA-MOVE не позволяет двигать объект на экране динамически, указывается базовая точка и точка вставки, куда объект моментально и перелетает.

[Startrek]

Ах и ах. Заработать-то заработал реактор да сразу же AutoCAD соскакивает с роликов - FATAL ERROR
А жаль - может я чего не так делаю AGAIN ??????

Код:

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

(defun ufa (notifier-object reactor-object parameter-list)
  (vl-load-com)
  (cond
    ( (vlax-property-available-p
       notifier-object
       "Area"
     )
   (setq actDoc 
   (vla-get-ActiveDocument (vlax-get-acad-object)))
   (vla-Regen actDoc acActiveViewport)

    )
  )
)

(defun uf ()
(command"regen")
)
(defun plar(/ pt pt1 pt2)
(setq pt (getpoint"\nStarting Point: "))
(setq pt1 (getpoint pt "\nNext Point: "))
(command "Pline" pt pt1 "")
	(while
 		(setq pt2 (getpoint pt1"\nNext Point: "))
		(command "pline" "" pt2 "")
		(command "pedit" pt "j" pt pt2 "" "")
		(setq pt1 pt2)
	)
(command "pedit" pt "c" "")
(princ)
)

(defun ar5 () 
(vl-load-com) 

  (setq cm (getvar "cmdecho")) 
  (setvar"cmdecho" 0) 
  (setq fd (getvar "fielddisplay")) 
  (if (/= fd 0)(setvar"fielddisplay" 0)) 

    (setq ar1 (entsel "\nSelect Area Boundary: ")) 
    (setq ar2 (car ar1)) 
    (setq tab (vlax-ename->vla-object ar2))
    (setq oba (vla-get-objectid tab)) 

(setq lu (getvar "lunits"))
(setq tpt (getpoint"\nSelect Area Text Point: "))
(cond
((= lu 2) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu6%qf1\">%")))
((= lu 4) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu2%ct4%qf1 SQ. FT.\">%")))
((= lu 5) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu5\">%")))
((= lu 3) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu2%ct4%qf1 SQ. FT.\">%")))
((= lu 1) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu1\">%")))
)
(command "mtext" tpt "w" "0" lin "")
(setq plineReactor (vlr-object-reactor (list tab)  "pline Reactor" '((:vlr-modified . ufa))))
(princ)
)		

(defun c:testarb (/ key)
(initget  1 "Boundary/label-area Label-area")
(setq key (getkword "\nWould you like Boundary/label-area[b] or Label-area<L>: "))
	(cond
	  ((= key "Boundary/label-area")(plar)(ar5))
	  ((= key "Label-area")(ar5))
	)
(princ)
)

[Torino]

Вот раскопал в туториале, мтожет проблема в этом:

Код:

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

;; The following code removes all reactors when the drawing is
;; closed. This is extremely important!!!!!!!!!
;; Without this notification, AutoCAD may crash upon exiting!
(if (not *DrawingReactor*)
(setq *DrawingReactor*
(VLR-DWG-Reactor
nil ; No data is associated with the drawing reactor
’((:vlr-beginClose . gp:clean-all-reactors)
)
) ;_ end of vlr-DWG-reactor
)
)

Если интересно - могу прислать весь тьюториал: pdf, 12 стр, 166 кБ

[{Smirnoff}]

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

Во вторых имеют свойство множиться что приводит к их одновременной сработке и как результат FATAL ERROR и всякая ерунда.

В случае конкретно с :VLR-OBJECT-REACTOR надо сначала получить список объектов владельцев реактора с помощью:

Код:

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

(setq ownersList(vlr-owners plineReactor)) ; т. е получить список VLA-объектов куда они внесены
; потом удалить их 
(foreach i ownersList
(vlr-owner-remove plineReactor i)
); end foreach
;или по крайней мере не вносить повторно

Прошу прощения, что сразу не стал "врубаться" в тему. В последнее время врываюсь на фору на 3 минуты и улетаю. Да и в реакторах разбираюсь почти как в кислой капусте... Экспериментировал довольно много, но в программах пременяю крайне редко.
[ATTACH]1092084101.gif[/ATTACH]

[{Smirnoff}]

Как всегда забыл главное.

Код:

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

(if(not plineReactor)
(setq plineReactor (vlr-object-reactor .....
);

В общем "каша" получается такая. В первый раз вы создаете VLR-OBJECT-REACTOR и вносите его в определенные примитивы, где он и остается до конца сеанса работы с чертежом. В следующем цикле вы создаете еще один реактор с той же реагирующей функцией и он опять успешно записывается в те же самые примитивы. Таким образом при наступлении соответствующего события они дружно "хором" пытаются сработать. Отключить конкретный реактор можно функцией (vlr-remove plineReactor), отключить все реакторы можно (vlr-remove-all), отключить все реакторы определенного типа (vlr-remove-all :vlr-object-reactor). (vlr-add plineReactor) -снова включит ваш реактор (это для того чтобы можно было временно "выводить их из игры" и снова включать) В общем надо выбирать как действовать в данной ситуации.

Можно по приезде в Ригу и вспрыснуть... Главное чтобы потом разговор на Реакторы не перешел

[Startrek]

АХРГРРР.... Не работает...
Ну и пусть раз они - реакторы такие буки....
А вспрыснуть так точно не мешает - пойдука поупражняюсь, легкая разминке не помешает.
Самое время

[{Smirnoff}]

К сожалению сейчас "снес" 2005 и немогу проверить вашу функцию с полями. Сделал свою тестовую. Надо ткнуть сначала на замкнутом объекте, затем на тексте который в последствии будет меняться в зависимости от площади объекта (см. картинку). Как я понял для изменения значения энтих самых полей надо просто регенерировать чертеж?

Код:

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

(vl-load-com)

(defun reaFun (modObject reacData Arg)
  (vla-put-TextString reaText
    (strcat
      (vlr-data reacData)
	(rtos(vla-get-Area modObject)))) 
(princ)
  );

(defun c:rtest (/ polObj)
  (setq polObj
	 (vlax-ename->vla-object
	   (car
	     (entsel "\nSelect closed object "))))
  (setq reaText
	 (vlax-ename->vla-object
	   (car
	     (entsel "\nSelect text "))))
  (if(not objReact)
    (setq objReact
	   (vlr-object-reactor
	     (list polObj) "Area = "
	     (list '(:vlr-modified . reaFun))))
    ); end if
    (princ)
    );end rtest

[ATTACH]1092257824.gif[/ATTACH]

[{Smirnoff}]

Ну думаю нас можно немного поздравить. Причина вскрылась! Я только что добавил в код реагирующей функции регенерацию. И каков вы думаете был результат? FATAL ERROR и "вылет" КАДА.

Причина теперь ясна. НИЗЯ совать регенерацию в реагирующую функцию.

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

Надо все-таки 2005-й снова поставить...

[Startrek]

Эта версия сработала!
Просьба - погоняйте на разных чертежах уважаемые коллеги, не соскакивает ли AUTOCAD?
Спасибо FANTOMAS огромное - да и легкая разминка (голова до сих пор разламывается, не уважаю виски) вроде тоже не в пустую была.

Код:

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

(defun ufa (notifier-object reactor-object parameter-list) 
  (vl-load-com) 
  (cond 
    ((vlax-property-available-p notifier-object "Area") 
     (setq actDoc 
     (vla-get-ActiveDocument (vlax-get-acad-object))) 
     (vla-SAVE actDoc) 
    ) 
  ) 
) 

(defun plar(/ pt pt1 pt2) 
(setq pt (getpoint"\nStarting Point: ")) 
(setq pt1 (getpoint pt "\nNext Point: ")) 
(command "Pline" pt pt1 "") 
   (while 
       (setq pt2 (getpoint pt1"\nNext Point: ")) 
      (command "pline" "" pt2 "") 
      (command "pedit" pt "j" pt pt2 "" "") 
      (setq pt1 pt2) 
   ) 
(command "pedit" pt "c" "") 
(princ) 
) 

(defun ar5 () 
(SETQ A NIL)
(vl-load-com) 

  (setq cm (getvar "cmdecho")) 
  (setvar"cmdecho" 0) 
  (setq fd (getvar "fielddisplay")) 
  (if (/= fd 0)(setvar"fielddisplay" 0)) 

    (setq ar1 (entsel "\nSelect Area Boundary: ")) 
    (setq ar2 (car ar1)) 
    (setq tab (vlax-ename->vla-object ar2)) 
    (setq oba (vla-get-objectid tab)) 

(setq lu (getvar "lunits")) 
(setq tpt (getpoint"\nSelect Area Text Point: ")) 
(cond 
((= lu 2) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu6%qf1\">%"))) 
((= lu 4) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu2%ct4%qf1 SQ. FT.\">%"))) 
((= lu 5) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu5\">%"))) 
((= lu 3) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu2%ct4%qf1 SQ. FT.\">%"))) 
((= lu 1) (setq lin (strcat "%<\\AcObjProp Object(%<\\_ObjId " (rtos oba 2 0) ">%).Area \\f \"%lu1\">%"))) 
) 
(command "mtext" tpt "w" "0" lin "") 
(setq plineReactor (vlr-object-reactor (list tab)  "pline Reactor" '((:vlr-modified . ufa))))

(princ) 
)       

(defun c:tarb (/ key) 
(initget  1 "Boundary/label-area Label-area") 
(setq key (getkword "\nWould you like Boundary/label-area[b] or Label-area<L>: ")) 
   (cond 
     ((= key "Boundary/label-area")(plar)(ar5)) 
     ((= key "Label-area")(ar5)) 
   ) 
(princ) 
)

И еще одна програмка по аналогии для образмеривания ARC - тоже паботает

Код:

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

(defun ufa (notifier-object reactor-object parameter-list) 
  (vl-load-com) 
  (cond 
    ((vlax-property-available-p notifier-object "area") 
     (setq actDoc 
     (vla-get-ActiveDocument (vlax-get-acad-object))) 
     (vla-save actDoc) 
    ) 
  ) 
) 

(defun c:tadim (/ cm fd ar1 ar2 ar3 tab oba) 
(vl-load-com) 

  (setq cm (getvar "cmdecho")) 
  (setvar"cmdecho" 0) 
  (setq fd (getvar "fielddisplay")) 
  (if (/= fd 0)(setvar"fielddisplay" 0)) 

    (setq ar1 (entsel "\nSelect an Arc: ")) 
    (setq ar2 (car ar1)) 
    (setq tab (vlax-ename->vla-object ar2))
    (setq oba (vla-get-objectid tab)) 
    (setq ar3 (strcat "%<\\AcObjProp Object(%<\\_ObjId " 
                      (rtos oba 2 0) 
                      ">%).ArcLength \\f \"%.30q0\">%"))
    (command "dimangular" ar1 "t" ar3 pause) 

    (setq dimReactor (vlr-object-reactor (list tab)  "dim Reactor" '((:vlr-modified . ufa))))

  (setvar"fielddisplay" fd) 
  (setvar "cmdecho" cm) 	

(princ)
)

[{Smirnoff}]

Давно не пил виски... Пойти что ли... До VLA-SAVE не додумался. Моя "тестовая" не слетает. Думаю все ОК!

[Startrek]

Эх жаль что мы так далеко - у меня есть в заначке бутылек "Столичной" еще с застойных времен,
высшего класса...... И черт с ним с этим виски....

[{Smirnoff}]

Я ограничился пивом "Лачплесис". Если помнишь мужик такой латышско-мифологический с ушами медвежими...

Завтра последний рабочий день и потом месяц отпуска. Буду в Юрмале на пляже загорать, как раз недалеко от известной тебе школы №2. Там многое поменялось. Спилили тополиную аллею около дороги, а сразу за школьным стадионом супермаркет... На пляже везде биотуалеты, мало кто поливает большой дуб по дороге к морю. Боюсь засохнет...

[Startrek]

Ну как же не помнить Лачплесис - раааскошное пивцо, мы его из боченка тянули в колхозе-миллионере "Лачплесис" в финской баньке..... ну ооочень даже хорошие воспомонания. Послушай а что сделали с маленьким придатком к школе где начальные классы были....я там на Новый год (1975) ээээ дежурил с Валечкой - вот не помню чего она там преподавала и Ларисой она учила Пение в младших классах, пришли десятикласники ох и надежурились мы сообща пели под гитару и на звонки из ГОРОНО отвечали почти твердым голосом ....тихо все мол и эта ... спокойно. Хм.
Yважаемый Админ. - прошу прощение за лирические отступления от прекрасного топика REAKTORS.

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

А школьников спаивать нехорошо... Вот ты оказывается каким учителем был :shock:

В Лелварде на заводе где варят "Лачплесис" тоже бывал, не раз...

Ухожу я в отпуск. Можно пожелать мне приятного отдыха...

Разве что в интернет кафе зайду чтобы сползать сюда и почту проверить.

[Startrek]

Хм мы под гитары не пили а "пели"
Ну счастливо отдохнуть, а я уже забыл что такое отпуск, лет 7 как не брал больше чем 1-3 дня.
И вообще мой отпуск максимум 10 рабочих дней в год, в сентябре будет 10лет как в компании - так прибавят еще 5 рабночих дней
ОДДЫХАЙ, загорай, итд.

[{Smirnoff}]

Извиняйте... Неправильно понял. Ну все, я поледние два часа в своей городской квартире...