TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: T.Willey on February 14, 2006, 05:24:47 PM
-
How do you tell if a reactor is associated to an object, when you only have the object? I have one I'm working on, just a learning thing, and it seems to work well, but I want to be able to see if one is attached already. I can post the code if needs be. Right now it's just the basic associate a text object to a polyline.
Thanks for any help. On second though, here is the code.
(defun c:AreaReact (/ Sel EntData PolyObj TextObj)
;| Adds a presistant reactor to a polyline object that
updates a selected text object to the polylines area
in square feet. You will have to have the subs loaded
in everydrawing for it to work, so that it know what
to do with the reactor, because it is saved with the
drawing. Saves the association between the text
and the polyline in the extension dictionary of the
polyline.
|;
(if
(and
(setq Sel (entsel "\n Select polyline to get area of: "))
(setq EntData (entget (car Sel)))
(= (cdr (assoc 0 EntData)) "LWPOLYLINE")
(setq PolyObj (vlax-ename->vla-object (car Sel)))
(setq Sel (entsel "\n Select text of hold area value: "))
(setq EntData (entget (car Sel)))
(vl-position (cdr (assoc 0 EntData)) '("TEXT" "MTEXT"))
(setq TextObj (vlax-ename->vla-object (car Sel)))
)
(progn
(PutArea PolyObj TextObj)
(vlr-pers (vlr-object-reactor (list PolyObj) nil '((:vlr-modified . MakeCmdEndReactor))))
)
)
(princ)
)
;---------------------------------------------------------------------------------------------------------------
(defun PutArea (PolyObj TextObj / Dict xRec SqFt)
(setq Dict (vla-GetExtensionDictionary PolyObj))
(if (vl-catch-all-error-p (setq xRec (vl-catch-all-apply 'vla-Item (list Dict "MyAreaReactor"))))
(setq xRec (vla-AddXRecord Dict "MyAreaReactor"))
)
(MySetXrec xRec '(40 1) (list (vlax-get PolyObj 'Area) (vlax-get TextObj 'Handle)))
(setq SqFt (/ (vla-get-Area PolyObj) 144.0))
(vla-put-TextString TextObj (strcat (rtos SqFt 2 2) " SQ.FT."))
xRec
)
;----------------------------------------------------------------------------------------------------------------
(defun MakeCmdEndReactor (Obj React NotSure)
(setq GlbVarAreaObject Obj)
(if (not GlbReactorCommandEnd)
(setq GlbReactorCommandEnd (vlr-command-reactor nil '((:vlr-commandEnded . AdjustTextObj))))
)
(princ)
)
;-----------------------------------------------------------------------------------------------------------------
(defun AdjustTextObj (React CommandList / Dict xRec xRecList TextObj)
(if
(and
GlbVarAreaObject
(not (vlax-erased-p GlbVarAreaObject))
)
(progn
(setq Dict (vla-GetExtensionDictionary GlbVarAreaObject))
(if (not (vl-catch-all-error-p (setq xRec (vl-catch-all-apply 'vla-Item (list Dict "MyAreaReactor")))))
(progn
(setq xRecList (MyGetXRec xRec))
(if
(and
(setq TextObj (vlax-ename->vla-object (setq tmpEnt (handent (cdr (assoc 1 xRecList))))))
(not (vlax-erased-p TextObj))
)
(PutArea GlbVarAreaObject TextObj)
)
)
)
(setq GlbVarAreaObject nil)
)
)
(setq GlbReactorCommandEnd nil)
)
;---------------------------------------------------------------------------
(defun MySetXRec (Obj CodeList DataList / )
; Sets XRecordData. Dxf numbers between 1-369, except 5, 100, 105.
; See help for types and numbers to use.
(vla-SetXRecordData Obj
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbInteger
(cons 0 (1- (length CodeList)))
)
CodeList
)
)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbVariant
(cons 0 (1- (length Datalist)))
)
DataList
)
)
)
)
;-----------------------------------------------------------------------------
(defun MyGetXRec (Obj / CodeType DataType)
; Retrive XRecordData for an object
(vla-GetXRecordData
Obj
'CodeType
'DataType
)
(if (and CodeType DataType)
(mapcar
'(lambda (a b)
(cons a (variant-value b))
)
(safearray-value CodeType)
(safearray-value DataType)
)
)
)
-
No time to read all your code....
Here is a little function that might be useful:
(defun rwiz-partof (obj / obj_reactors)
(if (setq obj_reactors
(cdar (vlr-reactors :vlr-object-reactor)))
(vl-some
(function (lambda (n) (numberp n)))
(mapcar
(function (lambda (r) (vl-position obj (vlr-owners r))))
obj_reactors))))
-
I guess a side question would be:
Is it safe to assume that the handles for objects won't change when opening and closing a drawing? Right now on my test drawing, two polylines and two pieces of text, they dont' seem to change, but I'm not sure about large scale drawings. I'm storing the handles (of the text objects) in the extension dictionary of the polyline objects so that I know which ones to update.
Thanks in advance.
-
Here is a little function that might be useful:
Thanks Luis. I think that gave me a great idea how to do it. Let you know what happens.
-
I guess a side question would be:
Is it safe to assume that the handles for objects won't change when opening and closing a drawing? Right now on my test drawing, two polylines and two pieces of text, they dont' seem to change, but I'm not sure about large scale drawings. I'm storing the handles (of the text objects) in the extension dictionary of the polyline objects so that I know which ones to update.
Thanks in advance.
You can use directly the built-in mechanism of VLR-PERS owners are saved in the (vlr-pers-dictname) = "VL-REACTORS"
-
The only problem of using VLR-PERS is that is not easy to know how to update the list of persistent reactors in vlr-pers-list...
-
Since I am in a good samaritan mode... and now I know that very few have downloaded and study what I did on this post:
http://www.theswamp.org/forum/index.php?topic=8327.0
I am going to removed the ZIP.... so if you want, grab it and look what I did to emulate what the VLR-PERS function does .... very simple mickey mouse solution... that really works and can be extended or make it better.... 10, 9, 8, 7, 6, :evil: :roll:
-
...5, 4, 3, 2, ...... :evil: :lmao:
-
Since I am in a good samaritan mode... and now I know that very little have downloaded and study what I did on this post:
http://www.theswamp.org/forum/index.php?topic=8327.0
I am going to removed the ZIP.... so if you want, grab it and look what I did to emulate what the VLR-PERS function does .... very simple mickey mouse solution... that really works and can be extended or make it better.... 10, 9, 8, 7, 6, :evil: :roll:
I was the first to test that one out. You did it for me like a year or so ago on the Adesk help group. You only could give it out as a vlx, so I couldn't learn from it at that time. I thought it was still in vlx form, so I didn't grab it. But thanks for letting me get it before you took it away.
I'm still trying to understand dictionaries, so I'm looking what you posted before and trying to grasp it. Here is the little one I just wrote to see if an object has an object reactor associated to it. Based on your quidence. Whick I very much appreciate. Thanks again.
(defun AssociatedReactors (Obj / ReactList)
(foreach i (vlr-reactors :vlr-object-reactor)
(if (vl-position Obj (vlr-owners (cadr i)))
(setq ReactList (cons (cadr i) ReactList))
)
)
ReactList
)
-
That was a joke...
The function looks good to me.... if the object is part of more than one...
I used my function, to test before passing the object as part of an object reactor.
The last object reactors I end up using VLR-PERS and handle everything inside of the "VL-REACTORS" dictionary...
Have fun!!!
-
That was a joke...
The function looks good to me.... if the object is part of more than one...
I used my function, to test before passing the object as part of an object reactor.
The last object reactors I end up using VLR-PERS and handle everything inside of the "VL-REACTORS" dictionary...
Have fun!!!
Thanks for the help, and the reviewal (not sure if it's a word, but sounds cool) of my code. I think I'm getting the hang of it a little better.
-
Once, you have all your code done.... do this:
1. Open a drawing and run your code
2. Save an open it again, and see if the reactors are running, and call again your code to generate a new reactor, and save the drawing again.
3. Open that drawing and now, erase the polyline.... what happens?
-
Once, you have all your code done.... do this:
1. Open a drawing and run your code
2. Save an open it again, and see if the reactors are running, and call again your code to generate a new reactor, and save the drawing again.
3. Open that drawing and now, erase the polyline.... what happens?
It seems to be working fine. But then again I have changed it, so that is there is an existing reactor associate to the polyline, that has the name of mine (new feature in the code, not posted) then it erases that one, and associates a new one. Even the dictionary "VL-REACTORS" has only one for the count, when I opened the drawing it had two.
I'm still writing the code, but I can post it if you want. I saw that I should associate and erase reactor to the object, but it seems like the way it is written now that it is not needed. Am I missing something.
-
I think I'm done. If anyone wants to test it, be my guest, but same precautions as always, test in a test drawing, not a production drawing. Let me know how it works for you.
(defun c:AreaReact (/ Sel EntData PolyObj TextObj ReactList Pos)
;| Adds a presistant reactor to a polyline object that
updates a selected text object to the polylines area
in square feet. You will have to have the subs loaded
in everydrawing for it to work, so that it know what
to do with the reactor, because it is saved with the
drawing. Saves the association between the text
and the polyline in the extension dictionary of the
polyline.
|;
(if
(and
(setq Sel (entsel "\n Select polyline to get area of: "))
(setq EntData (entget (car Sel)))
(= (cdr (assoc 0 EntData)) "LWPOLYLINE")
(setq PolyObj (vlax-ename->vla-object (car Sel)))
(setq Sel (entsel "\n Select text of hold area value: "))
(setq EntData (entget (car Sel)))
(vl-position (cdr (assoc 0 EntData)) '("TEXT" "MTEXT"))
(setq TextObj (vlax-ename->vla-object (car Sel)))
)
(progn
(PutArea PolyObj TextObj)
(if
(and
(setq ReactList (AssociatedReactors PolyObj))
(setq Pos (vl-position "MyAreaReactor" (mapcar 'vlr-data ReactList)))
)
(vlr-remove (nth Pos ReactList))
)
(vlr-pers (vlr-object-reactor (list PolyObj) "MyAreaReactor" '((:vlr-modified . MakeCmdEndReactor))))
)
)
(princ)
)
;---------------------------------------------------------------------------------------------------------------
(defun PutArea (PolyObj TextObj / Dict xRec SqFt)
(setq Dict (vla-GetExtensionDictionary PolyObj))
(if (vl-catch-all-error-p (setq xRec (vl-catch-all-apply 'vla-Item (list Dict "MyAreaReactor"))))
(setq xRec (vla-AddXRecord Dict "MyAreaReactor"))
)
(MySetXrec xRec '(40 1) (list (vlax-get PolyObj 'Area) (vlax-get TextObj 'Handle)))
(setq SqFt (/ (vla-get-Area PolyObj) 144.0))
(vla-put-TextString TextObj (strcat (rtos SqFt 2 2) " SQ.FT."))
xRec
)
;----------------------------------------------------------------------------------------------------------------
(defun MakeCmdEndReactor (Obj React NotSure)
(setq GlbVarAreaObject Obj)
(if (not GlbReactorCommandEnd)
(setq GlbReactorCommandEnd (vlr-command-reactor nil '((:vlr-commandEnded . AdjustTextObj))))
)
(princ)
)
;-----------------------------------------------------------------------------------------------------------------
(defun AdjustTextObj (React CommandList / Dict xRec xRecList TextObj)
(if
(and
GlbVarAreaObject
(not (vlax-erased-p GlbVarAreaObject))
)
(progn
(setq Dict (vla-GetExtensionDictionary GlbVarAreaObject))
(if (not (vl-catch-all-error-p (setq xRec (vl-catch-all-apply 'vla-Item (list Dict "MyAreaReactor")))))
(progn
(setq xRecList (MyGetXRec xRec))
(if
(and
(setq TextObj (vlax-ename->vla-object (setq tmpEnt (handent (cdr (assoc 1 xRecList))))))
(not (vlax-erased-p TextObj))
)
(PutArea GlbVarAreaObject TextObj)
)
)
)
(setq GlbVarAreaObject nil)
)
)
(setq GlbReactorCommandEnd nil)
)
;---------------------------------------------------------------------------
(defun MySetXRec (Obj CodeList DataList / )
; Sets XRecordData. Dxf numbers between 1-369, except 5, 100, 105.
; See help for types and numbers to use.
(vla-SetXRecordData Obj
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbInteger
(cons 0 (1- (length CodeList)))
)
CodeList
)
)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbVariant
(cons 0 (1- (length Datalist)))
)
DataList
)
)
)
)
;-----------------------------------------------------------------------------
(defun MyGetXRec (Obj / CodeType DataType)
; Retrive XRecordData for an object
(vla-GetXRecordData
Obj
'CodeType
'DataType
)
(if (and CodeType DataType)
(mapcar
'(lambda (a b)
(cons a (variant-value b))
)
(safearray-value CodeType)
(safearray-value DataType)
)
)
)
;-------------------------------------------------------------------------------------
(defun AssociatedReactors (Obj / ReactList)
; Return a list of reactors (object type) associated with an object.
(foreach i (vlr-reactors :vlr-object-reactor)
(if (vl-position Obj (vlr-owners (cadr i)))
(setq ReactList (cons (cadr i) ReactList))
)
)
ReactList
)
-
Tim;
Press F2 after opening the drawing where you have the areas [erase one of the plines that belongs to a reactor]
What is the error message?
Is this:
; warning:erased VLA-object restored to NIL
-
Also... try to grip two plines and do a stretch... just one text is updated no?
-
Yup. I see it now. I guess I have to have an erase reactor? I will look at how to do that. Thanks for pointing that one out. Back to the drawing board.
This is fun for me though. I'm having a good time figuring this out while working on my "REAL" work.
Also... try to grip two plines and do a stretch... just one text is updated no?
You are right again. I should have thought of that one also. I will see what I can do. Thanks again Luis.
-
I guess I have to have an erase reactor?
Yes... and what I mentioned on my third post here... in case you find out difficult to update the VL-REACTORS list... I can help on that... but try it first.... I know you are a very smart person... keep the good programming coming.
-
I hope not to derail this thread by posting an alternate solution.
I notice you are using the Object Reactor to store the area and the handle of the text in an extension dictionary of the polyline object and then creating a Command Reactor that is doing the modification to the text when the :vlr-CommandEnded callback fires. You can do this all at once with just the Object Reactor on the Polyline object by storing the area of the Polyline and the handle of the text in the client data of the reactor object and the modifying the text when the :vlr-ObjectClosed callback fires.
You can set and retreive this data using the VLR-Data-Set and VLR-Data functions respectivelly, and you can also use it to store a flag for what to do when the object is closed, to handel the polyline getting deleted.
When you create your reactor, store the initial data and have it react to all situations:
(VLR-Object-Reactor
(List (VLAX-EName->VLA-Object PolylineObject))
(List '(0 . 0) ;modify flag
(Cons 1 PolylineArea ) ;area of polyline
(Cons 2 TextObjectHandle) ;handle of the text object
)
'((:vlr-Cancelled . Pline_Cancelled-Callback )
(:vlr-Modified . Pline_Modified-Callback )
(:vlr-Copied . Pline_Copied-Callback )
(:vlr-Erased . Pline_Erased-Callback)
(:vlr-UnErased . Pline_UnErased-Callback )
(:vlr-ObjectClosed . Pline_ObjectClosed-Callback )
)
)
Put (vlr-trace-reaction) in all of the callbacks and watch the order in whice they come down. When the object is modified :vlr-Modified fires then :vlr-ObjectClosed. When the object is erased :vlr-Modified fires, then :vlr-Erased, then :vlr-ObjectClosed fires.
You cannot rely on the order in which the callbacks will fire, especially when modifying multiple objects at once. The :vlr-ObjectClosed will always fire when the object is closed for editing. You use the other callbacks to over-write the modify flag in the client data of the reactor object and then retreive it to determine what the Pline_ObjectClosed-Callback function will do. The Pline_Modified-Callback function will store the area of the polyline into the 1 dotted-pair of the association list.
If you want to go down this tangent, I can post lots of code snipettes, since I just finished writing a reactor that linked a lable with an object and maintained it when the object changed. It also had to take into account not only when the object was erased and brought back with the OOPS or Undo Commands (:vlr-UnErased), but also when the object and lable were copied and the new label had to become linked to the new object.
-
Thanks zoltan. Let me try some stuff first, as I seem to learn by doing with this type of stuff. There is a lot to digest in your post, and since this is my first real reactor, I don't understand it all with my first read, but it looks like something I can do. I'll post back if I get stuck. Thanks again.
-
Tim
I tried your routine, and found it to be non persistant. I probably did something wrong. Anyway here is what I'm using.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;; Reactor Link Activex Function ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ARCH:LinkActiveX ()
(vl-load-com)
(if (null modelSpace)
(setq acadApp (vlax-get-acad-object)
docObj (vla-get-activedocument acadApp)
modelSpace (vla-get-modelspace docObj))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;; Area Link Reactor for ARCH_AREALINK Function ;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ARCH:AreaLinkFix-Acre (nObj rObj pList / Objs vObj tObj)
(if (vlax-property-available-p nObj "AREA")
(progn (setq NewArea (vla-get-area nObj)
Objs (vlr-owners rObj))
(foreach
vObj Objs
(if (vlax-property-available-p vObj "TEXTSTRING")
(setq tObj vObj)))
(if tObj
(vla-put-textstring
tObj
(strcat (rtos (/ NewArea 43560) 2 (getvar "useri4")) " ARCES"))))))
(defun ARCH:AreaLinkFix-SF (nObj rObj pList / Objs vObj tObj)
(if (vlax-property-available-p nObj "AREA")
(progn (setq NewArea (vla-get-area nObj)
Objs (vlr-owners rObj))
(foreach
vObj Objs
(if (vlax-property-available-p vObj "TEXTSTRING")
(setq tObj vObj)))
(if tObj
(vla-put-textstring
tObj
(strcat (rtos (/ NewArea 144) 2 (getvar "useri4")) " S.F."))))))
;;;
(defun ARCH:AreaLinkFix (nObj rObj pList / Objs vObj tObj)
(if (vlax-property-available-p nObj "AREA")
(progn (setq NewArea (vla-get-area nObj)
Objs (vlr-owners rObj))
(foreach
vObj Objs
(if (vlax-property-available-p vObj "TEXTSTRING")
(setq tObj vObj)))
(if tObj
(vla-put-textstring tObj (strcat (rtos (/ NewArea 144) 2 1) " S.F."))))))
;;;AutoCADET's Guide to Visual LISP - Chapter 16 Example Function Set
;;;Bill Kramer 2001
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun C:AREALINKIT ()
(initget "A S")
(setq tmp1
(getkword
"\n* Select Area Type: <A>creage <S>quare Footage *"
)
)
(initget 7) ;;disallow null,zero & negative
(cond
((= tmp1 "A")(AREALINK-IT 43560 2 " ACRES"))
((or(= tmp1 "S")(= tmp1 nil))(AREALINK-IT 144 1 " S.F."))
)
(princ)
)
(defun AREALINK-IT (AA DD NN / ENP ENT V_ENP V_ENT)
(ARCH:LinkActiveX) ;;ARCH_SUBROUTINES
;;(ARCH:F_S-VAR)
(setq ENP (entsel (strcat "\n* Select" NN " Polyline Boundary *")))
(if ENP
(progn
(setq V_ENP
(vlax-ename->vla-object (car ENP))
)
(if (vlax-property-available-p
V_ENP
"AREA"
)
(progn
(setq ENT (getpoint (strcat "\n* Pick" NN " Text insertion point *")))
;;(ARCH:LYR "A-AREA")
;;(ARCH:SET-AREA)
(if ENT
(progn
(setq V_ENT
(vla-addtext
modelSpace
(strcat (rtos (/ (vla-get-area V_ENP) AA) 2 DD) NN)
(vlax-3d-point ENT)
;;(* (getvar "TEXTSIZE") 0.667)
ARCH#SC-T
)
)
(cond
((= tmp1 "A")
(setq ARCHAREA
(vlr-object-reactor
(list V_ENP V_ENT)
"AreaConnect"
'((:vlr-modified . ARCH:AreaLinkFix-Acre)) ;;ARCH_SUBROUTINES
)
)
)
((or (= tmp1 "S")(= tmp1 nil))
(setq ARCHAREA
(vlr-object-reactor
(list V_ENP V_ENT)
"AreaConnect"
'((:vlr-modified . ARCH:AreaLinkFix-SF)) ;;ARCH_SUBROUTINES
)
)
)
)
)
)
)
)
)
)
(vlr-pers ARCHAREA)
;;(vlr-pers-p ARCHAREA)
;;(vlr-pers-list)
;;(ARCH:F_R-VAR)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(princ)
Gary
-
Tim
I tried your routine, and found it to be non persistant. I probably did something wrong. Anyway here is what I'm using.
The first one I posted was not, but the second one was, but it still could be done better. Thanks for posting the code will look at it when I have a chance. Real work has come my way.
-
zoltan -
I tried to go your way, but I couldn't do it. I kept getting and error about object is notifying, or something like that.
This seems to work on my test drawing. The only problem I experienced is when I didn't have the lisp file loading upon opening the drawing, then I would get errors. Is there anyway to stop that? Say you send out your drawings to other people, and you have reactors, but they don't have those reactor routines. How can you have it set up so it doesn't error? I'm sure there is a slick way that I haven't though of yet, so if anyone knows, please let me know.
Thanks again to all who helped me.
(defun c:AreaReact (/ Sel EntData PolyObj TextObj ReactList Pos)
;| Adds a presistant reactor to a polyline object that
updates a selected text object to the polylines area
in square feet. You will have to have the subs loaded
in everydrawing for it to work, so that it know what
to do with the reactor, because it is saved with the
drawing. Saves the association between the text
and the polyline in the extension dictionary of the
polyline.
Thanks to Luis Esquivel for his help and guidance.
|;
(if
(and
(setq Sel (entsel "\n Select polyline to get area of: "))
(setq EntData (entget (car Sel)))
(= (cdr (assoc 0 EntData)) "LWPOLYLINE")
(setq PolyObj (vlax-ename->vla-object (car Sel)))
(setq Sel (entsel "\n Select text of hold area value: "))
(setq EntData (entget (car Sel)))
(vl-position (cdr (assoc 0 EntData)) '("TEXT" "MTEXT"))
(setq TextObj (vlax-ename->vla-object (car Sel)))
)
(progn
(PutArea PolyObj TextObj)
(if
(and
(setq ReactList (AssociatedReactors PolyObj))
(setq Pos (vl-position "MyAreaReactorModified" (mapcar 'vlr-data ReactList)))
)
(vlr-remove (nth Pos ReactList))
)
(vlr-pers
(vlr-object-reactor
(list PolyObj)
"MyAreaReactorModified"
'(
(:vlr-modified . MakeCmdEndReactor)
(:vlr-erased . ObjectEraseReactor)
(:vlr-unerased . ObjectUnErasedReactor)
)
)
)
)
)
(princ)
)
;---------------------------------------------------------------------------------------------------------------
(defun PutArea (PolyObj TextObj / Dict xRec SqFt)
(setq Dict (vla-GetExtensionDictionary PolyObj))
(if (vl-catch-all-error-p (setq xRec (vl-catch-all-apply 'vla-Item (list Dict "MyAreaReactor"))))
(setq xRec (vla-AddXRecord Dict "MyAreaReactor"))
)
(MySetXrec xRec '(40 1) (list (vlax-get PolyObj 'Area) (vlax-get TextObj 'Handle)))
(setq SqFt (/ (vla-get-Area PolyObj) 144.0))
(vla-put-TextString TextObj (strcat (rtos SqFt 2 2) " SQ.FT."))
xRec
)
;----------------------------------------------------------------------------------------------------------------
(defun MakeCmdEndReactor (Obj React NotSure)
(if GlbVarAreaObject
(setq GlbVarAreaObject (append GlbVarAreaObject (list Obj)))
(setq GlbVarAreaObject (list Obj))
)
(if (not GlbReactorCommandEnd)
(setq GlbReactorCommandEnd (vlr-command-reactor nil '((:vlr-commandEnded . AdjustTextObj))))
)
(princ)
)
;------------------------------------------------------------------------------------------------------------------
(defun ObjectEraseReactor (Obj React NotSure)
(vlr-pers-release React)
(vlr-remove React)
(setq GlbReactorCommandEnd nil)
)
;-----------------------------------------------------------------------------------------------------------------
(defun ObjectUnErasedReactor (Obj React NotSure)
(vlr-pers
(vlr-object-reactor
(list Obj)
"MyAreaReactorModified"
'(
(:vlr-modified . MakeCmdEndReactor)
(:vlr-erased . ObjectEraseReactor)
(:vlr-unerased . ObjectUnErasedReactor)
)
)
)
(setq GlbReactorCommandEnd nil)
)
;-----------------------------------------------------------------------------------------------------------------
(defun AdjustTextObj (React CommandList / Dict xRec xRecList TextObj)
(foreach Obj GlbVarAreaObject
(if (not (vlax-erased-p Obj))
(progn
(setq Dict (vla-GetExtensionDictionary Obj))
(if (not (vl-catch-all-error-p (setq xRec (vl-catch-all-apply 'vla-Item (list Dict "MyAreaReactor")))))
(progn
(setq xRecList (MyGetXRec xRec))
(if
(and
(setq TextObj (vlax-ename->vla-object (setq tmpEnt (handent (cdr (assoc 1 xRecList))))))
(not (vlax-erased-p TextObj))
)
(PutArea Obj TextObj)
)
)
)
)
)
)
(setq GlbVarAreaObject nil)
(setq GlbReactorCommandEnd nil)
)
;---------------------------------------------------------------------------
(defun MySetXRec (Obj CodeList DataList / )
; Sets XRecordData. Dxf numbers between 1-369, except 5, 100, 105.
; See help for types and numbers to use.
(vla-SetXRecordData Obj
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbInteger
(cons 0 (1- (length CodeList)))
)
CodeList
)
)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbVariant
(cons 0 (1- (length Datalist)))
)
DataList
)
)
)
)
;-----------------------------------------------------------------------------
(defun MyGetXRec (Obj / CodeType DataType)
; Retrive XRecordData for an object
(vla-GetXRecordData
Obj
'CodeType
'DataType
)
(if (and CodeType DataType)
(mapcar
'(lambda (a b)
(cons a (variant-value b))
)
(safearray-value CodeType)
(safearray-value DataType)
)
)
)
;-------------------------------------------------------------------------------------
(defun AssociatedReactors (Obj / ReactList)
; Return a list of reactors (object type) associated with an object.
; Use like (AssociatedReactors (vlax-ename->vla-object (car (entsel))))
(foreach i (cdar (vlr-reactors :vlr-object-reactor))
(if (vl-position Obj (vlr-owners i))
(setq ReactList (cons i ReactList))
)
)
ReactList
)
;---------------------------------------------------------------------------
(defun RemovePersReact ()
; Remove persistant reactors that don't have an owner.
(foreach i (vlr-pers-list)
(if (not (vlr-owners i))
(progn
(vlr-pers-release i)
(vlr-remove i)
)
)
)
)
-
Tim
I tried your new version...I like it. I retested my routine and yours for adding a vertice to the pline. This broke the reactor linkage.
I sure wish ther was a way ti fix this so that it would work with adding new vertices to the pline.
Gary
-
I don't have a routine like that yet, so post yours if you can, and I will test it to see what happens.
Thanks for testing it.
-
Tim
I just remembered Peter has a lispmacro routine taht might do the trick.
From his text file:
Use the vba man to embed the lispmacro.dvb macro into a drawing.
Then load the lispmacro.lsp and dcl files into the lispmacro dialog box.
Then embed any lisp files you need
Peter Jamtgaard
Gary
-
Tim
Here is the routine I use for adding a vertice to a pline. This breaks the reactor link.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This original Copyrighted routine has been modified...
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;ADV.LSP ADD VERTEX TO POLYLINE (C)2002, Aniyam Kandiyil
;;;ADDS VERTEX TO A POLYLINE WITHOUT LOOSING XDATA
;;;(command "convertpoly")
(defun c:ADV ()
(setvar "CMDECHO" 0)
(setq PK_PLN (entsel
"\n* Pick Lightweight Polyline at point to add Vertex and Stretch *"))
(cond ((= (cdr (assoc 0 (entget (car PK_PLN)))) "LWPOLYLINE") (ADV-IT2))
;|((/= (cdr (assoc 0 (entget (car PK_PLN)))) "LWPOLYLINE")
(progn
(setq Result (ARCH:WARNING
"Do you want to covert the selected\n"
"Polyline from a Heavy to a Lightweight\n"
"Polyline?\n\n"
"Please select an option below...\n"
)
)
)
) |;
((/= (cdr (assoc 0 (entget (car PK_PLN)))) "LWPOLYLINE")
(progn (command "convertpoly" "l" PK_PLN "") (ADV-IT2))))
;;(cond
;;((= 0 Result) (progn (command "convertpoly" "l" PK_PLN "")(ADV-IT2)))
;;((= 1 Result) (ARCH:CANCEL))
;;)
(princ))
(defun ADV-IT1 ()
(setvar "CMDECHO" 0)
(while (or (not (setq PK_PLN
(entsel
"\n* Pick Lightweight Polyline at point to add Vertex and Stretch: *")))
(/= (cdr (assoc 0 (entget (car PK_PLN)))) "LWPOLYLINE"))
(ARCH:ALERT-Q
"MsgBox \"You did not select a Lightweight Polyline.\nPlease try again.\""))
(ADV-IT2)
(princ))
(defun ADV-IT2 (/ CR_LYR PL_LST XD_LST PL_OPN PL_LYR PK_PNT NR_PNT NE_PNT EN_PNT AN_MID
EN_PNT EN_PNT1 EN_PNT2 VTX_LST)
(setq CR_LYR (getvar "CLAYER")
PL_LST (entget (car PK_PLN))
PL_WID (cdr (assoc 40 PL_LST))
XD_LST (assoc -3 (entget (car PK_PLN) (list "*")))
PL_OPN (cdr (assoc 70 PL_LST))
PL_LYR (cdr (assoc 8 PL_LST))
PC_PNT (cadr PK_PLN)
PK_PNT (osnap PC_PNT "mid")
NR_PNT (osnap PC_PNT "nea")
NE_PNT (list (car PK_PNT) (cadr PK_PNT))
EN_PNT (osnap PC_PNT "end")
AN_MID (angle PK_PNT EN_PNT)
EN_PNT1 (list (car EN_PNT) (cadr EN_PNT))
EN_PNT (polar PK_PNT (+ AN_MID pi) (distance PK_PNT EN_PNT))
EN_PNT2 (list (car EN_PNT) (cadr EN_PNT))
VTX_LST ()) ;_ end of setq
(foreach
N PL_LST
(if (= (car N) 10)
(setq VTX_LST (append VTX_LST (list (cdr N))))) ;_ end of if
) ;_ end of foreach
(RVS_VTX)
(entdel (car PK_PLN))
(setvar "CLAYER" PL_LYR)
(setvar "PLINEWID" PL_WID)
(command ".PLINE" (foreach PT NVTX_LST (command PT)))
(if (= PL_OPN 1)
(command ".pedit" (entlast) "c" "")) ;_ end of if
(if XD_LST
(progn (setq OBJ_LST (entget (entlast)))
(setq OBJ_LST (append OBJ_LST (list XD_LST)))
(entmod OBJ_LST)) ;_ end of progn
) ;_ end of if
(setvar "CLAYER" CR_LYR)
(command "stretch" "c" NR_PNT NR_PNT "" NR_PNT)
(princ)) ;_ end of defun
(defun RVS_VTX ()
(setq NVTX_LST ())
(setq FOUND NIL)
(setq N 0)
(setq NTH_VTX1 (nth N VTX_LST))
(setq NTH_VTX2 (nth (+ N 1) VTX_LST))
(while (and NTH_VTX1 NTH_VTX2)
(progn (if (not (member NTH_VTX1 NVTX_LST))
(setq NVTX_LST (append NVTX_LST (list NTH_VTX1)))) ;_ end of if
(FMIDP NTH_VTX1 NTH_VTX2)
(if (and (not (member NR_PNT NVTX_LST))
(= (car MIDPNT) (car NE_PNT))
(= (cadr MIDPNT) (cadr NE_PNT))) ;_ end of and
(setq NVTX_LST (append NVTX_LST (list NR_PNT)))) ;_ end of if
(if (not (equal NTH_VTX1 NTH_VTX2))
(setq NVTX_LST (append NVTX_LST (list NTH_VTX2)))) ;_ end of if
(setq N (+ N 1))
(setq NTH_VTX1 (nth N VTX_LST))
(if (not (setq NTH_VTX2 (nth (+ N 1) VTX_LST)))
(progn (if (not (member NR_PNT NVTX_LST))
(setq NVTX_LST (append NVTX_LST (list NR_PNT)))) ;_ end of if
(setq NTH_VTX1 NIL)) ;_ end of progn
) ;_ end of if
) ;progn
) ;while
) ;_ end of defun
(defun FMIDP (SP LP)
(setq MIDPNT (list (/ (+ (car SP) (car LP)) 2.0) (/ (+ (cadr SP) (cadr LP)) 2.0)) ;_ end of list
) ;_ end of setq
) ;_ end of defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This original Copyrighted routine has been modified...
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Remove Pline vertice ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun drop (lst item)
(append (reverse (cdr (member item (reverse lst))))
(cdr (member item lst))))
;;;
(defun massoc (key alist / x nlist)
(foreach
x alist
(if (eq key (car x))
(setq nlist (cons (cdr x) nlist))))
(reverse nlist))
;;;
(defun rv (e pt)
(if (= (cdr (assoc 0 (setq e (entget e)))) "LWPOLYLINE")
(progn (setvar "cmdecho" 0)
(command "undo" "begin")
(entmod
(drop e
(cons 10
(if (= (type pt) 'LIST)
(progn (setq pt (trans pt 1 (cdr (assoc -1 e))))
(list (car pt) (cadr pt)))
(nth pt (massoc 10 e))))))
(command "undo" "end")
(setvar "cmdecho" 1)
(princ))))
;;;example--->(rv (car (entsel)) 2)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Remove Pline vertice ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun RMVIT (/ *CURR_OSNAP olderror SelectedEntity PolyProperties iCount iCount2 NewPoly)
(setq *CURR_OSNAP (getvar "osmode"))
(setq olderror *error*)
(setq *error* RVLispError)
(setvar "cmdecho" 0)
(command "undo" "begin")
(setvar "osmode" 0)
(setq SelectedEntity (car (entsel "\n* Select Pline to Remove Vertex *")))
(if (and (/= SelectedEntity nil)
(= (cdr (assoc 0 (entget SelectedEntity))) "LWPOLYLINE"))
(progn (setq PolyProperties (entget SelectedEntity))
(initget 1)
(setvar "osmode" 32)
(setq SelectedVertex (getpoint "\n* Pick Vertex Point to Remove *"))
(setq iCount 0)
(while (< iCount (cdr (assoc 90 PolyProperties)))
(setq VertexPosition (cdr (nth (+ (* iCount 4) 14) PolyProperties)))
(if (and (= (car VertexPosition) (car SelectedVertex))
(= (cadr VertexPosition) (cadr SelectedVertex)))
(progn (setq iCount2 0)
(while (< iCount2 4)
(setq NewPoly
(vL-remove
(nth (+ (* iCount 4) 14) PolyProperties)
PolyProperties))
(setq iCount2 (1+ iCount2)))
(setq NewPoly
(subst (cons 90 (1- (cdr (assoc 90 PolyProperties))))
(assoc 90 PolyProperties)
NewPoly))
(entmod NewPoly)
(entupd (cdr (assoc -1 NewPoly)))
(setq iCount (cdr (assoc 90 PolyProperties)))))
(setq iCount (1+ iCount))))
(prompt "\n* No polylines selected! *"))
(princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun AVXIT (/)
(setq cmde (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq osm (getvar "osmode"))
(setvar "osmode" 32)
(setq pnt (osnap (getpoint "\n* Pick intersection point *") "_int"))
(if pnt
(progn (setq ss (ssget "_C" pnt pnt (list (cons 0 "LWPOLYLINE,POLYLINE"))))
(while (> (sslength ss) 0)
(setq en (ssname ss 0))
(command "break" en (trans pnt 1 en) "@")
(command "pedit" "m" en "L" "" "j" 0.000 "" "")
(ssdel en ss))))
(setvar "cmdecho" cmde)
(setvar "osmode" osm)
(princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(princ)
Gary
-
The problem is not my code, but yours. The code you posted draws a new polyline. To fix this you would need to just change the existing polyline definition, or copy the extension dictionary from the old one to the new one, and then copy the reactor (or assign a new one) to the new polyline. Let me see if I can come up with a routine to add a new vertex to an existing polyline, so that it will keep the reactor.
-
Tim
I just remembered Peter has a lispmacro routine taht might do the trick.
From his text file:
Use the vba man to embed the lispmacro.dvb macro into a drawing.
Then load the lispmacro.lsp and dcl files into the lispmacro dialog box.
Then embed any lisp files you need
Peter Jamtgaard
Gary
What ?
-
Tim
Thanks, that is what I thought, because just editing the pline with pedit, doesnot distroy the reactor.
Gary
-
Luis
I was just shooting from the hip. I think you can use his routine to embed the the areareact.lsp code within the drawing.
Then you could send the drawing to someone who does not have the code to keep the reactor persistant. It has been
a long time since I tried this. Maybe Peter can answer this.
Gary
-
How can you have it set up so it doesn't error? I'm sure there is a slick way that I haven't though of yet, so if anyone knows, please let me know.
(vl-load-com)
(vlax-ldata-put "TWILLEY" "AUTO_LOAD" nil t)
;; my functions in the right loading order start from here:
Make your routine part of a protected namespace VLX standard
I posted this solution on one of the Question #.... for the swamp.... anyways, that's the BEST way to auto load your LISP routines.
-
:vlr-unerased ...
You do not need that.
-
:vlr-unerased ...
You do not need that.
To elaborate more:
In the modified event you simple use something like the following:
(if (and (not (wcmatch (getvar "cmdnames")
"ERASE,CUTCLIP,U,UNDO,REDO,OOPS"))
... my stuff inside of the event....
Then, if the user use those commands, the reactor is not going to do NOTHING. and also, helps to get the built-in UNDO....
Autolisp and Visual Lisp are not structured coding.... All end up doing what they want... and that's a BAD habit... glad that I quit LISP.
stickto.lsp uses a proved solution that works.... btw.
-
Tim, this one works nice - just to test what I said in my previous post, without using vlr-unerased.... you are in the right track.... !
(defun c:AreaReact (/ Sel EntData PolyObj TextObj ReactList Pos)
;| Adds a presistant reactor to a polyline object that
updates a selected text object to the polylines area
in square feet. You will have to have the subs loaded
in everydrawing for it to work, so that it know what
to do with the reactor, because it is saved with the
drawing. Saves the association between the text
and the polyline in the extension dictionary of the
polyline.
Thanks to Luis Esquivel for his help and guidance.
|;
(if
(and
(setq Sel (entsel "\n Select polyline to get area of: "))
(setq EntData (entget (car Sel)))
(= (cdr (assoc 0 EntData)) "LWPOLYLINE")
(setq PolyObj (vlax-ename->vla-object (car Sel)))
(setq Sel (entsel "\n Select text of hold area value: "))
(setq EntData (entget (car Sel)))
(vl-position (cdr (assoc 0 EntData)) '("TEXT" "MTEXT"))
(setq TextObj (vlax-ename->vla-object (car Sel)))
)
(progn
(PutArea PolyObj TextObj)
(if
(and
(setq ReactList (AssociatedReactors PolyObj))
(setq Pos (vl-position "MyAreaReactorModified" (mapcar 'vlr-data ReactList)))
)
(vlr-remove (nth Pos ReactList))
)
(vlr-pers
(vlr-object-reactor
(list PolyObj)
"MyAreaReactorModified"
'(
(:vlr-modified . MakeCmdEndReactor)
(:vlr-erased . ObjectEraseReactor)
;;;;;; (:vlr-unerased . ObjectUnErasedReactor)
)
)
)
)
)
(princ)
)
;---------------------------------------------------------------------------------------------------------------
(defun PutArea (PolyObj TextObj / Dict xRec SqFt)
(setq Dict (vla-GetExtensionDictionary PolyObj))
(if (vl-catch-all-error-p (setq xRec (vl-catch-all-apply 'vla-Item (list Dict "MyAreaReactor"))))
(setq xRec (vla-AddXRecord Dict "MyAreaReactor"))
)
(MySetXrec xRec '(40 1) (list (vlax-get PolyObj 'Area) (vlax-get TextObj 'Handle)))
(setq SqFt (/ (vla-get-Area PolyObj) 144.0))
(vla-put-TextString TextObj (strcat (rtos SqFt 2 2) " SQ.FT."))
xRec
)
;----------------------------------------------------------------------------------------------------------------
(defun MakeCmdEndReactor (Obj React NotSure)
(if (not (wcmatch (getvar "cmdnames")
"U,UNDO,REDO,OOPS")) (progn
(if GlbVarAreaObject
(setq GlbVarAreaObject (append GlbVarAreaObject (list Obj)))
(setq GlbVarAreaObject (list Obj))
)
(if (not GlbReactorCommandEnd)
(setq GlbReactorCommandEnd (vlr-command-reactor nil '((:vlr-commandEnded . AdjustTextObj))))
)
))
(princ)
)
;------------------------------------------------------------------------------------------------------------------
(defun ObjectEraseReactor (Obj React NotSure)
(vlr-pers-release React)
(vlr-remove React)
(setq GlbReactorCommandEnd nil)
)
;-----------------------------------------------------------------------------------------------------------------
;;;;;;;;;(defun ObjectUnErasedReactor (Obj React NotSure)
;;;;;;;;;
;;;;;;;;;(vlr-pers
;;;;;;;;;(vlr-object-reactor
;;;;;;;;; (list Obj)
;;;;;;;;; "MyAreaReactorModified"
;;;;;;;;; '(
;;;;;;;;; (:vlr-modified . MakeCmdEndReactor)
;;;;;;;;; (:vlr-erased . ObjectEraseReactor)
;;;;;;;;; (:vlr-unerased . ObjectUnErasedReactor)
;;;;;;;;; )
;;;;;;;;;)
;;;;;;;;;)
;;;;;;;;;(setq GlbReactorCommandEnd nil)
;;;;;;;;;)
;-----------------------------------------------------------------------------------------------------------------
(defun AdjustTextObj (React CommandList / Dict xRec xRecList TextObj)
(foreach Obj GlbVarAreaObject
(if (not (vlax-erased-p Obj))
(progn
(setq Dict (vla-GetExtensionDictionary Obj))
(if (not (vl-catch-all-error-p (setq xRec (vl-catch-all-apply 'vla-Item (list Dict "MyAreaReactor")))))
(progn
(setq xRecList (MyGetXRec xRec))
(if
(and
(setq TextObj (vlax-ename->vla-object (setq tmpEnt (handent (cdr (assoc 1 xRecList))))))
(not (vlax-erased-p TextObj))
)
(PutArea Obj TextObj)
)
)
)
)
)
)
(setq GlbVarAreaObject nil)
(setq GlbReactorCommandEnd nil)
)
;---------------------------------------------------------------------------
(defun MySetXRec (Obj CodeList DataList / )
; Sets XRecordData. Dxf numbers between 1-369, except 5, 100, 105.
; See help for types and numbers to use.
(vla-SetXRecordData Obj
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbInteger
(cons 0 (1- (length CodeList)))
)
CodeList
)
)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbVariant
(cons 0 (1- (length Datalist)))
)
DataList
)
)
)
)
;-----------------------------------------------------------------------------
(defun MyGetXRec (Obj / CodeType DataType)
; Retrive XRecordData for an object
(vla-GetXRecordData
Obj
'CodeType
'DataType
)
(if (and CodeType DataType)
(mapcar
'(lambda (a b)
(cons a (variant-value b))
)
(safearray-value CodeType)
(safearray-value DataType)
)
)
)
;-------------------------------------------------------------------------------------
(defun AssociatedReactors (Obj / ReactList)
; Return a list of reactors (object type) associated with an object.
; Use like (AssociatedReactors (vlax-ename->vla-object (car (entsel))))
(foreach i (cdar (vlr-reactors :vlr-object-reactor))
(if (vl-position Obj (vlr-owners i))
(setq ReactList (cons i ReactList))
)
)
ReactList
)
;---------------------------------------------------------------------------
(defun RemovePersReact ()
; Remove persistant reactors that don't have an owner.
(foreach i (vlr-pers-list)
(if (not (vlr-owners i))
(progn
(vlr-pers-release i)
(vlr-remove i)
)
)
)
)
-
and without a fancy loading system... simple place:
(LOAD "AREAREACT.LSP" NIL)
in your acad.mnl.... and rock & roll....
-
Thanks Luis. I will have to look into these issues later, real work has happened again. I can't tell you how much I appreciate you taking the time to look over this stuff.
Gary here is a quick routine I wrote before lunch. It woked on my test, but only with lwpolylines.
(defun c:AddVertex (/ Sel Pt Obj CoordList cnt ParmPt cnt2 Ang tmpPt1 tmpPt2)
(if
(and
(setq Sel (entsel "\n Select polyline near where new vertex will be added: "))
(= (cdr (assoc 0 (entget (car Sel)))) "LWPOLYLINE")
(setq Pt (vlax-curve-getClosestPointTo (car Sel) (cadr Sel)))
(setq Obj (vlax-ename->vla-object (car Sel)))
(setq CoordList (vlax-get Obj 'Coordinates))
)
(progn
(setq cnt 0)
(setq ParmPt 1)
(while (< (1+ cnt) (length CoordList))
(setq cnt2
(if (>= (setq cnt2 (+ 2 cnt)) (length CoordList))
(- cnt2 (length CoordList))
cnt2
)
)
(setq Ang
(angle
(setq tmpPt1
(list
(nth cnt CoordList)
(nth (1+ cnt) CoordList)
)
)
(setq tmpPt2
(list
(nth cnt2 CoordList)
(nth (1+ cnt2) CoordList)
)
)
)
)
(if
(or
(equal (angle Pt tmpPt1) Ang 0.000001)
(equal (angle Pt tmpPt2) Ang 0.000001)
)
(setq cnt (length CoordList))
(progn
(setq ParmPt (1+ ParmPt))
(setq cnt (+ 2 cnt))
)
)
)
(vlax-invoke Obj 'AddVertex ParmPt (list (car Pt) (cadr Pt)))
)
)
(princ)
)
-
Tim
Thanks, it will replace my old routine for sure now. It works with both routines (yours and mine). I will soon have
a standalone dialog based routine that will have my collection of area routines. I tend to like dialog boxes, because
they give you more control of the routine. Thanks again. Like I keep saying I'm going to learn this vlisp stuff.
I can't imagine what Luis is up against with the c++ arx stuff.
Gary
-
. Like I keep saying I'm going to learn this vlisp stuff.
I can't imagine what Luis is up against with the c++ arx stuff.
Amigos;
Nothing against to LISP/VLISP ... I am just saying that in there anyone can do whatever they want, there is no control, no methodology, nothing, niep, nada, nil.... That is good an bad....
That's all... :mrgreen:
-
I'm glad that people find it useful. That is one of the best feelings about programming. Will post the finished version here, after I make the corrections per Luis's instructions in the last few posts.
I can't imagine what Luis is up against with the c++ arx stuff.
Gary
Me either, but I'm sure it will be very cool, and very productive.
Amigos;
Nothing against to LISP/VLISP ... I am just saying that in there anyone can do whatever they want, there is no control, no methodology, nothing, niep, nada, nil.... That is good an bad....
That's all... :mrgreen:
I think he was saying more that what you do is going to be awesome because that language is so powerful compared to lisp/vlisp and that will be cool to see where you can take it and cad.
-
Yes, everything I see from Luis has been awesome. I welcome his feedback and look forward to seeing what he comes up next.
Gary
-
Thanks for the cheers.... there are others out there more capable.... glad I'm still of use in here....
Have fun amigos.
-
:vlr-unerased ...
You do not need that.
The :vlr-Erased callback should not remove the reactor with (vlr-remove) because then if someone erases it and later brings it back with the OOPS or Undo command, the reactor will be gone and nothing will react to the :vlr-UnErased event. Instead you want the :vlr-Erased callback to remove the persistance and the :vlr-UnErased callback to put it back. if somone erases the object, the reactor will just hang around waiting for the object to get unerased. If it is never unerased, the non-persistant reactor will die when the drawing is closed.
-
The :vlr-Erased callback should not remove the reactor with (vlr-remove) because then if someone erases it and later brings it back with the OOPS or Undo command, the reactor will be gone and nothing will react to the :vlr-UnErased event. Instead you want the :vlr-Erased callback to remove the persistance and the :vlr-UnErased callback to put it back. if somone erases the object, the reactor will just hang around waiting for the object to get unerased. If it is never unerased, the non-persistant reactor will die when the drawing is closed.
Have you tested the latest routine yet?
I did exactly what you are mentioned in my early routines with reactors... One of the concerns to find an easier way to solve and get the UNDO mechanism without the use of the unerased event, was to use what I posted.
Mostly because, when you have a routine with reactors to run several times, basically a VLISP programmer would tend to create every time a new reactor per each call, in this case it is just a single object[owner]... what would happen if they were 4,5,6,10...
So, I end up killing the reactor in the erased event... and not worried of having any problems, if I not end up using the unerased....
The last routines I did with object reactors basically I simple implement a "reactor per object", in example if one routine was using four objects, and the user call it 100 times, the routine only was using 4 reactors, instead of 400 per say....
Have fun.
-
To keep adding to this, routines with visual lisp reactors must be used with care, not everything can be done by implementing them... I wrote a lot on reactors since the first time they came up on vital lisp... today I do not use a single one....
-
I just tested my routine with out the unerase reactor, and it worked fine. When I had it in, the way I did it, it was associate a new reactor with each undo, or oops after I erased. So if I oops 4 times on the same object, it would have 5 reactors attached to it, but when I took it out, it only had one. But I just ran into a new problem, which I would consider a big one. With the code now, you can only undo once. Say you stretch the object twice, the first undo will work, but the second one says "Nothing to undo". And ideas why?
-
Nice routine guys. Can this be made to work with an attributed block?
-
Say you stretch the object twice, the first undo will work, but the second one says "Nothing to undo". And ideas why?
What code are you using ?
Also, any reason why you have this:
(if (not GlbReactorCommandEnd)
(setq GlbReactorCommandEnd (vlr-command-reactor nil '((:vlr-commandEnded . AdjustTextObj))))
)
Inside of MakeCmdEndReactor ?
Why not simple place that out side ?
-
What code are you using ?
My latest, here.
(defun c:AreaReact (/ Sel EntData PolyObj TextObj ReactList Pos)
;| Adds a presistant reactor to a polyline object that
updates a selected text object to the polylines area
in square feet. You will have to have the subs loaded
in everydrawing for it to work, so that it know what
to do with the reactor, because it is saved with the
drawing. Saves the association between the text
and the polyline in the extension dictionary of the
polyline.
Thanks to Luis Esquivel for his help and guidance.
|;
(if
(and
(setq Sel (entsel "\n Select polyline to get area of: "))
(setq EntData (entget (car Sel)))
(= (cdr (assoc 0 EntData)) "LWPOLYLINE")
(setq PolyObj (vlax-ename->vla-object (car Sel)))
(setq Sel (entsel "\n Select text of hold area value: "))
(setq EntData (entget (car Sel)))
(vl-position (cdr (assoc 0 EntData)) '("TEXT" "MTEXT"))
(setq TextObj (vlax-ename->vla-object (car Sel)))
)
(progn
(PutArea PolyObj TextObj)
(if
(and
(setq ReactList (AssociatedReactors PolyObj))
(setq Pos (vl-position "MyAreaReactorModified" (mapcar 'vlr-data ReactList)))
)
(vlr-remove (nth Pos ReactList))
)
(vlr-pers
(vlr-object-reactor
(list PolyObj)
"MyAreaReactorModified"
'(
(:vlr-modified . MakeCmdEndReactor)
(:vlr-erased . ObjectEraseReactor)
; (:vlr-unerased . ObjectUnErasedReactor)
)
)
)
)
)
(princ)
)
;---------------------------------------------------------------------------------------------------------------
(defun PutArea (PolyObj TextObj / Dict xRec SqFt)
(setq Dict (vla-GetExtensionDictionary PolyObj))
(if (vl-catch-all-error-p (setq xRec (vl-catch-all-apply 'vla-Item (list Dict "MyAreaReactor"))))
(setq xRec (vla-AddXRecord Dict "MyAreaReactor"))
)
(MySetXrec xRec '(40 1) (list (vlax-get PolyObj 'Area) (vlax-get TextObj 'Handle)))
(setq SqFt (/ (vla-get-Area PolyObj) 144.0))
(vla-put-TextString TextObj (strcat (rtos SqFt 2 2) " SQ.FT."))
xRec
)
;----------------------------------------------------------------------------------------------------------------
(defun MakeCmdEndReactor (Obj React NotSure)
(if GlbVarAreaObject
(setq GlbVarAreaObject (append GlbVarAreaObject (list Obj)))
(setq GlbVarAreaObject (list Obj))
)
(if (not GlbReactorCommandEnd)
(setq GlbReactorCommandEnd (vlr-command-reactor "tempAreaCommandReactor" '((:vlr-commandEnded . AdjustTextObj))))
)
(princ)
)
;------------------------------------------------------------------------------------------------------------------
(defun ObjectEraseReactor (Obj React NotSure)
(vlr-pers-release React)
(vlr-remove React)
)
;-----------------------------------------------------------------------------------------------------------------
(defun ObjectUnErasedReactor (Obj React NotSure)
(vlr-pers
(vlr-object-reactor
(list Obj)
"MyAreaReactorModified"
'(
(:vlr-modified . MakeCmdEndReactor)
(:vlr-erased . ObjectEraseReactor)
(:vlr-unerased . ObjectUnErasedReactor)
)
)
)
)
;-----------------------------------------------------------------------------------------------------------------
(defun AdjustTextObj (React CommandList / Dict xRec xRecList TextObj)
(foreach Obj GlbVarAreaObject
(if (not (vlax-erased-p Obj))
(progn
(setq Dict (vla-GetExtensionDictionary Obj))
(if (not (vl-catch-all-error-p (setq xRec (vl-catch-all-apply 'vla-Item (list Dict "MyAreaReactor")))))
(progn
(setq xRecList (MyGetXRec xRec))
(if
(and
(setq TextObj (vlax-ename->vla-object (setq tmpEnt (handent (cdr (assoc 1 xRecList))))))
(not (vlax-erased-p TextObj))
)
(PutArea Obj TextObj)
)
)
)
)
)
)
(setq GlbVarAreaObject nil)
(vlr-remove GlbReactorCommandEnd)
(setq GlbReactorCommandEnd nil)
)
;---------------------------------------------------------------------------
(defun MySetXRec (Obj CodeList DataList / )
; Sets XRecordData. Dxf numbers between 1-369, except 5, 100, 105.
; See help for types and numbers to use.
(vla-SetXRecordData Obj
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbInteger
(cons 0 (1- (length CodeList)))
)
CodeList
)
)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbVariant
(cons 0 (1- (length Datalist)))
)
DataList
)
)
)
)
;-----------------------------------------------------------------------------
(defun MyGetXRec (Obj / CodeType DataType)
; Retrive XRecordData for an object
(vla-GetXRecordData
Obj
'CodeType
'DataType
)
(if (and CodeType DataType)
(mapcar
'(lambda (a b)
(cons a (variant-value b))
)
(safearray-value CodeType)
(safearray-value DataType)
)
)
)
;-------------------------------------------------------------------------------------
(defun AssociatedReactors (Obj / ReactList)
; Return a list of reactors (object type) associated with an object.
; Use like (AssociatedReactors (vlax-ename->vla-object (car (entsel))))
(foreach i (cdar (vlr-reactors :vlr-object-reactor))
(if (vl-position Obj (vlr-owners i))
(setq ReactList (cons i ReactList))
)
)
ReactList
)
;---------------------------------------------------------------------------
(defun RemovePersReact ()
; Remove persistant reactors that don't have an owner.
(foreach i (vlr-pers-list)
(if (not (vlr-owners i))
(progn
(vlr-pers-release i)
(vlr-remove i)
)
)
)
)
Also, any reason why you have this:
(if (not GlbReactorCommandEnd)
(setq GlbReactorCommandEnd (vlr-command-reactor nil '((:vlr-commandEnded . AdjustTextObj))))
)
Inside of MakeCmdEndReactor ?
Why not simple place that out side ?
I was thinking that having it there, then it will only work when one of the objects that are defined by the command is modified. I didn't want to have the reactor just floating out there for anything to fire it. I thought this was a safer (more secure) way to handle the reactor.
Nice routine guys. Can this be made to work with an attributed block?
Thanks. I don't think it would be hard to do at all. That is also on the assumption that attribute handles don't change when opening and closing a drawing. In the first portion of the code, where it ask to select a text object, change "entsel" to "nentsel", and it should work for nested objects. Also you will need to change this line
(vl-position (cdr (assoc 0 EntData)) '("TEXT" "MTEXT"))
to
(vl-position (cdr (assoc 0 EntData)) '("TEXT" "MTEXT" "ATTRIB"))
-
Change this:
(defun MakeCmdEndReactor (Obj React NotSure)
(if (not (wcmatch
(getvar "cmdnames")
"U,UNDO,REDO,OOPS"))
(progn
(if GlbVarAreaObject
(setq GlbVarAreaObject (append GlbVarAreaObject (list Obj)))
(setq GlbVarAreaObject (list Obj)))
(if (not GlbReactorCommandEnd)
(setq GlbReactorCommandEnd
(vlr-command-reactor
nil
'((:vlr-commandEnded . AdjustTextObj))))) ))
(princ))
I see that you did not tested your code with the changes I did previously....
-
I can't test now because I"m at home, but I didn't think I had to do that. I want the reactor to fire if an undo is done that affected the polyline object, won't what you put not allow that? I will test this in the morning when I get to work.
It looks like the wording of your other post, that there is no other way to do it than that way. I hope it works for my routine. Thanks again.
-
that there is no other way to do it than that way.
What I simple been trying to do here, is to provide a work of years of research, that does not means that is right/wrong/or the only way.... it is just something that works.
Please, use what I have posted as just another example... :-)
-
What I simple been trying to do here, is to provide a work of years of research, that does not means that is right/wrong/or the only way.... it is just something that works.
Please, use what I have posted as just another example... :-)
That works sweet!!! Thanks Luis!!! I thought it wouldn't work right because it wouldn't fire with an undo, but it does, and it updates the polyline. THANKS A WHOLE LOT LUIS, for staying with me, and sharing your knowledge!!
I will continue to check it to see if there is anything else I need to do to it, but right now I think it works that way it should. The only think I changed is what Luis posted, but here is my version, which is the same, just in my style.
(defun MakeCmdEndReactor (Obj React NotSure)
(if (not (wcmatch (getvar "cmdnames") "U,UNDO,REDO,OOPS"))
(progn
(if GlbVarAreaObject
(setq GlbVarAreaObject (append GlbVarAreaObject (list Obj)))
(setq GlbVarAreaObject (list Obj))
)
(if (not GlbReactorCommandEnd)
(setq GlbReactorCommandEnd (vlr-command-reactor "tempAreaCommandReactor" '((:vlr-commandEnded . AdjustTextObj))))
)
)
)
(princ)
)
-
Here is the latest version that I am happy with. Have fun, and let me know if it doesn't work correctly.
-
...
Por nada Tim.
-
Here is the latest version that I am happy with. Have fun, and let me know if it doesn't work correctly.
;;make sure the textobj can write
(vlax-write-enabled-p textobj)
-
Here is the latest version that I am happy with. Have fun, and let me know if it doesn't work correctly.
;;make sure the textobj can write
(vlax-write-enabled-p textobj)
Thanks for the tip, I never thought of that. I don't think I have ever seen that. Is that only controlled by code?
-
The most important thing is objectdbx is not support to open a persistent reactors dwg.
-
Here is the latest version that I am happy with. Have fun, and let me know if it doesn't work correctly.
1.only del the textobj then do several modify-----like modify the ployline, then undo back the textobj, reactor fail
2.only del the textobj then save, reopen then dwg, reactor fail
-
1.only del the textobj then do several modify-----like modify the ployline, then undo back the textobj, reactor fail
I wanted it to work this way that is why I put a prompt telling them that the reactor was erased.
Command: areareact
Select polyline to get area of:
Select text of hold area value:
Command:
Command: e ERASE
Select objects: Specify opposite corner: 1 found
Select objects:
Command: Specify opposite corner:
Command:
** STRETCH **
Specify stretch point or [Base point/Copy/Undo/eXit]:
Reactor has be removed because the text object has been erased.
2.only del the textobj then save, reopen then dwg, reactor fail
This one I don't like. When I did this, it was a bad error, and I didn't like seeing that, so here is the fix. Replace the function in the lisp file with this one.
(defun AdjustTextObj (React CommandList / Dict xRec xRecList TextObj)
(foreach Obj GlbVarAreaObject
(if (not (vlax-erased-p Obj))
(progn
(setq Dict (vla-GetExtensionDictionary Obj))
(if (not (vl-catch-all-error-p (setq xRec (vl-catch-all-apply 'vla-Item (list Dict "MyAreaReactor")))))
(progn
(setq xRecList (MyGetXRec xRec))
(if
(and
(setq tmpEnt (handent (cdr (assoc 1 xRecList))))
(setq TextObj (vlax-ename->vla-object tmpEnt))
(not (vlax-erased-p TextObj))
)
(PutArea Obj TextObj)
(progn
(foreach i (AssociatedReactors Obj)
(if (= (vlr-data i) "MyAreaReactorModified")
(progn
(vlr-pers-release i)
(vlr-remove i)
)
)
)
(prompt "\n Reactor has be removed because the text object has been erased.")
)
)
)
)
)
)
)
(setq GlbVarAreaObject nil)
(vlr-remove GlbReactorCommandEnd)
(setq GlbReactorCommandEnd nil)
)
Thanks for testing and posting back about the code Lucas.
-
If said that is the selection “PLINE” the automatic production “TEXT” the thing and has the area value, when and carries on “PLINE” the thing “COPY”, but is connected the production automatically “TEXT” the thing, and the content is its area value, how should achieve the duplication the response movement?
Hoped that the moderator perhaps other masters may explain.
Thanks!
-
I hope not to derail this thread by posting an alternate solution.
I notice you are using the Object Reactor to store the area and the handle of the text in an extension dictionary of the polyline object and then creating a Command Reactor that is doing the modification to the text when the :vlr-CommandEnded callback fires. You can do this all at once with just the Object Reactor on the Polyline object by storing the area of the Polyline and the handle of the text in the client data of the reactor object and the modifying the text when the :vlr-ObjectClosed callback fires.
You can set and retreive this data using the VLR-Data-Set and VLR-Data functions respectivelly, and you can also use it to store a flag for what to do when the object is closed, to handel the polyline getting deleted.
When you create your reactor, store the initial data and have it react to all situations:
(VLR-Object-Reactor
(List (VLAX-EName->VLA-Object PolylineObject))
(List '(0 . 0) ;modify flag
(Cons 1 PolylineArea ) ;area of polyline
(Cons 2 TextObjectHandle) ;handle of the text object
)
'((:vlr-Cancelled . Pline_Cancelled-Callback )
(:vlr-Modified . Pline_Modified-Callback )
(:vlr-Copied . Pline_Copied-Callback )
(:vlr-Erased . Pline_Erased-Callback)
(:vlr-UnErased . Pline_UnErased-Callback )
(:vlr-ObjectClosed . Pline_ObjectClosed-Callback )
)
)
Put (vlr-trace-reaction) in all of the callbacks and watch the order in whice they come down. When the object is modified :vlr-Modified fires then :vlr-ObjectClosed. When the object is erased :vlr-Modified fires, then :vlr-Erased, then :vlr-ObjectClosed fires.
You cannot rely on the order in which the callbacks will fire, especially when modifying multiple objects at once. The :vlr-ObjectClosed will always fire when the object is closed for editing. You use the other callbacks to over-write the modify flag in the client data of the reactor object and then retreive it to determine what the Pline_ObjectClosed-Callback function will do. The Pline_Modified-Callback function will store the area of the polyline into the 1 dotted-pair of the association list.
If you want to go down this tangent, I can post lots of code snipettes, since I just finished writing a reactor that linked a lable with an object and maintained it when the object changed. It also had to take into account not only when the object was erased and brought back with the OOPS or Undo Commands (:vlr-UnErased), but also when the object and lable were copied and the new label had to become linked to the new object.
Ask you are
'((:vlr-Cancelled . Pline_Cancelled-Callback )
(:vlr-Modified . Pline_Modified-Callback )
(:vlr-Copied . Pline_Copied-Callback )
(:vlr-Erased . Pline_Erased-Callback)
(:vlr-UnErased . Pline_UnErased-Callback )
(:vlr-ObjectClosed . Pline_ObjectClosed-Callback )
)
connected procedure in where?