### Author Topic: Other Flex Duct Creator  (Read 1003 times)

0 Members and 1 Guest are viewing this topic.

#### cardirom

• Mosquito
• Posts: 1
##### Other Flex Duct Creator
« on: August 25, 2022, 03:04:39 AM »
Hey everyone. Sorry, I'm french... I send you my first lisp code to create flex duct
Thank to Lee Mac for all routines I Used.
Code - Auto/Visual Lisp: [Select]
1.
2. ;;>>>>>>>>>>> Construction de gaines souples de traitement d'air en 2D
3. ;; Romain CARDINEAU
4. ;; VERSION 19
5. ;;>>>>>>>>>>
6.
7.            oDoc (vla-get-ActiveDocument oApp)
8.            oMSp (vla-get-ModelSpace oDoc)
9.    )
10. ;tan
11. (defun tan (a)
12.         (/ (sin a) (cos a))
13. )
14.
15. ;asinGA
16. ;-1<=y<=1
17. ;returns inverse sin in radians
18. (defun asin (y) (atan y (sqrt (- 1 (* y y)))))
19.
20. ;acos
21. ;-1<=y<=1
22. ;returns inverse cos in radians
23. (defun acos (y) (atan (sqrt (- 1 (* y y))) y))
24.
26.    (setq oLine (vla-AddLine oMSp  (vlax-3d-point '(1.0 1.0 0.0))  (vlax-3d-point '(10.0 10.0 0.0))))
27.     (vla-update oLine)
28.
29.    ;; Get the current color values
30.    (setq oColor (vlax-get-property oLine 'TrueColor)
31.            clrR (vlax-get-property oColor 'Red)
32.            clrG (vlax-get-property oColor 'Green)
33.            clrB (vlax-get-property oColor 'Blue)
34.    )
35.
36.    ;; Set TrueColor to blue (R=0, G=101, B=204)
37.    (vlax-invoke-method oColor 'SetRGB 0 101 204)
38.    (vlax-put-property oLine 'TrueColor oColor)
39.    (vla-update oLine)
40.
41.
42.    (entdel (entlast))
43.
44. (defun cs:linegainesouple (PO PF)
45.     oMSp
46.     (vlax-3d-point PO)
47.     (vlax-3d-point PF)
48.   )
49. )
50.
51.
52. ;; 3-Point Arc  -  Lee Mac
53. ;; Returns the Center, Start/End Angle and Radius of the
54. ;; Arc defined by three supplied points.
55. (defun LM:3PArc (p1 p2 p3 / cn m1 m2 m11 m12 m21 m22 angledebutarc anglefinarc rayonarc)
56.
57.
58.   (if (= (angle p1 p2) (angle p2 p3))
59.   (cs:linegainesouple p1 p3)
60.     (setq m1 (mid p1 p2)
61.           m2 (mid p2 p3)
62.     )
63.
64.         (setq cn
65.                 (polar m1 (- (angle p1 p2) (/ pi 2)) 1000)
66.                 (polar m1 (+ (angle p1 p2) (/ pi 2)) 1000)
67.                 (polar m2 (- (angle p2 p3) (/ pi 2)) 1000)
68.                 (polar m2 (+ (angle p2 p3) (/ pi 2)) 1000)
69.             )
70.         )
71.
72.             (if (LM:Clockwise-p p1 p2 p3)
73.                 (setq angledebutarc (angle cn p3) anglefinarc (angle cn p1))
74.                 (setq angledebutarc (angle cn p1) anglefinarc (angle cn p3))
75.             )
76.
77.             (setq rayonarc (distance cn p1))
78.
79.                 oMSp
80.                 (vlax-3d-point cn)
81.                 rayonarc
82.                         angledebutarc
83.                         anglefinarc
84.         )
85.
86.   )
87.   )
88. )
89.
90. (defun cs:arcvla (cn rayonarc angledebutarc anglefinarc)
91.                 oMSp
92.                 (vlax-3d-point cn)
93.                 rayonarc
94.                         angledebutarc
95.                         anglefinarc
96.         )
97. )
98. ;; Midpoint  -  Lee Mac
99. ;; Returns the midpoint of two points
100. (defun mid ( a b )
101.     (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) a b)
102. )
103.
104. ;; Clockwise-p  -  Lee Mac
105. ;; Returns T if p1,p2,p3 are clockwise oriented
106.
107. (defun LM:Clockwise-p ( p1 p2 p3 )
108.     (< (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
109.        (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
110.     )
111. )
112.
113. (defun Polylineentmake (lst)
114.   (entmakex (list (cons 0 "POLYLINE")
115.                   (cons 10 '(0 0 0))))
116.     (function (lambda (p)
117.                 (entmake (list (cons 0 "VERTEX") (cons 10 p))))) lst)
118.   (entmakex (list (cons 0 "SEQEND")))
119.
120. )
121.
122. (defun ARCpoly (ptcentre pt1 inclinaison numsecteur nbsecteur anglesecteur / rayon)
123.         (setq rayon (distance ptcentre pt1)
124.                 alpha (angle ptcentre pt1)
125.         )
126.         (setq ptlist nil)
127.
128.                 (repeat nbsecteur
129.                         (setq   beta (atan (* (cos inclinaison) (tan (* anglesecteur numsecteur)))))
130.
131.                         (setq   Longpoint (/ (* rayon (cos (* anglesecteur numsecteur))) (cos beta)))
132.                         (setq   PTn (polar ptcentre (+ alpha beta) Longpoint)
133.                                         ptlist (cons PTn ptlist)
134.                                         numsecteur (+ numsecteur 1)
135.                         )
136.                 )
137.
138.         (Polylineentmake ptlist)
139.
140. )
141. ;; Intersections  -  Lee Mac
142. ;; Returns a list of all points of intersection between two objects
143. ;; for the given intersection mode.
144. ;; ob1,ob2 - [vla] VLA-Objects
145. ;;     mod - [int] acextendoption enum of intersectwith method
146. (defun LM:intersections ( ob1 ob2 mod / lst rtn )
147.     (if (and (vlax-method-applicable-p ob1 'intersectwith)
148.              (vlax-method-applicable-p ob2 'intersectwith)
149.              (setq lst (vlax-invoke ob1 'intersectwith ob2 mod))
150.         )
151.         (repeat (/ (length lst) 3)
152.             (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn)
153.                   lst (cdddr lst)
154.             )
155.         )
156.     )
157.     (reverse rtn)
158. )
159.
160.
161. (defun CreerATTRIBUT (ATTinsertionpoint ATTetiquette ATTprompt ATTvaleur)
162.                         (list
163.                                 (cons 0 "ATTDEF")
164.                                 ;;(cons 8 "0") ;;Calque
165.                                 (cons 10 ATTinsertionpoint) ;insertion point
166.                                 (cons 1 ATTvaleur)
167.                                 (cons 2 ATTetiquette)
168.                                 (cons 3 ATTprompt)
169.                                 (cons 40 0.1) ;Text height
170.                                 (cons 70 1) ;mode 1:invisible
171.                         )
172.                 )
173. )
174.
175.
176. (defun CreerBLOC (selectionset BlockName InsertPoint / number BlocknameNUM en)
177.
178.         (command "_.CHPROP" selectionset "" "_LA" "0" "") ;;change le calque du jeu de selection
179.
180.         (setq number 1
181.             BlocknameNUM (strcat Blockname "#" (itoa number))
182.     )
184.                 (setq BlocknameNUM (strcat Blockname "#" (itoa (setq number (1+ number))))
185.                 )
186.     )
187.     (command "BLOC" BlocknameNUM InsertPoint selectionset "")
188.
189.         (setq n 1)
190.         (setq nfin (sslength selectionset))
191.         (while (/= n nfin)
192.                 (setq l (ssname selectionset 0))
193.                 (setq n (1+ n))
194.         (ssdel l selectionset)
195.         )
196.
197.         (command "INSERER" BlocknameNUM InsertPoint "" "" "")
198.
199. )
200.
201.
202.
203. ;;==========================
204. ;; Saisie des éléments de construction
205. ;;==========================
206.
207. (defun c:gaineflex (/ selectionset insertionpoint number Blockname FlexStart FlexEnd PlineEnt FlexDuct1 FlexDuct2 FlexDuct3 FlexDuct4
208.                         rayoncourburearc nbarc anglearc anglearctot iarc longarc01 longarc02 longarc01PK longarc02PK choixpiq episolation
209.                         clrR clrG clrB clrR01 clrG01 clrB01 clrR02 clrG02 clrB02 deltaclrR deltaclrG deltaclrB longueurGS PTC rayon angleDEB angleFIN)
210.
211.         (if (null (tblsearch "ltype" "HIDDEN8"))
212.         (command "TYPELIGNE" "CHARGER" "HIDDEN8" "zwcad.lin" "")
213.         )
214.
215.    (if (= initgainesouple nil)
216.         (while (= initgainesouple nil)
217.                 (setq initgainesouple (getdist "\nDiametre de la gaine : < 0.125 > [m]"))
218.                       (if (= initgainesouple nil) (setq initgainesouple 0.125))
219.         )
220.         (setq initgainesouple (getdist (strcat "\nDiametre de la gaine < " (rtos Dfirst) " > [m] :")))
221.    )
222.
223.    (if (= initgainesouple nil)
224.       (setq initgainesouple Dfirst)
225.       (setq Dfirst initgainesouple)
226.    )
227.
229.
230.  (setq D Dfirst)
231.
232.     (if (= initgainesoupleISO nil)
233.         (while (= initgainesoupleISO nil)
234.                 (setq initgainesoupleISO (getdist "\nEpaisseur isolation : < 50 > [mm]"))
235.                       (setq initgainesoupleISO 50)
236.         )
237.         (setq initgainesoupleISO (getdist (strcat "\nEpaisseur isolation  < " (rtos DfirstISO) " > [mm] :")))
238.    )
239.
240.    (if (= initgainesoupleISO nil)
241.       (setq initgainesoupleISO DfirstISO)
242.       (setq DfirstISO initgainesoupleISO)
243.    )
244.
245.  (setq episolation DfirstISO)
246.  (setq D (+ D (* 0.002 episolation)))
247.
248.
249.  (setq FlexStart (getpoint "\n Point début : "))
250.  (setq FlexEnd (getpoint FlexStart "\n direction : "))
251.  (setq FlexEnd (polar FlexStart (angle FlexStart FlexEnd) 0.0625))
252.
253.  (command "POLYLIGN" FlexStart "LA" D D FlexEnd "arc")
254.  (while (> (getvar "cmdactive") 0)
255.   (command PAUSE)
256.  )
257.
258.  (setq PlineEnt (entget(entlast)))
259.  ;;(vlax-put-property (vlax-ename->vla-object (entlast)) 'Layer "0")
260.  ;;(vlax-put-property (vlax-ename->vla-object (entlast)) 'ConstantWidth 0)
262.  (setq CHEM (vlax-ename->vla-object (cdr(assoc -1 PlineEnt))))
263.
264.  ;; calculer la longueur du chemin
265.  (setq LCHEM (vlax-get-property  CHEM 'Length))
266.  ;;(setq LCHEM (vlax-curve-getDistAtPoint CHEM (vlax-curve-getEndPoint CHEM)))
267.  ;;(vlax-invoke-method oColor 'SetRGB 90 90 90)
268.  ;;(vlax-put-property (vlax-ename->vla-object (entlast)) 'TrueColor oColor)
269.
270.
271.         (setq   clrR 100
272.                 clrG 100
273.                 clrB 100
274.                 clrR01 20 ;;20
275.                 clrG01 20 ;;20
276.                 clrB01 20 ;;20
277.                 clrR02 210 ;;210
278.                 clrG02 210 ;;210
279.                 clrB02 210 ;;210
281.                 rayoncourburearc (* D 1.50)
282.         )
283.
284.  (if (> rayoncourburearc (* D 0.51)) (setq rayoncourburearc rayoncourburearc) (setq rayoncourburearc (* D 0.51)))
285.
286.
287.     (setq PM (vlax-curve-getParamAtDist CHEM LCHEM))
288.     (setq PT (vlax-curve-getPointAtDist CHEM LCHEM))
289.     (setq FDER (vlax-curve-getfirstderiv CHEM PM))
290.     (setq PTDERIV (mapcar '+ PT FDER))
291.     (setq PTC1 (polar PT (+ (angle PTDERIV PT) pi) (* 2 D)))
292.         (setq PTC2 (polar PT (+ (angle PT PTDERIV) pi) (* 2 D)))
293.
294.
295.         (command "LIGNE" PT PT "")
296.         (setq ename1 (entlast))
297.         (setq PASS1 (vlax-ename->vla-object ename1))
298.
299.         (command "CERCLE" PT (/ D 1.5) "")
300.         (setq ename2 (entlast))
301.         (setq PASS2 (vlax-ename->vla-object ename2))
302.
303.
304.         (setq choixpiq "Plafond")
305.
306.         (while (= 5 (car (setq gr (grread 't 13 0))))
308.                                 (if (<= (distance cp PTC1) (distance cp PTC2)) (setq DELTA 1) (setq DELTA 2))
309.
310.                 (if (= DELTA 1)
311.                         (vlax-put-property PASS1 'EndPoint (vlax-3D-point PTC1))
312.                         (vlax-put-property PASS1 'EndPoint (vlax-3D-point PT))
313.                 )
314.                 (if (= DELTA 1)
316.                         (vlax-put-property PASS2 'Radius (/ D 1.5))
317.                 )
318.
319.                 (if (= DELTA 1)
320.            (setq choixpiq "Mural")
321.            (setq choixpiq "Plafond")
322.                 )
323.
324.                 (vlax-invoke-method PASS1 'update)
325.                 (vlax-invoke-method PASS2 'update)
326.                 (redraw)
327.         )
328.
329.         (entdel ename1)
330.         (entdel ename2)
331.
332.
333.         ;;(initget 2 "P M")
334.         ;;(setq choixpiq (getkword "\nPiquage/Mural/<Plafond> :"))
335.     ;;(if (or (equal choixpiq "M") (equal choixpiq "m"))
336.            ;;(setq choixpiq "Mural")
337.            ;;(setq choixpiq "Plafond")
338.     ;;)
339.
340.         (if (> LCHEM (* rayoncourburearc 0.50))
341.                         (if (> LCHEM rayoncourburearc)
342.                                 (setq rayoncourburearc rayoncourburearc)
343.                                 (setq rayoncourburearc LCHEM)
344.                         )
345.                 )
346.                 (setq choixpiq "Mural")
347.         )
348.
349. (if (= choixpiq "Plafond")
350.
351.  ;;(command "HACHURES" "_P" "SOLID" "_S" "_L" "" "")
352.   ;;(vlax-put-property (vlax-ename->vla-object (entlast)) 'Layer "0")
354.  ;;(vla-update obj)
355.
356.    ;; Get the current color values
357.    ;;(setq oColor (vlax-get-property obj 'TrueColor)
358.            ;;clrR (vlax-get-property oColor 'Red)
359.            ;;clrG (vlax-get-property oColor 'Green)
360.            ;;clrB (vlax-get-property oColor 'Blue)
361.    ;;)
362.
363.         (setq i 0)
365.                 (setq deltaclrR (fix (+ clrR01 (* (- clrR02 clrR01) (/ (* D (cos (* (- nbdegrade i) (/ pi (* 2 nbdegrade))))) D)))))
366.                 (setq deltaclrG (fix (+ clrG01 (* (- clrG02 clrG01) (/ (* D (cos (* (- nbdegrade i) (/ pi (* 2 nbdegrade))))) D)))))
367.                 (setq deltaclrB (fix (+ clrB01 (* (- clrB02 clrB01) (/ (* D (cos (* (- nbdegrade i) (/ pi (* 2 nbdegrade))))) D)))))
368.                         (list
369.                                 (cons 0 "CIRCLE")
370.                                 (cons 10 (vlax-curve-getEndPoint CHEM))
371.                                 (cons 40 (/ (* D (cos (* i (/ pi (* 2 nbdegrade))))) 2))
372.                         )
373.                 )
375.                 (setq obj (vlax-ename->vla-object (entlast)))
376.                 (vlax-invoke-method oColor 'SetRGB deltaclrR deltaclrG deltaclrB)
377.                 (vlax-put-property (vlax-ename->vla-object (entlast)) 'TrueColor oColor)
378.
379.                 (command "-HACHURES" "_P" "SOLID" "_S" (entlast) "" "")
381.                 (setq obj (vlax-ename->vla-object (entlast)))
382.                 (vlax-put-property (vlax-ename->vla-object (entlast)) 'TrueColor oColor)
383.                 (setq i (+ i 1))
384.         )
385.  )
386. )
387.
388.
389.
390.         (setq i 0)
392.                 (setq deltaclrR (fix (+ clrR01 (* (- clrR02 clrR01) (/ (* D (cos (* (- nbdegrade i) (/ pi (* 2 nbdegrade))))) D)))))
393.                 (setq deltaclrG (fix (+ clrG01 (* (- clrG02 clrG01) (/ (* D (cos (* (- nbdegrade i) (/ pi (* 2 nbdegrade))))) D)))))
394.                 (setq deltaclrB (fix (+ clrB01 (* (- clrB02 clrB01) (/ (* D (cos (* (- nbdegrade i) (/ pi (* 2 nbdegrade))))) D)))))
395.                 (setq FlexDuct3 (vlax-invoke CHEM 'offset (/ D 1000)))
397.                 (vlax-invoke-method oColor 'SetRGB deltaclrR deltaclrG deltaclrB)
398.                 (vlax-put-property (vlax-ename->vla-object (entlast)) 'TrueColor oColor)
399.                 (vlax-put-property (vlax-ename->vla-object (entlast)) 'ConstantWidth (* D (cos (* i (/ pi (* 2 nbdegrade))))))
400.                 ;;(vlax-invoke-method FlexDuct3 'update)
401.                 (setq i (+ i 1))
402.         )
403.
404.   (setq D (/ D 2))
405.   (setq PAS (+ (* 0.10 D) 0.028))
406.
407.  (vlax-invoke-method oColor 'SetRGB clrR clrG clrB)
408.
409.  ;;============================ construction des polylignes parallèles au chemin ==========================
410.
411.  (setq FlexDuct1 (vlax-invoke CHEM 'offset D))
412.  (setq obj1 (vlax-ename->vla-object (entlast)))
413.  (vlax-put-property (vlax-ename->vla-object (entlast)) 'ConstantWidth 0)
415.  (vla-update obj1)
416.  (setq PTG (vlax-curve-getEndPoint (vlax-ename->vla-object (entlast))))
417.
418.  (setq FlexDuct2 (vlax-invoke CHEM 'offset (- D)))
419.  (setq obj2 (vlax-ename->vla-object (entlast)))
420.  (vlax-put-property (vlax-ename->vla-object (entlast)) 'ConstantWidth 0)
422.  (vla-update obj2)
423.  (setq PTD (vlax-curve-getEndPoint (vlax-ename->vla-object (entlast))))
424.
425.         (if (= choixpiq "Plafond")
426.                         (command "ARC" "C" (vlax-curve-getEndPoint CHEM) PTG PTD "")
427.                         (setq obj (vlax-ename->vla-object (entlast)))
429.                         (vla-update obj)
430.
431.                         (command "CERCLE" (vlax-curve-getEndPoint CHEM) (* D 1.25) "")
432.                         (setq obj (vlax-ename->vla-object (entlast)))
433.                         (setq PTG (vlax-invoke obj1 'intersectwith obj acextendnone))
434.                         (setq PTD (vlax-invoke obj2 'intersectwith obj acextendnone))
435.                         (vla-delete obj)
436.
437.                         (command "ARC" "C" (vlax-curve-getEndPoint CHEM) PTG PTD "")
438.                         (setq obj (vlax-ename->vla-object (entlast)))
439.                         (vla-ScaleEntity obj (vlax-3D-point (vlax-curve-getEndPoint CHEM)) (/ (* D 1.25) (distance (vlax-curve-getEndPoint CHEM) PTG)))
441.                         (vla-update obj)
442.
443.                 )
444.         )
445.
446. ;;======= Construction des lignes perpendiculaires au chemin ======
447.
448.
449.
450.   (setq PK 0)
451.
452.   (while (<= PK (- LCHEM (if (= choixpiq "Plafond") rayoncourburearc 0)))
453.
454.     ;; déterminer le paramètre au pk courant
455.
456.     (setq PM (vlax-curve-getParamAtDist CHEM PK))
457.
458.     ;; déterminer le point au pk courant
459.
460.     (setq PT (vlax-curve-getPointAtDist CHEM PK))
461.
462.     ;; déterminer la dérivée première
463.
464.     (setq FDER (vlax-curve-getfirstderiv CHEM PM))
465.
466.     ;; déterminer le point qui construit la tangente à la courbe au point PT
467.
468.     (setq PTDERIV (mapcar '+ PT FDER))
469.
470.     ;; déterminer les points perpendiculaires à PT à une distance D
471.
472.
473.     (setq PTG (polar PT (+ (angle PT PTDERIV) (/ pi 2)) D))
474.
475.     (setq PTD (polar PT (- (angle PT PTDERIV) (/ pi 2)) D))
476.
477.
478.         (if (= PK 0) (setq Alisere 0 Dlisere 0) (setq   Alisere (* D 0.12) Dlisere (* D 0.4)))
479.
480.                  ;; passer au pk suivant
481.                 (setq PK (+ PK PAS))
482.
483.      ;; tracer la ligne
484.         (setq PTM (mid PTD PTG)
485.                         P4 (polar PTM (angle PTG PTD) Alisere)
486.                         P5 (polar PTM (angle PTG PTD) (+ Alisere Dlisere))
487.         )
488.
489.     (cs:linegainesouple PTG P4)
491.
492.         (cs:linegainesouple PTD P5)
494.   )
495.
496. ;;=====================================================================================================================================================
497. ;;=============================construction des arcs si gaine souple piquage plafonnier================================================================
498. ;;=====================================================================================================================================================
499.
500. (if (= choixpiq "Plafond")
501.
502.         (setq   PK (- PK PAS)
503.                 nbarc (fix (/ (* pi rayoncourburearc) (* 2 PAS)))
504.                 anglearc (/ (/ pi 2) nbarc) ;;en radians
505.                 iarc -1
506.         )
507.
508.         (repeat (+ nbarc 1)
509.                         (setq iarc (+ iarc 1)
510.                                 anglearctot (* anglearc iarc)
511.                         )
512.                         (if (= (- nbarc 1) iarc) (setq anglearctot (/ pi 2)))
513.                         (setq   longarc01 (* rayoncourburearc (sin anglearctot))
514.                                 longarc02 (* (+ rayoncourburearc D) (sin anglearctot))
515.                                 longarc01PK (+ longarc01 PK)
516.                                 longarc02PK (+ longarc02 PK)
517.                         )
518.                         (if (= (- nbarc 1) iarc) (setq longarc01PK LCHEM longarc02PK (+ D LCHEM)))
519.                         (setq   PM (vlax-curve-getParamAtDist CHEM longarc01PK)
520.                                 PT (vlax-curve-getPointAtDist CHEM longarc01PK)
521.                                 FDER (vlax-curve-getfirstderiv CHEM PM)
522.                                 PTDERIV (mapcar '+ PT FDER)
523.                         )
524.
525.                         (setq PTG (polar PT (+ (angle PT PTDERIV) (/ pi 2)) D)
526.                                         PTD (polar PT (- (angle PT PTDERIV) (/ pi 2)) D)
527.                                         ptcentre (mid PTG PTD)
528.                                 )
529.
530.                         (if (>= longarc02PK LCHEM)
531.                                 (setq   PM (vlax-curve-getParamAtDist CHEM LCHEM)
532.                                         PT (vlax-curve-getPointAtDist CHEM LCHEM)
533.                                         FDER (vlax-curve-getfirstderiv CHEM PM)
534.                                         PTDERIV (mapcar '+ PT FDER)
535.                                         PTM (polar PT (angle PT PTDERIV) (- longarc02PK LCHEM))
536.                                 )
537.                                 (setq   PM (vlax-curve-getParamAtDist CHEM longarc02PK)
538.                                         PT (vlax-curve-getPointAtDist CHEM longarc02PK)
539.                                         FDER (vlax-curve-getfirstderiv CHEM PM)
540.                                         PTDERIV (mapcar '+ PT FDER)
541.                                         PTM (polar PT (+ (angle PT PTDERIV) (/ pi 2)) 0)
542.                                 )
543.                         )
544.
545.                         (setq P1 PTG P2 PTM P3 PTD)
546.
547.                         (if (= (angle P1 P2) (angle P2 P3))
548.                                 ()
549.                                         (setq m1 (mid P1 P2)
550.                                                         m2 (mid P2 P3)
551.                                         )
552.
553.                                         (setq PTC
554.                                                         (polar m1 (- (angle P1 P2) (/ pi 2)) 1000)
555.                                                         (polar m1 (+ (angle P1 P2) (/ pi 2)) 1000)
556.                                                         (polar m2 (- (angle P2 P3) (/ pi 2)) 1000)
557.                                                         (polar m2 (+ (angle P2 P3) (/ pi 2)) 1000)
558.                                                 )
559.                                         )
560.
561.                                         (setq rayonarc (distance PTC P1))
562.
563.                                         (setq   alpha3 (angle P1 P3)
564.                                                         alpha4 (acos (/ Alisere rayonarc))
565.                                                         P4 (polar PTC (+ alpha4 alpha3) rayonarc)
566.                                                         alpha5 (acos (/ (+ Alisere Dlisere) rayonarc))
567.                                                         P5 (polar PTC (+ alpha5 alpha3) rayonarc)
568.                                                         alpha6 (angle PTC (mid P5 P3))
569.                                                         P6 (polar PTC alpha6 rayonarc)
570.                                         )
571.
572.                                         (setq anglesecteur (/ pi 21)
573.                                                 numsecteur 0
574.                                                 nbsecteur 8
575.                                                 anglearctot (- (/ pi 2) anglearctot)
576.                                         )
577.
578.                                         (ARCpoly ptcentre PTD anglearctot numsecteur nbsecteur anglesecteur)
580.
581.                                         (setq numsecteur 10
582.                                                   nbsecteur 12
583.                                         )
584.
585.                                         (ARCpoly ptcentre PTD anglearctot numsecteur nbsecteur anglesecteur)
587.
588.
589.                                 )
590.                         )
591.                 )
592.         )
593.    )
594. )
595.
596.
597.
598.
599.
600. ;;=====================================================================================================================================================
601. ;;============================= Définition des attributs et Construction du bloc gaine souple =========================================================
602. ;;=====================================================================================================================================================
603.
604.                 (vlax-invoke-method CHEM 'delete) ;;supprime la polyligne de construction CHEM
605.
606.         (if (= choixpiq "Mural")
607.                         (setq longueurGS LCHEM)
608.                         (setq longueurGS (+ LCHEM (* rayoncourburearc (- (/ pi 2) 1))))
609.                 )
610.                 (setq longueurGS (rtos longueurGS 2 4))
611.                 (setq D (rtos (* 2000 (- D (* 0.001 episolation))) 2 0))
612.                 (setq episolation (rtos episolation 2 0))
613.
614.                 ;;CreerATTRIBUT ( ATTinsertionpoint ATTetiquette ATTprompt ATTvaleur )
615.                 (CreerATTRIBUT FlexStart  "DIAMETRE" "Diamètre:" D)
617.
618.                 (CreerATTRIBUT FlexStart "LONGUEUR" "Longueur:" longueurGS)
620.
621.                 (CreerATTRIBUT FlexStart "ISOLATION" "Isolation:" episolation)
623.
624.                 ;;CreerBLOC (selectionset BlockName InsertPoint)
625.                 (CreerBLOC selectionset "GAINE_SOUPLE" FlexStart )
626.                 (command "" "" "")
627.   (princ)
628. )
629.
630.