Ciao Andrea,
Can't find name of the author [same author] for next 2 routines! First one draws 2 concentric circles, then when using MOVE [not drag] to relocate one circle the other follows. Second routine will ask you to pick a point on screen, an undescored text will be printed. When erasing text, the line is deleted as well.
(vl-load-com)
;;;----
(defun nothing (A B C) nil)
(defun move-circle (A B C)
(vlr-reaction-set MOVEREAKTOR :vlr-modified 'nothing)
(cond ((equal A circle1) (vla-put-center circle2 (vla-get-center A)))
(T (vla-put-center circle1 (vla-get-center A)))
) ;_ end of cond
(vlr-reaction-set MOVEREAKTOR :vlr-modified 'move-circle)
) ;end move-circle
(setq CIRCLE1
(progn (setq PKT (getpoint "\nCentrePoint:")
PROMIEN (distance PKT (getpoint PKT "\nRadius:"))
) ;_ end of setq
(vla-addCircle (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
(vlax-3d-point PKT)
PROMIEN
) ;_ end of vla-addCircle
) ;end progn
) ;end circle1
(entmake (list '(0 . "CIRCLE") (cons 10 PKT) (cons 40 (/ PROMIEN 2))))
(setq CIRCLE2 (vlax-ename->vla-object (entlast)))
(setq MOVEREAKTOR (vlr-object-reactor (list circle1 circle2) nil '((:vlr-modified . move-circle))))
(princ)
(vl-load-com)
(defun cleanreactors (A B)
(setq CLOSEDWG nil)
(mapcar 'vlr-remove-all
'(:vlr-wblock-reactor :vlr-insert-reactor :vlr-editor-reactor :vlr-object-reactor)
) ;_ end of mapcar
) ;end cleanreactors
(setq CLOSEDWG (vlr-dwg-reactor nil '((:vlr-beginclose . cleanreactors))))
;;;---
(defun test (A B) (alert "Object(s) erased.."))
(vlr-acdb-reactor nil '((:vlr-objecterased . test)))
;;;---
(defun erase-line (A B C)
(if (not (vlax-erased-p myline))
(vla-delete myline)
) ;_ end of if
) ;end erase-line
(setq
mytext (progn (setq PKT (getpoint "\nPick point:"))
(vla-addText (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
"Test On Reactor"
(vlax-3d-point PKT)
1.0
) ;_ end of vla-addText
) ;end progn
) ;end mytext
(entmake (list '(0 . "LINE") (cons 10 PKT) (cons 11 (polar PKT 0.0 13.0))))
(setq MYLINE (vlax-ename->vla-object (entlast)))
(vlr-object-reactor (list mytext) nil '((:vlr-erased . erase-line)))
(princ)
This next one is from Autodesk:
;;;--------------------------------------------------------------------;
;;; This file demonstrates how VLISP interacts with the properties ;
;;; manager - changes propagated via selection sets and reactors ;
;;;--------------------------------------------------------------------;
(command "_.properties")
(setq message
(strcat
"Observe the property manager's state right now.\n"
"Type \"change-OPM\" at the command-line to see a
change to Model Space propagate to the OPM\n"
)
)
(princ message)
(defun C:change-OPM ()
(vl-load-com)
(setq *ModelSpace*
(vla-get-ModelSpace
(setq activeDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
) ;_ end of vla-get-ModelSpace
) ;_ end of setq
(setq myObj
(vla-AddMtext
*ModelSpace*
(vlax-3d-point '(3 6 0))
7
"While this MTEXT is selected,
\\P\\Plook at Properties Manager
\\PDo you see this entity's properties displayed?
\\P\\PWatch Properties change again:
\\PHit ESC to de-select this entity"
)
)
(vla-ZoomAll (vlax-get-acad-object))
(vla-update myObj)
; make a pickfirst selection set out of new MTEXT object
(sssetfirst nil (ssget "L"))
(princ "\nNotice the new entity is selected\nand the manager has changed to display the properties of the new mtext\n
Next...")
(initget 1 "Y N")
(if (equal "Y"
(getkword
"Attach an object reactor to this new mtext? [Y/N] "
)
)
(attach-reactor myObj)
)
)
(defun attach-reactor (obj)
(vl-load-reactors)
(setq entityReactor
(vlr-object-reactor
(list obj)
nil
'((:vlr-modified . chain-reaction))
)
)
(princ "\nNew reactor object: entityReactor\nIt (<event> . <callback function>) is rigged as: ")
(princ (vlr-reactions entityReactor))
(princ "\nNow changes to this mtext entity will trigger an event notification.")
(princ)
)
(defun chain-reaction (notifier-object reactor-object param-list)
(princ "\nYou've modified the MTEXT's properties\n")
)
Then, from Bill Kramer:
; C:CONNECT - demonstrates simple reactor system based on
; Visual LISP.
;
; Draw two circles, then run the connect routine. A line
; will be drawn between the two circles. If either circle
; is modified, the line is regenerate. More than one
; set of circles can be related and one circle can be
; related to a group of circles.
;
; This function set merely demonstrates the basics involved
; in building a reactor system in Visual LISP.
;
;
;Connection reactor set up routine
;
(defun C:CONNECT ()
(setq EN1 (car (entsel "\nPick a circle: "))
EN2 (car (entsel " and another: "))
RCnt (if RCnt (1+ RCnt) 1)
Connect_Flag 'T
)
(if (and EN1 EN2)
(progn
(vl-load-com)
(setq EN3 (Connection EN1 EN2) ;;see listing 21
EN3 (vlax-ename->vla-object EN3)
EN1 (vlax-ename->vla-object EN1)
EN2 (vlax-ename->vla-object EN2)
)
(vlr-object-reactor
(list EN1 EN2 EN3)
(strcat "Connect Circles " (itoa RCnt))
'((:vlr-modified . ConnectFix) ;;see listing 22
;(:vlr-erased . ConnectKill)
)
)
)
)
)
;;---------------------------------------------------------
; Drawing a line between circles
;
(defun Connection (EN1 EN2 / EL1 EL2)
(setq EN1 (if (= (type EN1) 'EName)
EN1
(vlax-vla-object->ename EN1))
EN2 (if (= (type EN2) 'Ename)
EN2
(vlax-vla-object->ename EN2))
EL1 (entget EN1)
EL2 (entget EN2)
R1 (cdr (assoc 40 EL1))
R2 (cdr (assoc 40 EL2))
P1 (cdr (assoc 10 EL1))
P2 (cdr (assoc 10 EL2))
A1 (angle P1 P2)
P1 (polar P1 A1 R1)
P2 (polar P2 (+ A1 PI) R2)
)
(entmake (list
'(0 . "LINE")
(assoc 8 EL1)
(cons 10 P1)
(cons 11 P2)
)
)
(entlast)
)
;;---------------------------------------------------------
; Entity Object Callback function
;
(defun ConnectFix (
Not_Obj ;;caused notification
Re_Obj ;;reactor object
PList ;;parameters list
/
ObjList ;;objects in reactor set
VObj ;;VLA object
EN ;;Entity name
EL ;;Entity list
ENL ;;Entity list for line
P1 ;;Center/end point 1
P2 ;;Center/end point 2
R1 ;;Radius 1
R2 ;;Radius 2
SkipIt ;;Process change flag
)
;;
(if Connect_Flag
(progn
(setq Connect_Flag nil)
;;
;;Get list of objects associated with the
;;reactor that caused the call back.
;;
(setq ObjList (vlr-owners Re_Obj))
;;
;;Loop through each object in list
(foreach VObj ObjList
;;
;;Convert object reference to AutoLISP style
(setq EN (vlax-vla-object->ename VObj)
EL (entget EN))
(cond ;;what type of entity is it?
((= (cdr (assoc 0 EL)) "LINE")
;;Did the line object cause the callback?
(if (eq Not_Obj VObj)
;;if so, skip it.
(setq SkipIt 'T)
)
(setq ENL EL) ;;save entity list of line
)
('T ;;Otherwise it is one of the circles.
;;get the center point and radius
(set (if (boundp 'P1) 'P2 'P1)
(cdr (assoc 10 EL)))
(set (if (boundp 'R1) 'R2 'R1)
(cdr (assoc 40 EL)))))
)
(setq AA (angle P1 P2) ;;angle between circles
;;adjust points P1 and P2
P1 (polar P1 AA R1)
P2 (polar P2 (+ AA PI) R2)
;;replace values in entity list
ENL (subst (cons 10 P1)
(assoc 10 ENL) ENL)
ENL (subst (cons 11 P2)
(assoc 11 ENL) ENL)
)
(if (null SkipIt)
(progn
(entmod ENL) ;;update the line
)
(prompt "\nConnection broken.")
)
(setq Connect_Flag 'T)
) ;;end PROGN
) ;;end IF
)
Canadian Serge Camiré:
;| SpyReactor.lsp
Permet de connaitre les commandes et les variables sollicitées.
Par Serge Camiré, Cad-Novation / Consultants Univers inc.
Création: 2003-06-13 (un vendredi 13)
Quoi de mieux que d'essayer le MVPort à http://www.cadnovation.com/fr/
ou un LTScale_Switch en français, en anglais, en Portuguais (merci à Luis Dantas),
en Espagnol (merci à Dominique Vaquand) , en Nééerlandais (merci à Richard Reggers)
et bientôt en Italien ( )
Reçoit: rien
Retourne: rien
Usage: Taper SHOWALL pour afficher le sommaire
Usage: Taper FLUSHALL pour vider le sommaire
|;
(vl-load-com)
(defun test:reactorSysvarWillChangeReactor (
data callbacks /
)
(setq *reactorSysvarWillChangeReactor* (cons (car callbacks) *reactorSysvarWillChangeReactor*))
(princ)
)
(defun test:reactorSysVarChangedReactor (
data callbacks /
)
(setq *reactorSysVarChangedReactor* (cons (car callbacks) *reactorSysVarChangedReactor*))
(princ)
)
(defun test:reactorCommandWillStartReactor (
calling-reactor command-list /
)
(setq *reactorCommandWillStartReactor* (cons (car command-list) *reactorSysVarChangedReactor*))
(princ)
)
(defun test:reactorCommandEndedReactor (
calling-reactor command-list /
)
(setq *reactorCommandEndedReactor* (cons (car command-list) *reactorCommandEndedReactor*))
(princ)
)
(defun test:reactorCommandCancelledReactor (
calling-reactor command-list /
)
(setq *reactorCommandCancelledReactor* (cons (car command-list) *reactorCommandCancelledReactor*))
(princ)
)
(defun test:reactorCommandFailedReactor (
calling-reactor command-list /
)
(setq *reactorCommandFailedReactor* (cons (car command-list) *reactorCommandFailedReactor*))
(princ)
)
;;; Already loaded? Unload it.
(if test:reactorCommandReactor (vlr-remove test:reactorCommandReactor))
(setq test:reactorCommandReactor
(vlr-editor-reactor
nil
'( (:vlr-CommandWillStart . test:reactorCommandWillStartReactor)
(:vlr-CommandEnded . test:reactorCommandEndedReactor)
(:vlr-CommandCancelled . test:reactorCommandCancelledReactor)
(:vlr-CommandFailed . test:reactorCommandFailedReactor)
)
)
)
;;; Already loaded? Unload it.
(if test:reactorSysvarReactor (vlr-remove test:reactorSysvarReactor))
(setq test:reactorSysvarReactor
(vlr-sysvar-reactor
nil
'( (:vlr-sysVarWillChange . test:reactorSysvarWillChangeReactor)
(:vlr-sysVarChanged . test:reactorSysVarChangedReactor)
)
)
)
(defun c:flushall ()
(setq *reactorSysvarWillChangeReactor* nil)
(setq *reactorSysVarChangedReactor* nil)
(setq *reactorCommandWillStartReactor* nil)
(setq *reactorCommandEndedReactor* nil)
(setq *reactorCommandCancelledReactor* nil)
(setq *reactorCommandFailedReactor* nil)
(princ)
)
(defun c:showall()
(princ "\n \nVariables sur le point de changer:\n")
(foreach atome *reactorSysvarWillChangeReactor* (if atome (princ atome)) (princ "\t"))
(if (not *reactorSysvarWillChangeReactor*) (princ "Aucune"))
(princ "\n \nVariables changées:\n")
(foreach atome *reactorSysVarChangedReactor* (if atome (princ atome)) (princ "\t"))
(if (not *reactorSysVarChangedReactor*) (princ "Aucune"))
(princ "\n \nCommandes entamées:\n")
(foreach atome *reactorCommandWillStartReactor* (if atome (if atome (princ atome))) (princ "\t"))
(if (not *reactorCommandWillStartReactor*) (princ "Aucune"))
(princ "\n \nCommandes terminées:\n")
(foreach atome *reactorCommandEndedReactor* (if atome (princ atome)) (princ "\t"))
(if (not *reactorCommandEndedReactor*) (princ "Aucune"))
(princ "\n \nCommandes annulées:\n")
(foreach atome *reactorCommandCancelledReactor* (if atome (princ atome)) (princ "\t"))
(if (not *reactorCommandCancelledReactor*) (princ "Aucune"))
(princ "\n \nCommandes échouées:\n")
(foreach atome *reactorCommandFailedReactor* (if atome (princ atome)) (princ "\t"))
(if (not *reactorCommandFailedReactor*) (princ "Aucune"))
(textscr)
(princ)
)
(c:flushall)
(princ)
And this last one draws a gear after prompting for specifications, and then when routine is loaded, and a call is made on the erase command, will re-prompt for new values to replace the gear:
;;; Create a persistent gear train given
;;; RPM, Gear Ratio, Diametral Pitch, Shaft Diameter
;; Due to inclusion of "Reactors", when you erase the gear train, the program prompts you to reenter the gear data and creates a new gear again.
(DEFUN c:gear ()
(gear_reactor 1 1 1)
)
(DEFUN gear_reactor (notifier reactor parameter)
(SETQ rpm (GETREAL "\nEnter RPM of Pinion Gear : ")
number_teeth (GETREAL "\nEnter Number of Teeth : ")
gear_ratio (/ 1 (GETREAL "\nEnter Gear Ratio : "))
dia_pitch (GETREAL "\nEnter Diametral Pitch : ")
shaft_dia (GETREAL "\nEnter Shaft Diameter : ")
PT (GETPOINT "\nSelect Point : ")
pitch_dia (/ number_teeth dia_pitch)
gear_teeth (* gear_ratio number_teeth)
gear_out (+ pitch_dia (* 2 (/ 1 (/ gear_teeth pitch_dia))))
pinion_out (+ pitch_dia (* 2 (/ 1 (/ number_teeth pitch_dia))))
gear_rpm (* gear_ratio rpm)
disatance (+ (* 0.5 pinion_out) (* 0.5 gear_out))
pt_x (+ disatance (CAR pt))
pt_y (CADR pt)
pinion (LIST (CONS 0 "CIRCLE")
(CONS 10 pt)
(CONS 40 (/ pinion_out 2))
(CONS 8 "pinion")
)
gear (LIST (CONS 0 "CIRCLE")
(CONS 10 (LIST pt_x pt_y))
(CONS 40 (/ gear_out 2.0))
(CONS 8 "gear")
)
shaft_pinion (LIST (CONS 0 "CIRCLE")
(CONS 10 pt)
(CONS 40 (/ shaft_dia 2.0))
(CONS 8 "pinion")
)
shaft_gear (LIST (CONS 0 "CIRCLE")
(CONS 10 (LIST pt_x pt_y))
(CONS 40 (/ shaft_dia 2.0))
(CONS 8 "pinion")
)
)
(ENTMAKE (list (cons 0 "block")
(CONS 2 "pinion")
(cons 10 (LIST pt_x pt_y))
(cons 70 64)
)
)
(ENTMAKE pinion)
(ENTMAKE shaft_pinion)
(ENTMAKE (list (cons 0 "endblk")))
(ENTMAKE (list (CONS 0 "INSERT")
(cons 2 "pinion")
(cons 10 (LIST pt_x pt_y))
)
)
(setq lastent (entget (entlast)))
(regapp "pinion")
(setq exdata1
(LIST
(LIST "pinion"
(CONS 1000 (STRCAT "Pinion's RPM " (RTOS rpm)))
(CONS 1041 gear_ratio)
(CONS 1042 number_teeth)
)
)
)
(setq newent1
(append lastent (list (append '(-3) exdata1)))
)
(entmod newent1)
(ENTMAKE (list (cons 0 "block")
(CONS 2 "gear")
(cons 10 (LIST pt_x pt_y))
(cons 70 64)
)
)
(ENTMAKE gear)
(ENTMAKE shaft_gear)
(ENTMAKE (list (cons 0 "endblk")))
(ENTMAKE (list (CONS 0 "INSERT")
(cons 2 "gear")
(cons 10 (LIST pt_x pt_y))
)
)
(setq lastent (entget (entlast)))
(regapp "gear")
(setq exdata
(LIST
(LIST "gear"
(CONS 1000 (STRCAT "Mating Gear's RPM " (RTOS rpm)))
(CONS 1041 gear_ratio)
(CONS 1042 gear_teeth)
)
)
)
(setq newent
(append lastent (list (append '(-3) exdata)))
)
(entmod newent)
(princ)
(define_reactor)
)
(defun define_reactor ()
(vl-load-com)
(setq vlr-object
(vlr-object-reactor
(list (vlax-ename->vla-object
(cdr (assoc -1 (entget (entlast))))
)
)
"Example Line Reactor"
'((:VLR-erased . gear_reactor))
)
)
)
(princ "VlxxGear.lsp Loaded. Type Gear to use.") (princ)
Have fun. There's more to be found in AutoCAD install, they are at first like a pain in the derriere, to learn/understand, but with practice...
