Topic: 3darraypath+scale.lsp

[ribarm]

Before I was absent, I remember someone asked for arraypath but with options to stretch or (I did it with scale) every next block entity along path... So this is now useful for better lofting procedure - I added also an option for incremental rotation... Starting block is arrayed along path so that Z axis is aligned with tangents of curve, and starting X axis is horizontal - that was logical option... So I hope this will help in lofting...

Code - Auto/Visual Lisp: [Select]

1. (defun c:3darraypath+scale ( / *error* v^v adoc ss pea bl f pa n chD r scf chXYZ scfX scfY scfZ scfXY scfZY scfZX d dx k pt vx vy vz )
2.  
3.   (vl-load-com)
4.  
5.   (defun *error* ( msg )
6.     (if pea (setvar 'peditaccept pea))
7.     (vla-endundomark adoc)
8.     (if msg (prompt msg))
9.     (princ)
10.   )
11.  
12.   (defun v^v ( u v / cda )
13.     (defun cda ( p ) (cdr (append p p)))
14.     (mapcar '- (mapcar '* (cda u) (cdr (cda v))) (mapcar '* (cdr (cda u)) (cda v)) '(0.0 0.0 0.0))
15.   )
16.  
17.   (setq pea (getvar 'peditaccept))
18.   (setvar 'peditaccept 1)
19.   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
20.   (vla-startundomark adoc)
21.   (command "_.ucs" "_W")
22.   (setq ss (ssadd))
23.   (while  (not
24.             (and
25.               (eq (cdr (assoc 0 (entget (setq bl (car (entsel "\nPick block in 2D")))))) "INSERT")
26.               (eq (vla-get-isxref (vla-item (vla-get-blocks adoc) (vla-get-effectivename (vlax-ename->vla-object bl)))) :vlax-false)
27.             )
28.           )
29.   )
30.   (while  (not
31.             (wcmatch (cdr (assoc 0 (entget (setq pa (car (entsel "\nPick 3d path curve")))))) "*POLYLINE,SPLINE,LINE,ARC,CIRCLE,ELLIPSE,HELIX")
32.           )
33.   )
34.  
35.   (command "_.explode" bl)
36.   (while (> (getvar 'cmdactive) 0) (command ""))
37.   (if (vl-every '(lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "*POLYLINE,LINE,ARC,SPLINE,ELLIPSE,CIRCLE")) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_P")))))
38.     (setq f t)
39.   )
40.   (command "_.undo" "_B")
41.  
42.   (initget 7)
43.   (setq n (getint "\nSpecify number of blocks array segments : "))
44.   (initget 1 "2D 3D")
45.   (setq chD (getkword "\nScaling along path [2D/3D] : "))
46.   (if (eq chD "3D")
47.     (progn
48.       (setq scf (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
49.       (if (null scf) (setq scf (/ 1.0 n)))
50.     )
51.     (progn
52.       (initget 1 "X Y Z XY ZY ZX")
53.       (setq chXYZ (getkword "\nScaling along path in direction of axis [X/Y/Z/XY/ZY/ZX] : "))
54.       (cond
55.         ( (eq chXYZ "X")
56.           (setq scfX (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
57.           (if (null scfX) (setq scfX (/ 1.0 n)))
58.         )
59.         ( (eq chXYZ "Y")
60.           (setq scfY (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
61.           (if (null scfY) (setq scfY (/ 1.0 n)))
62.         )
63.         ( (eq chXYZ "Z")
64.           (setq scfZ (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
65.           (if (null scfZ) (setq scfZ (/ 1.0 n)))
66.         )
67.         ( (eq chXYZ "XY")
68.           (setq scfXY (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
69.           (if (null scfXY) (setq scfXY (/ 1.0 n)))
70.         )
71.         ( (eq chXYZ "ZY")
72.           (setq scfZY (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
73.           (if (null scfZY) (setq scfZY (/ 1.0 n)))
74.         )
75.         ( (eq chXYZ "ZX")
76.           (setq scfZX (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
77.           (if (null scfZX) (setq scfZX (/ 1.0 n)))
78.         )
79.       )
80.     )
81.   )
82.   (setq r (getdist (strcat "\nPick or specify rotation factor increment between 2 adjacent blocks in decimal degrees <" (rtos (/ 360.0 n) 2 15) "> : ")))
83.   (if (null r) (setq r (/ 360.0 n)))
84.   (setq d (- (vlax-curve-getdistatparam pa (vlax-curve-getendparam pa)) (vlax-curve-getdistatparam pa (vlax-curve-getstartparam pa))))
85.   (setq dx (/ d (float n)))
86.   (setq k -1)
87.   (repeat (1+ n)
88.     (setq pt (vlax-curve-getpointatdist pa (* dx (setq k (1+ k)))))
89.     (setq vz (vlax-curve-getfirstderiv pa (vlax-curve-getparamatpoint pa pt)))
90.     (setq vx (v^v vz '(0.0 0.0 1.0)))
91.     (setq vy (v^v vz vx))
92.     (command "_.ucs" "_3P" pt (mapcar '+ pt vx) (mapcar '+ pt vy))
93.     (cond
94.       ( (not (null scf))
95.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) (+ 1.0 (* scf k)) (+ 1.0 (* scf k)) (* r k))
96.         (if f
97.           (progn
98.             (command "_.explode" (entlast))
99.             (while (> (getvar 'cmdactive) 0) (command ""))
100.             (if (vl-every '(lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "LINE,ARC")) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_P")))))
101.               (progn
102.                 (command "_.pedit" "_M" (ssget "_P") "" "_J")
103.                 (while (> (getvar 'cmdactive) 0) (command ""))
104.               )
105.             )
106.           )
107.         )
108.         (ssadd (entlast) ss)
109.       )
110.       ( (not (null scfX))
111.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
112.         (vla-put-XScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfX k)))
113.         (if f
114.           (progn
115.             (command "_.explode" (entlast))
116.             (while (> (getvar 'cmdactive) 0) (command ""))
117.             (if (vl-every '(lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "LINE,ARC")) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_P")))))
118.               (progn
119.                 (command "_.pedit" "_M" (ssget "_P") "" "_J")
120.                 (while (> (getvar 'cmdactive) 0) (command ""))
121.               )
122.             )
123.           )
124.         )
125.         (ssadd (entlast) ss)
126.       )
127.       ( (not (null scfY))
128.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
129.         (vla-put-YScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfY k)))
130.         (if f
131.           (progn
132.             (command "_.explode" (entlast))
133.             (while (> (getvar 'cmdactive) 0) (command ""))
134.             (if (vl-every '(lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "LINE,ARC")) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_P")))))
135.               (progn
136.                 (command "_.pedit" "_M" (ssget "_P") "" "_J")
137.                 (while (> (getvar 'cmdactive) 0) (command ""))
138.               )
139.             )
140.           )
141.         )
142.         (ssadd (entlast) ss)
143.       )
144.       ( (not (null scfZ))
145.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
146.         (vla-put-ZScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfZ k)))
147.         (if f
148.           (progn
149.             (command "_.explode" (entlast))
150.             (while (> (getvar 'cmdactive) 0) (command ""))
151.             (if (vl-every '(lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "LINE,ARC")) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_P")))))
152.               (progn
153.                 (command "_.pedit" "_M" (ssget "_P") "" "_J")
154.                 (while (> (getvar 'cmdactive) 0) (command ""))
155.               )
156.             )
157.           )
158.         )
159.         (ssadd (entlast) ss)
160.       )
161.       ( (not (null scfXY))
162.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
163.         (vla-put-XScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfXY k)))
164.         (vla-put-YScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfXY k)))
165.         (if f
166.           (progn
167.             (command "_.explode" (entlast))
168.             (while (> (getvar 'cmdactive) 0) (command ""))
169.             (if (vl-every '(lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "LINE,ARC")) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_P")))))
170.               (progn
171.                 (command "_.pedit" "_M" (ssget "_P") "" "_J")
172.                 (while (> (getvar 'cmdactive) 0) (command ""))
173.               )
174.             )
175.           )
176.         )
177.         (ssadd (entlast) ss)
178.       )
179.       ( (not (null scfZY))
180.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
181.         (vla-put-ZScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfZY k)))
182.         (vla-put-YScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfZY k)))
183.         (if f
184.           (progn
185.             (command "_.explode" (entlast))
186.             (while (> (getvar 'cmdactive) 0) (command ""))
187.             (if (vl-every '(lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "LINE,ARC")) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_P")))))
188.               (progn
189.                 (command "_.pedit" "_M" (ssget "_P") "" "_J")
190.                 (while (> (getvar 'cmdactive) 0) (command ""))
191.               )
192.             )
193.           )
194.         )
195.         (ssadd (entlast) ss)
196.       )
197.       ( (not (null scfZX))
198.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
199.         (vla-put-ZScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfZX k)))
200.         (vla-put-XScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfZX k)))
201.         (if f
202.           (progn
203.             (command "_.explode" (entlast))
204.             (while (> (getvar 'cmdactive) 0) (command ""))
205.             (if (vl-every '(lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "LINE,ARC")) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_P")))))
206.               (progn
207.                 (command "_.pedit" "_M" (ssget "_P") "" "_J")
208.                 (while (> (getvar 'cmdactive) 0) (command ""))
209.               )
210.             )
211.           )
212.         )
213.         (ssadd (entlast) ss)
214.       )
215.     )
216.     (command "_.ucs" "_P")
217.   )
218.   (sssetfirst nil ss)
219.   (*error* nil)
220. )
221.  

Regards, M.R.

[andy_lee]

Before I was absent, I remember someone asked for arraypath but with options to stretch or (I did it with scale) every next block entity along path... So this is now useful for better lofting procedure - I added also an option for incremental rotation... Starting block is arrayed along path so that Z axis is aligned with tangents of curve, and starting X axis is horizontal - that was logical option... So I hope this will help in lofting...

Hi , ribarm,　Why don't you upload demo ?

[ribarm]

Hi , ribarm,　Why don't you upload demo ?

Here is my new version which creates regions as cross sections...
I'll upload small video gif demonstration...

Code - Auto/Visual Lisp: [Select]

1. (defun c:3darraypath+scale-regs ( / *error* v^v foo qaf adoc ms ss sss ssp sspl i ent bl f pa n chD r scf chXYZ scfX scfY scfZ scfXY scfZY scfZX d dx k pt vx vy vz regl )
2.  
3.   (vl-load-com)
4.  
5.   (defun *error* ( msg )
6.     (if qaf (setvar 'qaflags qaf))
7.     (vla-endundomark adoc)
8.     (if msg (prompt msg))
9.     (princ)
10.   )
11.  
12.   (defun v^v ( u v / cda )
13.     (defun cda ( p ) (cdr (append p p)))
14.     (mapcar '- (mapcar '* (cda u) (cdr (cda v))) (mapcar '* (cdr (cda u)) (cda v)) '(0.0 0.0 0.0))
15.   )
16.  
17.   (defun foo ( f )
18.     (if f
19.       (progn
20.         (command "_.explode" (entlast))
21.         (while (> (getvar 'cmdactive) 0) (command ""))
22.         (setq ssp (ssget "_P"))
23.         (setq sspl (ssadd))
24.         (setq i -1)
25.         (while (setq ent (ssname ssp (setq i (1+ i))))
26.           (if (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
27.             (progn
28.               (ssadd ent sspl)
29.               (ssdel ent ssp)
30.             )
31.           )
32.         )
33.         (cond
34.           ( (eq (sslength sspl) 1)
35.             (command "_.explode" sspl)
36.             (while (> (getvar 'cmdactive) 0) (command ""))
37.             (setq i -1)
38.             (while (setq ent (ssname (ssget "_P") (setq i (1+ i))))
39.               (ssadd ent ssp)
40.             )
41.           )
42.           ( (> (sslength sspl) 1)
43.             (setvar 'qaflags 1)
44.             (command "_.explode" sspl)
45.             (while (> (getvar 'cmdactive) 0) (command ""))
46.             (setvar 'qaflags 0)
47.             (setq i -1)
48.             (while (setq ent (ssname (ssget "_P") (setq i (1+ i))))
49.               (ssadd ent ssp)
50.             )
51.           )
52.         )
53.         (setq regl (vlax-invoke ms 'AddRegion (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssp))))))
54.         (mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssp))))
55.         (setq sss (ssadd))
56.         (foreach reg regl
57.           (ssadd (vlax-vla-object->ename reg) sss)
58.         )
59.         (command "_.union" sss "")
60.         (ssadd (entlast) ss)
61.       )
62.     )
63.   )
64.  
65.   (setq qaf (getvar 'qaflags))
66.   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
67.   (setq ms (vlax-get adoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
68.   (vla-startundomark adoc)
69.   (command "_.ucs" "_W")
70.   (setq ss (ssadd))
71.   (while  (not
72.             (and
73.               (eq (cdr (assoc 0 (entget (setq bl (car (entsel "\nPick block in 2D")))))) "INSERT")
74.               (eq (vla-get-isxref (vla-item (vla-get-blocks adoc) (vla-get-effectivename (vlax-ename->vla-object bl)))) :vlax-false)
75.             )
76.           )
77.   )
78.   (while  (not
79.             (wcmatch (cdr (assoc 0 (entget (setq pa (car (entsel "\nPick 3d path curve")))))) "*POLYLINE,SPLINE,LINE,ARC,CIRCLE,ELLIPSE,HELIX")
80.           )
81.   )
82.  
83.   (command "_.explode" bl)
84.   (while (> (getvar 'cmdactive) 0) (command ""))
85.   (if (vl-every '(lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "*POLYLINE,LINE,ARC,SPLINE,ELLIPSE,CIRCLE")) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_P")))))
86.     (setq f t)
87.   )
88.   (command "_.undo" "_B")
89.  
90.   (initget 7)
91.   (setq n (getint "\nSpecify number of blocks array segments : "))
92.   (initget 1 "2D 3D")
93.   (setq chD (getkword "\nScaling along path [2D/3D] : "))
94.   (if (eq chD "3D")
95.     (progn
96.       (setq scf (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
97.       (if (null scf) (setq scf (/ 1.0 n)))
98.     )
99.     (progn
100.       (initget 1 "X Y Z XY ZY ZX")
101.       (setq chXYZ (getkword "\nScaling along path in direction of axis [X/Y/Z/XY/ZY/ZX] : "))
102.       (cond
103.         ( (eq chXYZ "X")
104.           (setq scfX (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
105.           (if (null scfX) (setq scfX (/ 1.0 n)))
106.         )
107.         ( (eq chXYZ "Y")
108.           (setq scfY (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
109.           (if (null scfY) (setq scfY (/ 1.0 n)))
110.         )
111.         ( (eq chXYZ "Z")
112.           (setq scfZ (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
113.           (if (null scfZ) (setq scfZ (/ 1.0 n)))
114.         )
115.         ( (eq chXYZ "XY")
116.           (setq scfXY (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
117.           (if (null scfXY) (setq scfXY (/ 1.0 n)))
118.         )
119.         ( (eq chXYZ "ZY")
120.           (setq scfZY (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
121.           (if (null scfZY) (setq scfZY (/ 1.0 n)))
122.         )
123.         ( (eq chXYZ "ZX")
124.           (setq scfZX (getdist (strcat "\nPick or specify scale factor increment between 2 adjacent blocks <" (rtos (/ 1.0 n) 2 15) "> : ")))
125.           (if (null scfZX) (setq scfZX (/ 1.0 n)))
126.         )
127.       )
128.     )
129.   )
130.   (setq r (getdist (strcat "\nPick or specify rotation factor increment between 2 adjacent blocks in decimal degrees <" (rtos (/ 360.0 n) 2 15) "> : ")))
131.   (if (null r) (setq r (/ 360.0 n)))
132.   (setq d (- (vlax-curve-getdistatparam pa (vlax-curve-getendparam pa)) (vlax-curve-getdistatparam pa (vlax-curve-getstartparam pa))))
133.   (setq dx (/ d (float n)))
134.   (setq k -1)
135.   (repeat (1+ n)
136.     (setq pt (vlax-curve-getpointatdist pa (* dx (setq k (1+ k)))))
137.     (setq vz (vlax-curve-getfirstderiv pa (vlax-curve-getparamatpoint pa pt)))
138.     (setq vx (v^v vz '(0.0 0.0 1.0)))
139.     (setq vy (v^v vz vx))
140.     (command "_.ucs" "_3P" pt (mapcar '+ pt vx) (mapcar '+ pt vy))
141.     (cond
142.       ( (not (null scf))
143.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) (+ 1.0 (* scf k)) (+ 1.0 (* scf k)) (* r k))
144.         (foo f)
145.       )
146.       ( (not (null scfX))
147.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
148.         (vla-put-XScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfX k)))
149.         (foo f)
150.       )
151.       ( (not (null scfY))
152.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
153.         (vla-put-YScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfY k)))
154.         (foo f)
155.       )
156.       ( (not (null scfZ))
157.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
158.         (vla-put-ZScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfZ k)))
159.         (foo f)
160.       )
161.       ( (not (null scfXY))
162.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
163.         (vla-put-XScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfXY k)))
164.         (vla-put-YScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfXY k)))
165.         (foo f)
166.       )
167.       ( (not (null scfZY))
168.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
169.         (vla-put-ZScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfZY k)))
170.         (vla-put-YScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfZY k)))
171.         (foo f)
172.       )
173.       ( (not (null scfZX))
174.         (command "_.insert" (cdr (assoc 2 (entget bl))) '(0.0 0.0 0.0) 1.0 1.0 (* r k))
175.         (vla-put-ZScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfZX k)))
176.         (vla-put-XScaleFactor (vlax-ename->vla-object (entlast)) (+ 1.0 (* scfZX k)))
177.         (foo f)
178.       )
179.     )
180.     (command "_.ucs" "_P")
181.   )
182.   (sssetfirst nil ss)
183.   (*error* nil)
184. )
185.  

[ribarm]

I've modified my last code to make it more concise, but functionality remained...

M.R.