Topic: Other Flex Duct Creator

[cardirom]

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