TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: ziele_o2k on August 25, 2018, 06:58:39 AM

Title: Please test and review this doubleclick reactor
Post by: ziele_o2k on August 25, 2018, 06:58:39 AM
As part of expanding my lisp skills, I'm starting to play with the reactors. Because the reactors require a little more attention than the "usual" routines, please review following code. Lisp in the future is meant to serve "my" blocks. The idea is that after double-clicking on the block for which I will have a defined function, autocad will start this function instead of default one.
Lisp to check:
Code: [Select]
(if (null *Check_Block-reactor*)
    (setq *Check_Block-reactor*
        (vlr-mouse-reactor "Check_Block" '((:vlr-beginDoubleClick . pz:checkblock)))
    )
)

(defun pz:checkblock (@Reactor @Point / _objectPoint _ACadDoc _ssets _flag _newsset _obj _ss _tmp)
    (setq _objectPoint (car @Point))
    (setq _ACadDoc (vla-get-activedocument(vlax-get-acad-object)))
    (setq _ssets (vla-get-selectionsets _ACadDoc))
    (if (vl-catch-all-error-p
            (vl-catch-all-apply
                'vla-item (list _ssets "$Set")
            )
        )
        (setq _newsset (vla-add _ssets "$Set"))
        (progn
            (vla-delete (vla-item _ssets "$Set"))
            (setq _newsset (vla-add _ssets "$Set"))
        )
    )
    (vla-selectAtPoint _newsset (vlax-3D-point _objectPoint))
    (if (/= (vla-get-count _newsset) 0)
        (progn
            (vlax-for %obj _newsset
                (setq _tmp (cons %obj _tmp))
            )
            (setq _tmp
                (vl-member-if
                    '(lambda (%)
                        (and
                            (= (vla-get-ObjectName %) "AcDbBlockReference")
                            (=  "EXAMPLE"
                                (strcase
                                    (vlax-get-property %
                                        (if (vlax-property-available-p % 'effectivename)
                                            'effectivename
                                            'name
                                        )
                                    )
                                )
                            )
                        )
                    )
                    _tmp
                )
            )
            (if _tmp
                (progn
                    (setq *escape-EATTEDIT* t)
                    (alert "Do my stuff...")
                    (vla-delete (vla-item _ssets "$Set"))
                )
                (progn
                    (setq _ss (ssget "_p"))
                    (sssetfirst nil _ss)
                )
            )
        )
    )
    (princ)
)

;based on:
;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/cancel-command-with-visual-lisp-reactor/m-p/3239430#M300536
(if (null *command-reactor*)
    (setq *command-reactor*
        (vlr-command-reactor nil '((:vlr-commandwillstart . commandreactorcallback)))
    )
)

(if (null *editor-reactor*)
    (setq *editor-reactor*
        (vlr-editor-reactor nil '((:vlr-beginclose . editorreactorcallback)))
    )
)

(defun commandreactorcallback ( reactor params )
    (if (and
            *escape-EATTEDIT*
            (or
                (eq (strcase (car params)) "EATTEDIT")
                (eq (strcase (car params)) "QUICKPROPERTIES")
                (eq (strcase (car params)) "RATRRED")
                (eq (strcase (car params)) "WŁAŚCIWOŚCI")
            )
        )
        (progn
            (if (setq *wsh* (cond (*wsh*) ((vlax-create-object "WScript.Shell"))))
                (vl-catch-all-apply 'vlax-invoke (list *wsh* 'sendkeys "{ESC}"))
            )
            (setq *escape-EATTEDIT* nil)
        )
    )
    (princ)
)

(defun editorreactorcallback ( reactor params )
    (if (and *wsh* (eq 'VLA-OBJECT (type *wsh*)) (not (vlax-object-released-p *wsh*)))
        (vl-catch-all-apply 'vlax-release-object (list *wsh*))
    )
    (if (and *command-reactor* (eq 'VLA-OBJECT (type *command-reactor*)))
        (vlr-remove *command-reactor*)
    )
    (vlr-remove reactor)
    (princ)
)
Title: Re: Please test and review this doubleclick reactor
Post by: Grrr1337 on August 26, 2018, 02:37:26 AM
Glad to see you solved this one, ziele_o2k !
I couldn't figure this out on my own, so I had to revise your code.
Personally I try to avoid global variables, if I can... aswell too many reactors - because I don't like efficient versions that turn the routine into a spaghetti code.
So heres my interpretation of it -

Code - Auto/Visual Lisp: [Select]
  1. ; trying to interpretate from
  2. ; http://www.theswamp.org/index.php?topic=54441.0
  3.  
  4. ; Callback functions:
  5.  
  6. (defun Mouse:CB ( rtr args / o )
  7.   (and
  8.     (setq o (nentselp (car args)))
  9.     (cond
  10.       ( (= 2 (length o)) (setq o (vlax-ename->vla-object (car o)))
  11.         (and
  12.           (eq (vlax-get-property o 'ObjectName) "AcDbAttribute")
  13.         ); and
  14.       )
  15.       ( (setq o (vlax-ename->vla-object (last (last o)))) )
  16.     ); cond
  17.     (eq (vlax-get-property o 'ObjectName) "AcDbBlockReference")
  18.     (if (setq *CheckBlock:EscEATTEDIT* (= "EXAMPLE" (strcase (vla-get-EffectiveName o))))
  19.       (alert "\nDo my stuff...")
  20.       (sssetfirst nil (ssget "_P"))
  21.     ); if
  22.   ); and
  23.  
  24. ); defun
  25.  
  26.  
  27. (defun Cmd:CB ( rtr args )
  28.   (and
  29.     *CheckBlock:EscEATTEDIT*
  30.     (member (strcase (car args)) '("EATTEDIT" "QUICKPROPERTIES" "RATRRED" "WLASCIWOSCI"))
  31.     (SendEsc)
  32.   ); and
  33.   (setq *CheckBlock:EscEATTEDIT* nil)
  34. ); defun Cmd:CB
  35.  
  36.  
  37. ; Include our reactors:
  38.  
  39. (defun CheckBlock ( flg ) ; subfoo that accepts boolean, to be used for on/off switching
  40.   (
  41.     (lambda ( rtrnm flg ) (vl-load-com)
  42.       (foreach rtr (cdar (vlr-reactors :VLR-Mouse-reactor)) (if (= rtrnm (vlr-data rtr)) (vlr-remove rtr)) )
  43.       (foreach rtr (cdar (vlr-reactors :VLR-Command-Reactor)) (if (= rtrnm (vlr-data rtr)) (vlr-remove rtr)) )
  44.       (if flg
  45.         (progn
  46.           (alert "\nCheck block reactor is ON")
  47.           (vlr-Mouse-Reactor rtrnm '((:VLR-BeginDoubleClick . Mouse:CB)))
  48.           (vlr-Command-Reactor rtrnm '((:VLR-commandWillStart . Cmd:CB)))
  49.         ); progn
  50.         (alert "\nCheck block reactor is OFF")
  51.       ); if
  52.      
  53.       (princ)
  54.     ); lambda
  55.     "Check_Block" flg
  56.   )
  57. ); defun CheckBlock
  58.  
  59. (defun C:CheckBlockOn nil (CheckBlock t) (princ))
  60. (defun C:CheckBlockOff nil (CheckBlock nil) (princ))
  61.  
  62. (C:CheckBlockOn)
  63.  
  64.  
  65. ; Subfunctions:
  66.  
  67. (defun SendEsc ( / wsh )
  68.   (and
  69.     (setq wsh (vlax-get-or-create-object "WScript.Shell"))
  70.     (vl-catch-all-apply (function (lambda nil (vlax-invoke-method wsh 'SendKeys "{ESC}"))))
  71.   )
  72.   (vl-catch-all-apply 'vlax-release-object (list wsh))
  73.   t
  74. ); defun SendEsc

Turns out you don't have to access to the SelectionSets collection, and create a named SS.

If you want to learn more about reactors just check some of my threads with questions about 'reactors' (where Lee answered),
but IMO you seem pretty good at them - especially when you managed to pull off this one.

Thanks again for sharing!