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