_

[LISP] Prośba o przetestowanie reaktorka

Forum poświęcone flagowemu produktowi oraz aplikacjom pochodnym Autodesku. To jedyne forum mające w tytule nazwę programu, a to ze względu na jego olbrzymią popularność w Polsce. Można tutaj umieszczać również posty z ogólnie pojętej tematyki "Kreślarskie 2D".

[LISP] Prośba o przetestowanie reaktorka

Postprzez ziele_o2k » sie 24, 2018 00:51

W ramach poszerzania swoich lispowych umiejętności zaczynam się bawić z reaktorami.
Ponieważ reaktorki wymagają trochę więcej uwagi niż "zwykłe" lispy, proszę o przeanalizowanie poniższego kodu.
Lisp w przyszłości ma służyć do obsługi "moich" bloków. Chodzi o to, żeby po podwójnym kliknięciu na blok dla którego będę mieć zdefiniowaną funkcję uruchamiała się właśnie ona, a nie domyślna autocadowa.

Kod: Zaznacz cały
(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)
)


i przyklad dzialania <klik>:
przyklad_dzialania.gif
Załączniki
example.dwg
Przykładowy plik dwg
(64.06 KiB) Pobrane 13 razy
Ziele
Avatar użytkownika
ziele_o2k
 
Posty: 728
Dołączył(a): mar 18, 2014 11:33
Lokalizacja: Poznań

Re: [LISP] Prośba o przetestowanie reaktorka

Postprzez wilda » sie 25, 2018 09:00

W sprawdzaniu kodu to niestety nie pomogę.
Mogę co najwyżej pomóc w testowaniu.
Chyba nie odkryję ameryki jeżeli napiszę że powyższy kod (reaktor) działa tylko na pierwsze kliknięcie na bloku.
wilda
 
Posty: 228
Dołączył(a): gru 18, 2007 21:41

Re: [LISP] Prośba o przetestowanie reaktorka

Postprzez ziele_o2k » sie 25, 2018 12:33

wilda napisał(a):(...)Chyba nie odkryję ameryki jeżeli napiszę że powyższy kod (reaktor) działa tylko na pierwsze kliknięcie na bloku.

No i tu się pojawia problem, ponieważ u mnie działa prawidłowo... co dzieje się za drugim razem i jakiego cada używasz ?
Ziele
Avatar użytkownika
ziele_o2k
 
Posty: 728
Dołączył(a): mar 18, 2014 11:33
Lokalizacja: Poznań

Re: [LISP] Prośba o przetestowanie reaktorka

Postprzez kojacek » sie 25, 2018 15:47

ziele_o2k napisał(a):
wilda napisał(a):(...)Chyba nie odkryję ameryki jeżeli napiszę że powyższy kod (reaktor) działa tylko na pierwsze kliknięcie na bloku.

No i tu się pojawia problem, ponieważ u mnie działa prawidłowo... co dzieje się za drugim razem i jakiego cada używasz ?


Potwierdzam działa ok, teraz popatrzę dokładniej na kod - na pierwszy rzut oka też jest wszystko ok.
Już widzę parę zastosowań... :)
Avatar użytkownika
kojacek
 
Posty: 5450
Dołączył(a): paź 03, 2005 20:17

Re: [LISP] Prośba o przetestowanie reaktorka

Postprzez ziele_o2k » sie 25, 2018 18:58

kojacek napisał(a):(...) teraz popatrzę dokładniej na kod - na pierwszy rzut oka też jest wszystko ok.

coś bym tam jeszcze zmieniłł, ale poczekamy co tam wypatrzysz.
kojacek napisał(a):Już widzę parę zastosowań... :)

No jakby się tak zastanowić, to dzięki takiemu narzędziu można kilka fajnych rzeczy osiągnąć.
Poza tym moim do bloków, to jeszcze przykładowo jakieś obiekty z xdata :?:
Ziele
Avatar użytkownika
ziele_o2k
 
Posty: 728
Dołączył(a): mar 18, 2014 11:33
Lokalizacja: Poznań

Re: [LISP] Prośba o przetestowanie reaktorka

Postprzez wilda » sie 25, 2018 19:02

AC2012
Załączniki
checkblock.gif
wilda
 
Posty: 228
Dołączył(a): gru 18, 2007 21:41

Re: [LISP] Prośba o przetestowanie reaktorka

Postprzez kojacek » sie 25, 2018 19:37

ziele_o2k napisał(a): coś bym tam jeszcze zmieniłł, ale poczekamy co tam wypatrzysz.

Póki co wypatrzyłem takie coś. Dwuklik na zwykłym bloku z atrybutami, uruchamia edytor, niemniej po dowolnej reakcji (ok / anuluj) w linii poleceń widać:

eattedit.PNG
eattedit.PNG (5.69 KiB) Przeglądane 216 razy


Chętnie też bym zmienił reakcję na listę bloków a nie tylko jedną nazwę - czyli nie tylko "EXAMPLE" ale "EXAMPLE1" "EXAMPLE2" etc...
Avatar użytkownika
kojacek
 
Posty: 5450
Dołączył(a): paź 03, 2005 20:17

Re: [LISP] Prośba o przetestowanie reaktorka

Postprzez wilda » sie 25, 2018 20:43

pierwszy dwuklik na bloku - reaktor działa,
drugi dwuklik - reaktor nie działa; pokazuje się okno rozszerzonego edytora atrybutów.
Sprawdzałem na wersji 2005 i tam za każdym razem działa.
Załączniki
checkblock.jpg
wilda
 
Posty: 228
Dołączył(a): gru 18, 2007 21:41

Re: [LISP] Prośba o przetestowanie reaktorka

Postprzez ziele_o2k » sie 25, 2018 21:01

wilda napisał(a):pierwszy dwuklik na bloku - reaktor działa,
drugi dwuklik - reaktor nie działa; pokazuje się okno rozszerzonego edytora atrybutów.
Sprawdzałem na wersji 2005 i tam za każdym razem działa.

Weź sprawdź co Ci się wyświetli z tego w tym AC2012.
Kod: Zaznacz cały
(if (null *Check_Block-reactor*)
    (setq *Check_Block-reactor*
        (vlr-mouse-reactor "Check_Block" '((:vlr-beginDoubleClick . pz:checkblock)))
    )
)

(defun pz:checkblock (@Reactor @Point / *error* _objectPoint _ACadDoc _ssets _flag _newsset _obj _ss _tmp)
    (defun *error* (msg / so)
        (cond
            ((not msg))
            ((member msg '("Function cancelled" "quit / exit abort")))
            (
                (princ (strcat "\n  <!>  Error: " msg "  <!> "))
                (cond (t (vl-bt)))
            )
        )
        (princ)
    )
    (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)
)
Ziele
Avatar użytkownika
ziele_o2k
 
Posty: 728
Dołączył(a): mar 18, 2014 11:33
Lokalizacja: Poznań

Re: [LISP] Prośba o przetestowanie reaktorka

Postprzez wilda » sie 25, 2018 21:26

Niepotrzebne zamieszanie :oops: uruchomiłem cada z innym obszarem roboczym i działa za każdym razem.
Co ciekawe teraz i po uruchomieniu w moim ustawionym obszarze roboczym też cały czas działa. Coś w pamięci autocada musiało siedzieć?
wilda
 
Posty: 228
Dołączył(a): gru 18, 2007 21:41

Następna strona

Powrót do AutoCAD

Kto przegląda forum

Użytkownicy przeglądający ten dział: Brak zidentyfikowanych użytkowników