Topic: Change Z value of point after using VLA-GetPoint

[Lee Mac]

Using variants/safearrays:

Code - Auto/Visual Lisp: [Select]

1. (defun c:test ( / *error* roundup8 list->variant doc hgt len lli llp lri lrp pl1 pl2 rg1 rg2 spc uli ulp uri urp wid )
2.  
3.     (defun *error* ( msg )
4.         (foreach obj (list pl1 pl2 rg1 rg2)
5.             (if (and obj (vlax-write-enabled-p obj)) (vla-delete obj))
6.         )
7.         (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
8.             (princ (strcat "\nError: " msg))
9.         )
10.         (princ)
11.     )
12.  
13.     (defun roundup8 ( n / r )
14.         (setq r (rem n 8))
15.         (if (or (equal 0.0 r 1e-8) (equal 8.0 r 1e-8)) (atof (rtos n 2 0)) (+ n (- 8 r)))
16.     )
17.  
18.     (defun list->variant ( typ lst )
19.         (vlax-make-variant
20.             (vlax-safearray-fill
21.                 (vlax-make-safearray typ (cons 0 (1- (length lst))))
22.                 lst
23.             )
24.         )
25.     )
26.    
27.     (setq doc (vla-get-activedocument (vlax-get-acad-object))
28.           spc (vla-get-modelspace doc)
29.     )
30.     (initget 6)
31.     (if (setq len (getdist "\nEnter wall length: "))
32.         (progn
33.             (setq len (roundup8 (* len 12.0)))
34.             (initget 6)
35.             (if (setq wid (getdist "\nEnter wall width: "))
36.                 (progn
37.                     (setq wid (roundup8 (* wid 12.0)))
38.                     (initget 6)
39.                     (if (setq hgt (getdist "\nEnter wall height: "))
40.                         (progn
41.                             (setq hgt (roundup8 (* hgt 12.0)))
42.                             (if (setq ulp (getpoint "\nPick upper-left wall corner: "))
43.                                 (progn
44.                                     (setq ulp (list (car ulp) (cadr ulp))
45.                                           lrp (mapcar '+ ulp  (list len (- wid)))
46.                                           uli (mapcar '+ ulp '( 8 -8))
47.                                           lri (mapcar '+ lrp '(-8  8))
48.                                           urp (list (car lrp) (cadr ulp))
49.                                           llp (list (car ulp) (cadr lrp))
50.                                           uri (list (car lri) (cadr uli))
51.                                           lli (list (car uli) (cadr lri))
52.                                           pl1 (vla-addlightweightpolyline spc (list->variant vlax-vbdouble (append ulp urp lrp llp)))
53.                                           pl2 (vla-addlightweightpolyline spc (list->variant vlax-vbdouble (append uli uri lri lli)))
54.                                     )
55.                                     (vla-put-closed pl1 :vlax-true)
56.                                     (vla-put-closed pl2 :vlax-true)
57.                                     (setq rg1 (car (vlax-safearray->list (vlax-variant-value (vla-addregion spc (list->variant vlax-vbobject (list pl1))))))
58.                                           rg2 (car (vlax-safearray->list (vlax-variant-value (vla-addregion spc (list->variant vlax-vbobject (list pl2))))))
59.                                     )
60.                                     (vla-delete pl1)
61.                                     (vla-delete pl2)
62.                                     (vla-boolean rg1 acsubtraction rg2)
63.                                     (vla-addextrudedsolid spc rg1 hgt 0.0)
64.                                     (vla-delete rg1)
65.                                 )
66.                             )
67.                         )
68.                     )
69.                 )
70.             )
71.         )
72.     )
73.     (princ)
74. )
75. (vl-load-com) (princ)

[Lee Mac]

Here's another quick example for a general wall outline:

Code - Auto/Visual Lisp: [Select]

1. (defun c:wall ( / *error* ent hgt obj off pt1 rg1 rg2 spc thk )
2.  
3.     (defun *error* ( msg )
4.         (foreach obj (vl-list* obj rg1 (append rg2 off))
5.             (if (and obj (vlax-write-enabled-p obj))
6.                 (vla-delete obj)
7.             )
8.         )
9.         (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
10.             (princ (strcat "\nError: " msg))
11.         )
12.         (princ)
13.     )
14.  
15.     (setq thk 8.0) ;; Wall thickness
16.  
17.     (if (setq pt1 (getpoint "\nPick start point: "))
18.         (progn
19.             (setq spc (vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
20.                   ent (entlast)
21.             )
22.             (vl-cmdf "_.pline" "_non" pt1)
23.             (while (= 1 (logand 1 (getvar 'cmdactive))) (vl-cmdf "\\"))
24.             (if (and (not (eq ent (setq ent (entlast))))
25.                      (= "AcDbPolyline" (vla-get-objectname (setq obj (vlax-ename->vla-object ent))))
26.                      (progn
27.                          (vla-put-closed obj :vlax-true)
28.                          (initget 6)
29.                          (setq hgt (getdist "\nSpecify wall height: "))
30.                      )
31.                 )
32.                 (progn
33.                     (if (not (LM:listclockwise-p (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget ent)))))
34.                         (setq thk (- thk))
35.                     )
36.                     (if (setq off (LM:catchapply 'vlax-invoke (list obj 'offset thk)))
37.                         (if (setq rg1 (car (LM:catchapply 'vlax-invoke (list spc 'addregion (list obj)))))
38.                             (if (setq rg2 (LM:catchapply 'vlax-invoke (list spc 'addregion off)))
39.                                 (progn
40.                                     (foreach reg rg2 (vla-boolean rg1 acsubtraction reg))
41.                                     (vla-addextrudedsolid spc rg1 hgt 0.0)
42.                                 )
43.                                 (princ "\nUnable to create internal region.")
44.                             )
45.                             (princ "\nUnable to create external region.")
46.                         )
47.                         (princ "\nWall outline too small for wall thickness.")
48.                     )
49.                 )
50.             )
51.         )
52.     )
53.     (*error* nil) (princ)
54. )
55.  
56. ;; List Clockwise-p  -  Lee Mac
57. ;; Returns T if the point list is clockwise oriented
58.  
59. (defun LM:ListClockwise-p ( lst )
60.     (minusp
61.         (apply '+
62.             (mapcar
63.                 (function
64.                     (lambda ( a b )
65.                         (- (* (car b) (cadr a)) (* (car a) (cadr b)))
66.                     )
67.                 )
68.                 lst (cons (last lst) lst)
69.             )
70.         )
71.     )
72. )
73.  
74. ;; Catch Apply  -  Lee Mac
75. ;; Applies a function to a list of parameters and catches any exceptions.
76.  
77. (defun LM:catchapply ( fnc prm / rtn )
78.     (if (not (vl-catch-all-error-p (setq rtn (vl-catch-all-apply fnc prm))))
79.         rtn
80.     )
81. )
82.  
83. ;; Active Document  -  Lee Mac
84. ;; Returns the VLA Active Document Object
85.  
86. (defun LM:acdoc nil
87.     (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
88.     (LM:acdoc)
89. )
90. (vl-load-com) (princ)

Quick demo:

[David Hall]

OMG, I can now see why I was having so much trouble.  I like your first method much better.  Thanks Lee, your awesome!!!

[Lee Mac]

OMG, I can now see why I was having so much trouble.  I like your first method much better.  Thanks Lee, your awesome!!!

Thanks David - I agree, its usually much easier to avoid variants/safearrays if possible.

[ribarm]

@Lee, I would suggest that you use (initget 7) instead of (initget 6) to avoid nil result after user presses enter while (getdist)...

[Lee Mac]

@Lee, I would suggest that you use (initget 7) instead of (initget 6) to avoid nil result after user presses enter while (getdist)...

This is not necessary as the null input is accounted for by the various if statements; furthermore, if (initget 7) were to be used, the user would have no way of exiting the program without pressing Esc & forcing an error.

[David Hall]

Lee, using your code from above, I am trying to cut a hole in the wall.  I have gotten this far

Code - Auto/Visual Lisp: [Select]

1. (defun DRAW_GATE (/ *ERROR* ROUNDUP8 DOC SPC LEN REFCORNER)
2.   (vl-load-com)
3.   (defun *ERROR* (MSG)
4.     (foreach OBJ (list PL1 PL2 RG1 RG2)
5.       (if (and OBJ (vlax-write-enabled-p OBJ))
6.    (vla-delete OBJ)
7.       )
8.     )
9.     (if   (not (wcmatch (strcase MSG t) "*break,*cancel*,*exit*"))
10.       (princ (strcat "\nError: " MSG))
11.     )
12.     (princ)
13.   )
14.  
15.   (defun ROUNDUP8 (N / R)
16.     (setq R (rem N)
17.     (if   (or (equal 0.0 R 1e-8) (equal 8.0 R 1e-8))
18.       (atof (rtos N 2 0))
19.       (+ N (- 8 R))
20.     )
21.   )
22.   (setq   DOC (vla-get-activedocument (vlax-get-acad-object))
23.    SPC (vla-get-modelspace DOC)
24.   )
25.  
26.   (initget 6)
27.   (if (setq LEN (getdist "\nEnter Distance from corner >= 15.333: "))
28.     (progn
29.       (setq LEN (ROUNDUP8 (* LEN 12.0)))
30.       (if (setq REFCORNER (getpoint "\nPick reference corner: "))
31.    (progn
32.      (if (setq
33.       REFANGLE (getangle REFCORNER
34.                "\nPick reference point on wall: "
35.           )
36.          )
37.        (setq INSPT       (polar REFCORNER REFANGLE LEN)
38.         BOX       (vlax-invoke SPC 'ADDBOX INSPT 240 240 360)
39.         SEL       (ssget '((0 . "3DSOLID")))
40.         WALL       (car (entget (ssname SEL 0)))
41.         WALLPIECE (vla-boolean WALL acsubtraction BOX)
42.  
43.        )
44.  
45.  
46.      )
47.    )
48.       )
49.     )
50.   )
51. )

but it errors out after creating the box.

Any Ideas?

Also, from code above, you set rg1 equal to the region created using car, when I try the same, it errors.


Also it should be noted that the error function needs updating, but I'm not quite sure what you were doing, so I haven't tried to change it yet.

[David Hall]

I was able to ake this work

Code: [Select]

    (setq INSPT     (polar REFCORNER REFANGLE LEN)
  BOX     (vlax-invoke SPC 'ADDBOX INSPT 240 240 360)
;;;   SEL     (ssget '((0 . "3DSOLID")))
  WALL      (car (entsel "\nPick wall: "))
  wall (vlax-ename->vla-object wall)
;;;   (vla-boolean WALL acintersection BOX)
  WALLPIECE (vla-boolean wall acsubtraction box)

    )but I thought that the acintersection created a new piece of 3dsolid, not erase everything but the intersection

[Lee Mac]

I was about to suggest converting the entity to a vla-object before issuing the boolean method, but it looks like you've got it 

Yes, the acintersection operation will return only the intersection of the two solids.