Topic: Help me to fix the code with reactor

[ribarm]

Hi all...

I've searched on how to make hatch-wipeouts (to "cheat" ACAD with double hatches), but I run into some kind of bug with reactor activated... Please before you load routine, use (vlr-remove-all) command so that reactor may fire correctly (twice loading, or more may produce unpredicted results)...

Code - Auto/Visual Lisp: [Select]

1. (setq *foo_reactor* (vlr-sysvar-reactor nil '((:vlr-sysVarChanged . Foo_Callback))))
2.  
3. (defun foo_Callback ( rea lst / newtilemode lay )
4.   (if (and
5.         (= "TILEMODE" (car lst))
6.         (= T (cadr lst))
7.         (/= (setq newtilemode (getvar 'tilemode))
8.             (cond (*tilemode*)
9.                   ((setq *tilemode* (getvar 'tilemode))))))
10.     (progn
11.       (setq *tilemode* newtilemode)
12.       (princ "\n\"TILEMODE\" has changed: ")
13.       (princ newtilemode)
14.       (if (eq (vla-get-freeze (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) "0")) :vlax-true)
15.         (vla-put-freeze (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) "0") :vlax-false)
16.       )
17.       (setvar 'clayer "0")
18.       (if (tblsearch "LAYER" "HATCH-WIPEOUT")
19.         (progn
20.           (setq lay (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) "HATCH-WIPEOUT"))
21.           (if (eq newtilemode 0) (vla-put-freeze lay :vlax-true) (vla-put-freeze lay :vlax-false))
22.         )
23.       )
24.       (vla-regen (vla-get-activedocument (vlax-get-acad-object)) AcAllViewports)
25.       (terpri))
26.   )
27. )
28.  
29. (defun c:bhwipeout ( / adoc True->RGB orlay lay bckmodcol rgb bound )
30.  
31.   (vl-load-com)
32.   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
33.  
34.   (defun True->RGB ( c )
35.     (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24))
36.   )
37.  
38.   (setq orlay (getvar 'clayer))
39.   (if (not (tblsearch "LAYER" "HATCH-WIPEOUT"))
40.     (setq lay (vla-add (vla-get-layers adoc) "HATCH-WIPEOUT"))
41.     (setq lay (vla-item (vla-get-layers adoc) "HATCH-WIPEOUT"))
42.   )
43.   (vla-put-plottable lay :vlax-false)
44.   (setq bckmodcol (vlax-variant-value (vlax-variant-change-type (vla-get-graphicswinmodelbackgrndcolor (vla-get-display (vla-get-preferences (vlax-get-acad-object)))) vlax-vbstring)))
45.   (setq rgb (reverse (true->rgb (atoi bckmodcol))))
46.   (command "_.layer" "_S" "HATCH-WIPEOUT" "_C" "_T" (strcat (itoa (car rgb)) "," (itoa (cadr rgb)) "," (itoa (caddr rgb))) "" "")
47.   (setvar 'clayer orlay)
48.   (setvar 'hpcolor "255,255,255")
49.   (setvar 'hpname "SOLID")
50.   (prompt "\nPick boundary entity for wipeout hatch")
51.   (setq bound (ssname (ssget "_+.:E:S:L" '((0 . "*POLYLINE,CIRCLE,ELLIPSE,SPLINE,REGION"))) 0))
52.   (command "_.-bhatch" "_S" bound "" "")
53.   (setvar 'clayer "HATCH-WIPEOUT")
54.   (setvar 'hpcolor "ByLayer")
55.   (command "_.-bhatch" "_S" bound "" "")
56.   (command "_.draworder" bound "" "_F")
57.   (setvar 'clayer orlay)
58.   (princ)
59. )
60.  

I am pretty slim when it comes to reactors, so I've just used one from BlackBox and Lee's subfunction True->RGB and applied reactor to my situation (case), but when routine is fired and wipeout(hatches) are created and when I switch for a few times from Model to Paper space, Model Space just blanks and I can't see anything and not even cursor - it changed to mouse Windows arrow...

Please, help me to solve this problem if you know how...

M.R.

[roy_043]

I can't reproduce the problem in BricsCAD V14. But have you tried commenting out line 24?:

Code: [Select]

(vla-regen (vla-get-activedocument (vlax-get-acad-object)) AcAllViewports)
If that solves the problem and you require the regen, consider using a 'postprocess'. Line 24 would then become:

Code: [Select]

(vla-sendcommand (vla-get-activedocument (vlax-get-acad-object)) "(RegenPostProcess) ")And you would need this function:

Code: [Select]

(defun RegenPostProcess () (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acallviewports) (princ))

[ribarm]

No it didn't help, again the same bug... Does it work in Brics...?

Code: [Select]

(defun regenpostprocess nil
  (vl-load-com)
  (vla-regen (vla-get-activedocument (vlax-get-acad-object)) AcAllViewports)
)

(defun reactor nil
  (vl-load-com)
  (setq *foo_reactor* (vlr-sysvar-reactor nil '((:vlr-sysVarChanged . Foo_Callback))))
)
 
(defun foo_Callback ( rea lst / newtilemode lay )
  (vl-load-com)
  (if (and
        (= "TILEMODE" (car lst))
        (= T (cadr lst))
        (/= (setq newtilemode (getvar 'tilemode))
            (cond (*tilemode*)
                  ((setq *tilemode* (getvar 'tilemode))))))
    (progn
      (setq *tilemode* newtilemode)
      (princ "\n\"TILEMODE\" has changed: ")
      (princ newtilemode)
      (if (eq (vla-get-freeze (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) "0")) :vlax-true)
        (vla-put-freeze (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) "0") :vlax-false)
      )
      (setvar 'clayer "0")
      (if (tblsearch "LAYER" "HATCH-WIPEOUT")
        (progn
          (setq lay (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) "HATCH-WIPEOUT"))
          (if (eq newtilemode 0) (vla-put-freeze lay :vlax-true) (vla-put-freeze lay :vlax-false))
        )
      )
      (vla-sendcommand (vla-get-activedocument (vlax-get-acad-object)) "(regenpostprocess)\n")
      (terpri))
  )
)

(defun c:bhwipeout ( / adoc True->RGB orlay lay bckmodcol rgb bound )

  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))

  (defun True->RGB ( c )
    (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24))
  )
 
  (setq orlay (getvar 'clayer))
  (if (not (tblsearch "LAYER" "HATCH-WIPEOUT"))
    (setq lay (vla-add (vla-get-layers adoc) "HATCH-WIPEOUT"))
    (setq lay (vla-item (vla-get-layers adoc) "HATCH-WIPEOUT"))
  )
  (vla-put-plottable lay :vlax-false)
  (setq bckmodcol (vlax-variant-value (vlax-variant-change-type (vla-get-graphicswinmodelbackgrndcolor (vla-get-display (vla-get-preferences (vlax-get-acad-object)))) vlax-vbstring)))
  (setq rgb (reverse (true->rgb (atoi bckmodcol))))
  (command "_.layer" "_S" "HATCH-WIPEOUT" "_C" "_T" (strcat (itoa (car rgb)) "," (itoa (cadr rgb)) "," (itoa (caddr rgb))) "" "")
  (setvar 'clayer orlay)
  (setvar 'hpcolor "255,255,255")
  (setvar 'hpname "SOLID")
  (prompt "\nPick boundary entity for wipeout hatch")
  (setq bound (ssname (ssget "_+.:E:S:L" '((0 . "*POLYLINE,CIRCLE,ELLIPSE,SPLINE,REGION"))) 0))
  (command "_.-bhatch" "_S" bound "" "")
  (setvar 'clayer "HATCH-WIPEOUT")
  (setvar 'hpcolor "ByLayer")
  (command "_.-bhatch" "_S" bound "" "")
  (command "_.draworder" bound "" "_F")
  (setvar 'clayer orlay)
  (vlr-remove-all)
  (reactor)
  (princ)
)

If it works, than my effort isn't total waste of time...

[roy_043]

I would try moving more callback code to the postprocess.
This line would be my next candidate:

Code: [Select]

(setvar 'clayer "0")
But you could also put everything, except the call to (vla-sendcommand), in the postprocess. This is perhaps even the wisest choice. Using (vla-sendcommand) ensures that the CAD program will execute the code when it is ready to do so. If the code is inside the callback that may not be the case.

Here is an example of the use of a postprocess:
http://www.theswamp.org/index.php?topic=42826.msg505544#msg505544

[ribarm]

Thanks, Roy, this solved it... Very much THANKS!!!

Code - Auto/Visual Lisp: [Select]

1. (defun postprocess nil
2.   (vl-load-com)
3.   (if (eq (vla-get-freeze (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) "0")) :vlax-true)
4.     (vla-put-freeze (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) "0") :vlax-false)
5.   )
6.   (setvar 'clayer "0")
7.   (if (tblsearch "LAYER" "HATCH-WIPEOUT")
8.     (progn
9.       (setq lay (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) "HATCH-WIPEOUT"))
10.       (if (eq (getvar 'tilemode) 0) (vla-put-freeze lay :vlax-true) (vla-put-freeze lay :vlax-false))
11.     )
12.   )
13.   (vla-regen (vla-get-activedocument (vlax-get-acad-object)) AcAllViewports)
14. )
15.  
16. (defun reactor nil
17.   (vl-load-com)
18.   (setq *foo_reactor* (vlr-sysvar-reactor nil '((:vlr-sysVarChanged . Foo_Callback))))
19. )
20.  
21. (defun foo_Callback ( rea lst / newtilemode lay )
22.   (vl-load-com)
23.   (if (and
24.         (= "TILEMODE" (car lst))
25.         (= T (cadr lst))
26.         (/= (setq newtilemode (getvar 'tilemode))
27.             (cond (*tilemode*)
28.                   ((setq *tilemode* (getvar 'tilemode))))))
29.     (progn
30.       (setq *tilemode* newtilemode)
31.       (princ "\n\"TILEMODE\" has changed: ")
32.       (princ newtilemode)
33.       (vla-sendcommand (vla-get-activedocument (vlax-get-acad-object)) "(postprocess)\n")
34.       (terpri))
35.   )
36. )
37.  
38. (defun c:bhwipeout ( / adoc True->RGB ss i orlay lay bckmodcol rgb bound )
39.  
40.   (vl-load-com)
41.   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
42.  
43.   (defun True->RGB ( c )
44.     (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24))
45.   )
46.  
47.   (setq orlay (getvar 'clayer))
48.   (if (not (tblsearch "LAYER" "HATCH-WIPEOUT"))
49.     (setq lay (vla-add (vla-get-layers adoc) "HATCH-WIPEOUT"))
50.     (setq lay (vla-item (vla-get-layers adoc) "HATCH-WIPEOUT"))
51.   )
52.   (vla-put-plottable lay :vlax-false)
53.   (setq bckmodcol (vlax-variant-value (vlax-variant-change-type (vla-get-graphicswinmodelbackgrndcolor (vla-get-display (vla-get-preferences (vlax-get-acad-object)))) vlax-vbstring)))
54.   (setq rgb (reverse (true->rgb (atoi bckmodcol))))
55.   (command "_.layer" "_S" "HATCH-WIPEOUT" "_C" "_T" (strcat (itoa (car rgb)) "," (itoa (cadr rgb)) "," (itoa (caddr rgb))) "" "")
56.   (setvar 'clayer orlay)
57.   (setvar 'hpname "SOLID")
58.   (prompt "\nSelect boundary entities for wipeout hatches")
59.   (setq ss (ssget (append (list '(-4 . "<or") '(0 . "CIRCLE") '(-4 . "<and") '(0 . "*POLYLINE") '(-4 . "<not") '(-4 . "&=") '(70 . 8) '(-4 . "not>") '(-4 . "&=") '(70 . 1) '(-4 . "and>") '(-4 . "<and") '(0 . "SPLINE") '(-4 . "&=") '(70 . 1) '(-4 . "and>") '(-4 . "<and") '(0 . "ELLIPSE") '(41 . 0.0)) (list (cons 42 (* 2 pi))) (list '(-4 . "and>") '(0 . "REGION") '(-4 . "or>")))))
60.   (setq i -1)
61.   (while (setq bound (ssname ss (setq i (1+ i))))
62.     (if (>= (atof (substr (getvar "acadver") 1 4)) 18.0) (setvar 'hpcolor "255,255,255") (setvar 'cecolor "RGB:255,255,255"))
63.     (setvar 'clayer orlay)
64.     (command "_.draworder" bound "" "_F")
65.     (command "_.-bhatch" "_S" bound "" "")
66.     (setvar 'clayer "HATCH-WIPEOUT")
67.     (if (>= (atof (substr (getvar "acadver") 1 4)) 18.0) (setvar 'hpcolor "ByLayer") (setvar 'cecolor "ByLayer"))
68.     (command "_.-bhatch" "_S" bound "" "")
69.     (command "_.draworder" bound "" "_F")
70.   )
71.   (setvar 'clayer orlay)
72.   (if *foo_reactor* (vlr-remove *foo_reactor*))
73.   (reactor)
74.   (princ)
75. )
76.  

M.R.

[roy_043]

Working with reactors can indeed be tricky. Nice to hear that you got it working.

[ribarm]

I've added multiple entity processing (setq ss (ssget ...)) and also included support for older CAD versions that don't have HPCOLOR sysvar...

Once again, thanks Roy... Hope routine is going to be of some help now - it's complete, but I personally don't want to place reactors into my Startup Suite (acaddoc.lsp), so I am using bare version for that case, and when I switch to Paper Space, I manually freeze that unplottable layer "HATCH-WIPEOUT"

Regards, thanks...
M.R.

[ribarm]

I've made mistake in copy-pasting pieces of codes... Now that's fixed, thanks for your patience, M.R.