Code Red > AutoLISP (Vanilla / Visual)
Stop an reactor
Patrick_35:
Hello
I have create this lisp which makes it possible by a right click on a block to rename it by the reactors
My concern, it's when i give a new name or answered an error message, the function click right continuous
I.e. that if the right click = enter, it takes again the last command or if not, it's the contextual menu
How to make so that an reactors stop definitively, and thus without autocad continuing in its logic
Thanks in advance
@+
--- Code: ---(defun Clic_Droit_Renommer(Rea Pt / Bk Bks Nom Sel Txt)
(defun MsgBox (Titre Bouttons Message / Reponse WshShell)
(setq WshShell (vlax-create-object "WScript.Shell"))
(setq Reponse (vlax-invoke WshShell 'Popup Message 7 Titre (itoa Bouttons)))
(vlax-release-object WshShell)
Reponse
)
(defun InputBox (Titre Message Defaut / *acad* users1 valeur)
(setq *acad* (vlax-get-acad-object) users1 (getvar "users1"))
(acad-push-dbmod)
(vla-eval *acad* (strcat "ThisDrawing.SetVariable \"USERS1\"," "InputBox (\"" Message "\", \"" Titre "\", \"" Defaut "\")"))
(setq valeur (getvar "users1"))
(setvar "users1" users1)
(acad-pop-dbmod)
valeur
)
(if (setq Sel (ssget (car Pt)))
(progn
(setq Sel (vlax-ename->vla-object (ssname Sel 0)))
(if (eq (vla-get-ObjectName Sel) "AcDbBlockReference")
(progn
(if (vlax-property-available-p Sel 'EffectiveName)
(setq nom (vla-get-EffectiveName Sel))
(setq nom (vla-get-Name Sel))
)
(if (setq Txt (InputBox "Rename Block" "Please give a new name to the block" Nom))
(if (not (eq (strcase Txt) (strcase Nom)))
(if (not (eq Txt ""))
(progn
(setq Bks (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))
(if (vla-item Bks Txt)
(MsgBox "Rename Block" 16 "Block Name already existing. Nothing of changed")
(progn
(setq Bk (vla-item Bks Nom))
(vla-put-name Bk Txt)
)
)
)
)
(MsgBox "Rename Block" 48 "Identical name. Nothing of changed")
)
)
)
)
)
)
(princ)
)
(defun creation_reacteur_renommer (/ i j n)
(vl-load-com)
(if (vlr-reactors :vlr-mouse-reactor)
(progn
(setq n 1)
(while (setq i (nth n (car (vlr-reactors :vlr-mouse-reactor))))
(if (eq (cdr (car (vlr-reactions i))) 'CLIC_DROIT_RENOMMER)
(setq j i)
)
(setq n (1+ n))
)
(if j
(vlr-remove j)
)
)
)
(setq mrea_ren (vlr-mouse-reactor nil '((:vlr-beginRightClick . Clic_Droit_Renommer))))
(princ "\nRight click to rename the blocks ENABLE")
(princ)
)
(if (not mrea_ren)
(creation_reacteur_renommer)
)
(princ)
--- End code ---
Patrick_35:
It's impossible ? :?
@+
LE:
See if this code works for you:
--- Code: ---;;;;;;;;;;;;(defun Clic_Droit_Renommer (Rea Pt / Bk Bks Nom Sel Txt)
;;;;;;;;;;;;
;;;;;;;;;;;; (defun MsgBox (Titre Bouttons Message / Reponse WshShell)
;;;;;;;;;;;; (setq WshShell (vlax-create-object "WScript.Shell"))
;;;;;;;;;;;; (setq Reponse (vlax-invoke
;;;;;;;;;;;; WshShell
;;;;;;;;;;;; 'Popup
;;;;;;;;;;;; Message
;;;;;;;;;;;; 7
;;;;;;;;;;;; Titre
;;;;;;;;;;;; (itoa Bouttons)))
;;;;;;;;;;;; (vlax-release-object WshShell)
;;;;;;;;;;;; Reponse
;;;;;;;;;;;; )
;;;;;;;;;;;;
(defun InputBox (Titre Message Defaut / *acad* users1 valeur)
(setq *acad* (vlax-get-acad-object)
users1 (getvar "users1"))
(acad-push-dbmod)
(vla-eval *acad*
(strcat "ThisDrawing.SetVariable \"USERS1\","
"InputBox (\"" Message
"\", \"" Titre
"\", \"" Defaut
"\")"))
(setq valeur (getvar "users1"))
(setvar "users1" users1)
(acad-pop-dbmod)
valeur
)
;;;;;;;;;;;;
;;;;;;;;;;;;
;;;;;;;;;;;;
;;;;;;;;;;;; (if (setq Sel (ssget (car Pt)))
;;;;;;;;;;;; (progn
;;;;;;;;;;;; (setq Sel (vlax-ename->vla-object (ssname Sel 0)))
;;;;;;;;;;;; (if (eq (vla-get-ObjectName Sel) "AcDbBlockReference")
;;;;;;;;;;;; (progn
;;;;;;;;;;;; (if (vlax-property-available-p Sel 'EffectiveName)
;;;;;;;;;;;; (setq nom (vla-get-EffectiveName Sel))
;;;;;;;;;;;; (setq nom (vla-get-Name Sel))
;;;;;;;;;;;; )
;;;;;;;;;;;; (if (setq Txt
;;;;;;;;;;;; (InputBox "Rename Block"
;;;;;;;;;;;; "Please give a new name to the block"
;;;;;;;;;;;; Nom))
;;;;;;;;;;;; (if (not (eq (strcase Txt) (strcase Nom)))
;;;;;;;;;;;; (if (not (eq Txt ""))
;;;;;;;;;;;; (progn
;;;;;;;;;;;; (setq Bks (vla-get-blocks
;;;;;;;;;;;; (vla-get-activedocument
;;;;;;;;;;;; (vlax-get-acad-object))))
;;;;;;;;;;;;
;;;;;;;;;;;;
;;;;;;;;;;;;
;;;;;;;;;;;; (if (vl-catch-all-error-p
;;;;;;;;;;;; (setq
;;;;;;;;;;;; return
;;;;;;;;;;;; (vl-catch-all-apply
;;;;;;;;;;;; 'vla-item
;;;;;;;;;;;; (list Bks Txt))))
;;;;;;;;;;;;
;;;;;;;;;;;; ;;(vla-item Bks Txt)
;;;;;;;;;;;; (MsgBox
;;;;;;;;;;;; "Rename Block"
;;;;;;;;;;;; 16
;;;;;;;;;;;; (strcat
;;;;;;;;;;;; "Block Name already existing. Nothing of changed \n"
;;;;;;;;;;;; (vl-catch-all-error-message return)))
;;;;;;;;;;;; (progn
;;;;;;;;;;;; (setq Bk (vla-item Bks Nom))
;;;;;;;;;;;; (vla-put-name Bk Txt)
;;;;;;;;;;;; )
;;;;;;;;;;;; )
;;;;;;;;;;;;
;;;;;;;;;;;;
;;;;;;;;;;;; )
;;;;;;;;;;;; )
;;;;;;;;;;;; (MsgBox "Rename Block"
;;;;;;;;;;;; 48
;;;;;;;;;;;; "Identical name. Nothing of changed")
;;;;;;;;;;;; )
;;;;;;;;;;;; )
;;;;;;;;;;;; )
;;;;;;;;;;;; )
;;;;;;;;;;;; )
;;;;;;;;;;;; )
;;;;;;;;;;;; (princ)
;;;;;;;;;;;; )
;;;;;;;;;;;;
;;;;;;;;;;;;
;;;;;;;;;;;;
;;;;;;;;;;;;(defun creation_reacteur_renommer (/ i j n)
;;;;;;;;;;;; (vl-load-com)
;;;;;;;;;;;; (if (vlr-reactors :vlr-mouse-reactor)
;;;;;;;;;;;; (progn
;;;;;;;;;;;; (setq n 1)
;;;;;;;;;;;; (while
;;;;;;;;;;;; (setq i (nth n (car (vlr-reactors :vlr-mouse-reactor))))
;;;;;;;;;;;; (if
;;;;;;;;;;;; (eq (cdr (car (vlr-reactions i))) 'CLIC_DROIT_RENOMMER)
;;;;;;;;;;;; (setq j i)
;;;;;;;;;;;; )
;;;;;;;;;;;; (setq n (1+ n))
;;;;;;;;;;;; )
;;;;;;;;;;;; (if j
;;;;;;;;;;;; (vlr-remove j)
;;;;;;;;;;;; )
;;;;;;;;;;;; )
;;;;;;;;;;;; )
;;;;;;;;;;;; (setq mrea_ren (vlr-mouse-reactor
;;;;;;;;;;;; nil
;;;;;;;;;;;; '((:vlr-beginRightClick . Clic_Droit_Renommer))))
;;;;;;;;;;;; (princ "\nRight click to rename the blocks ENABLE")
;;;;;;;;;;;; (princ)
;;;;;;;;;;;; )
;;;;;;;;;;;;
;;;;;;;;;;;;(if (not mrea_ren)
;;;;;;;;;;;; (creation_reacteur_renommer)
;;;;;;;;;;;; )
;;;;;;;;;;;;(princ)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (not *doc*)
(setq *doc* (vla-get-activedocument (vlax-get-acad-object))))
(if (not mouse_reactor)
(setq mouse_reactor
(vlr-mouse-reactor
"right_click"
'((:vlr-beginRightClick . on_right_click)))))
(defun on_right_click (reactor_obj lst / obj compare pt ent ss)
(if lst
(progn
(if
(and
(eq 1
(logand
1
(vlax-variant-value
(vla-getvariable *doc* "pickfirst"))))
(setq ss (ssget "_i"))
(eq 1 (sslength ss)))
(progn
(setq ent (ssname ss 0)
pt (osnap (car lst) "_nea")
obj (vlax-ename->vla-object ent))
(sssetfirst nil nil)))
(if
(and
obj
(equal (vlax-variant-value
(vla-getvariable *doc* "cmdnames"))
"")
(wcmatch (strcase (vla-get-objectname obj))
"*BLOCK*"))
(progn
(if (vlax-property-available-p obj 'EffectiveName)
(setq nom (vla-get-EffectiveName obj))
(setq nom (vla-get-Name obj)))
(setq Txt
(InputBox "Rename Block"
"Please give a new name to the block"
Nom))
(if (and (not (vl-catch-all-error-p
(setq
return
(vl-catch-all-apply
'vla-item
(list (vla-get-blocks *doc*) Txt)))))
(/= txt ""))
(vla-put-name
(vla-item (vla-get-blocks *doc*) nom)
txt))))))
(princ))
(princ)
--- End code ---
Correction:
(defun on_right_click (reactor_obj lst
Patrick_35:
Thank you very much of your help :-) , but that does not answer exactly so that I seek
I would wish simply with a right click on a block can rename a block, without the grips, just with the mouse pointer
When I make a right click, if it's not a block, the right click continuous as that was defines in autocad :-)
If it's a block, I rename the block and it's there that the things of complicate because the reactor continues. For example if the right click at summer defines as enter in autocad, of the blow, it takes again the last order :?
@+
LE:
I think I understood what you are saying.... for now I do not have time to play with lisp... when I got a chance I'll tried something else.... (not been doing any lisp for a while)
Now... I'm just lurking here.... need to do some serious work like cleaning the office.... :lol:
Navigation
[0] Message Index
[#] Next page
Go to full version