gile

Salut Mac, On parle de "récusivité" pour une fonction qui s'appelle elle même dans sa définition j'ai découvert çà ici où il y a d'autres liens vers des forums en anglais. Je trouve çà puissant et très élégant. On aurait pu écrire, de manière "itérative" : (defun remove-doubles (lst / lst2) (while (car lst) (setq lst2 (cons (car lst) lst2) lst (vl-remove (car lst) lst) ) ) (reverse lst2) ) A plus...

Salut MAC, pour ta première question je te propose ce code façon "récursive" : ;;; REMOVE_DOUBLES - Suprime tous les doublons d'une liste (defun REMOVE_DOUBLES (lst) (cond ((null lst) nil) (T (cons (car lst) (REMOVE_DOUBLES (vl-remove (car lst) lst))) ) ) ) A plus

Merci pour les commentaires, çà ne me décourage pas bien au contraire ! Je vais éditer le code ci-dessus pour y introduire cette modification et corriger une petite erreur concernant l'affichage de la masse totale. Mais comme le dit Tramber çà ne va pas beaucoup raccourcir le tout !

C'est super ! C'est exactement ce dont j'avais besoin et çà m'a permis de mettre mon nez dans Visual LISP et Active X, ce qui m'ouvre de nouveaux horizons. J'ai pondu un truc qui peut servir, je l'ai mis dans ce forum. A plus. [Edité le 23/5/2005 par gile]

Salut, voilà une routine qui permet de créer un point sur le centre de gravité d'une structure composée de solides de différentes densités, çà marche aussi en 2D avec des régions (section d'une structure linéaire). Je ne sais pas si j'enfonce des portes ouvertes, mais le plaisir d'avoir appris me donne envie de partager. ;;; C:CENTROID Crée un point sur le centre de gravité d'une structure composée de solides de densités ;;; différentes (ou d'une section composée de régions) et affiche la masse totale de la structure ;;; ;;; L'utlisateur sélectionne les solides (ou les régions) un par un et, pour chaque solide (ou région), ;;; spécifie sa densité (ou annule la dernière sélection) puis entre "t" pour terminer la commande. (defun C:CENTROID (/ obj mas cen vol den_prec den lst pts pt) (vl-load-com) (initget 1) (setq obj (entsel "\nSélectionnez un solide ou une région: ")) (cond ((= (getval 0 obj) "3DSOLID") (setq mas T) (OBJ->BARYLST 'volume) (while (progn (initget 1 "Terminer") (not (= (setq obj (entsel "\nSélectionnez un solide ou [Terminer]: ")) "Terminer" ) ) ) (if (= (getval 0 obj) "3DSOLID") (OBJ->BARYLST 'volume) (princ "\nEntité non valide.") ) ) ) ((= (getval 0 obj) "REGION") (OBJ->BARYLST 'area) (while (progn (initget 1 "Terminer") (not (= (setq obj (entsel "\nSélectionnez une région ou [Terminer]: ")) "Terminer" ) ) ) (if (= (getval 0 obj) "REGION") (OBJ->BARYLST 'area) (princ "\nEntité non valide.") ) ) ) (T (princ "\nEntité non valide.")) ) (setq lst (BARYCENTRE (REMOVE_DOUBLES lst))) (mapcar 'vla-erase pts) (vla-addPoint (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)) ) (vlax-3D-point (car lst)) ) (if mas (princ (strcat "\nMasse totale : " (rtos (cdr lst)))) ) (princ) ) ;;; OBJ->BARYLST Crée une liste d'association contenant le centre de gravité et la masse ;;; de chaque solides ou régions (defun OBJ->BARYLST (prop) (setq obj (vlax-ename->vla-object (car obj)) cen (vlax-safearray->list (vlax-variant-value (vla-get-centroid obj)) ) vol (* (vlax-get-property obj prop) 1e-6) ) [surligneur](if (= (vla-get-ObjectName obj) "AcDbRegion") (setq cen (trans cen 1 0)) )[/surligneur] (vlax-invoke-method obj 'highlight 1) (if (not den_prec) (setq den_prec 1.0) ) (initget "annUler") (setq den (getreal (strcat "\nSpécifiez la densité du matériau ou [annUler] <" (rtos den_prec) ">: " ) ) ) (if (= den "annUler") (vlax-invoke-method obj 'highlight 0) (progn (if den (setq den_prec den) (setq den den_prec) ) (setq lst (cons (cons cen (* vol den)) lst) pt (vla-addPoint (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)) ) (vlax-3D-point cen) ) pts (cons pt pts) ) (vlax-invoke-method obj 'highlight 0) ) ) ) ;;; BARYCENTRE Calcule le barycentre de points pondérés contenus dans une liste d'association ;;; ex : (BARYCENTRE '(((10.0 10.0 0.0) . 1.0) ((20.0 30.0 10.0) . 3.0))) -> (((17.5 25.0 7.5) . 4.0)) (defun BARYCENTRE (lst) (cond ((null (cdr lst)) (car lst)) (T (BARYCENTRE (cons (cons (mapcar '+ (caar lst) (mapcar '(lambda (x) (* x (/ (cdadr lst) (+ (cdar lst) (cdadr lst)))) ) (mapcar '- (caadr lst) (caar lst)) ) ) (+ (cdar lst) (cdadr lst)) ) (cdr (cdr lst)) ) ) ) ) ) ;;; REMOVE_DOUBLES - Suprime tous les doublons d'une liste (defun REMOVE_DOUBLES (lst) (cond ((null lst) nil) (T (cons (car lst) (REMOVE_DOUBLES (vl-remove (car lst) lst))) ) ) ) ;;; GETVAL (Reini Urban) Retourne la première valeur du groupe d'une entité. ;;; Accepte tous les genres de représentations de l'entité ;;; (ename, les listes entget, les listes entsel) ;;; NOTE: Ne peut obtenir que le premier groupe 10 dans LWPOLYLINE ! (defun getval (grp ele) ; "valeur dxf" de toute entité. (cond ((= (type ele) 'ENAME) ; ENAME (cdr (assoc grp (entget ele))) ) ((not (vl-consp ele)) nil) ; élément invalide ((= (type (car ele)) 'ENAME) ; liste entsel (cdr (assoc grp (entget (car ele)))) ) (T (cdr (assoc grp ele))) ; liste entget ) ) Tous les commentaires sont évidemmment les bienvenus, à plus.[Edité le 23/5/2005 par gile][Edité le 23/5/2005 par gile] [Edité le 9/6/2005 par gile]

Merci beaucoup Tramber, je pense que çà répond tout à fait à ce que je cherchais. J'essaye çà . Il faut vraiment que je me mette au VLA... A plus.

Salut à tous, Je cherche à extraire automatiquement les coordonnées du centre de gravité d'une région (ou d'un solide) pour en attribuer la valeur à une variable LISP, dans le but de faire une petite routine qui placerait l'origine du SCU directement sur ce point. Et ensuite, extraire les moments d'inertie de la région par rapport à son centre de gravité. Merci d'avance...

Pour continuer l'exercice : Tu peux faire un truc du genre : (initget 6) (if (setq Vdist (getdist (strcat "\nDistance de décalage <" (rtos (getvar "offsetdist")) "> :" ) ) ) (setvar "offsetdist" Vdist) (setq Vdist (getvar "offsetdist")) ) Le (initget 6) empèche l'entrée de zéro ou d'un nombre négatif mais permet "enter". Sinon regarde quand même ce que j'ai dit plus haut pour le côté de décalage, c'est pas un problème de LISP mais de géométrie : si pt1 (qui est un sommet de la polyligne) est situé sur un sommet en angle droit un des points spécifié pour le décalage peut appartenir à la polyligne et AutoCAD ne saura plus de quel côté décaler. D'où l'intérêt du point pt0 milieu de pt1 pt2 (essaye avec un rectangle) Et au risque de paraître tétu, je pense que c'est une bonne habitude que de mettre osmode à 0 avant de créer une entité de dessin avec (command) pour assurer une plus grande fiabilité. Pour effacer l'entité source (command "_erase" (car select_ent) "") ou plus "classe" (entdel (car select_ent)) A plus. [Edité le 15/5/2005 par gile]

Il semble que le problème soit plutôt dû au choix de pt1 pour les "polar", essaye avec pt0 (milieu de pt1 et pt2), chez moi çà semble marcher : (setq anglepl (angle Pt1 Pt2) pt0 (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2)) pt1 pt2) PtGauche (polar pt0 (+ anglepl (/ pi 2)) 1) PtDroite (polar Pt0 (- anglepl (/ pi 2)) 1) v1 (getvar "osmode") ) [Edité le 14/5/2005 par gile]

Salut, mac Quelques petites remarques vite fait (si tu veux continuer en LISP, bien sûr !) : Tu peux effectivement supprimer tous "progn" de ta fonction peut s'écrire : (setq pt1 (cdr (assoc 10 entité1)) pt2 (cdr (assoc 11 entité1)) ) de même pour les autres "progn". Pour ce qui est du zoom, c'est probablement un problème avec l'accochage aux objets. Essaye en changeant la valeur de "osmode" avant les "command" (setq init_os (getvar "osmode")) (setvar "osmode" 0) (command "_offset" .....) (setvar "osmode" init_os) Autre remarque, ton "if" pourrait être avantageusement remplacé par un "cond" ce qui te permettrait d'envisger d'autres conditionnelles, donc de décaler d'autres entités (cercles, arcs, etc.) et de renvoyer un message d'erreur si l'entité selectionnée ne peut être décalée. [Edité le 14/5/2005 par gile]

Merci Bonuscad et toutes mes excuses pour cette réponse tardive, j'ai été privé de connexion pendant la semaine. J'avais tout d'abord procédé comme tu le suggère pour la 3D, mais le déplacement du SCU permet à l'affichage des "grvecs" de rester cohérent visuellement. Sinon, je suis très flatté que la manière dont j'ai récupéré les entrées au clavier puisse t'intéresser parceque c'est pour moi une découverte ! A bientôt...

Allez Bonuscad, envoie les remarques ! ... Je voulais juste dire : j'arrête d'envoyer des "patchs". Bien sûr que je n'arrête pas d'essayer d'améliorer l'histoire, même si je continue d'utiliser la version "classique" (elle me semble plus fiable et permet d'utiliser le repère objet). Grace à toi en particulier, j'ai appris à me servir de fonctions LISP que je n'utilisait pas encore : grread, ascii, chr...

Une autre amélioration possible, après j'arrête ! Pour pouvoir saisir le second sommet en coordonnées relatives (avec @), l'origine étant le premier sommet, il suffit de remplacer cette partie du code précédent : par : ((or (member key '((2 13) (2 32))) (eq (car key) 25)) (if (not (zerop (strlen value))) (cond ((and (= 64 (ascii (substr value 1 1))) (STR->PT (substr value 2)) ) (setq pt2 (mapcar '+ pt1 (STR->PT (substr value 2)))) ) ((STR->PT value) (setq pt2 (STR->PT value)) ) (T (princ "\nNécessite un point 2D ou entrée au clavier.") (setq pt2 nil value "" ) ) ) ) (if pt2 (progn (redraw) (grvecs (list pt1 pt2 pt2 pt3 pt3 pt1)) (setq loop nil) ) ) ) et modifier la définition de STR->PT pour éviter un message d'erreur en cas de faute de frappe. ;;; STR->PT Transforme une chaine en point ;;; ex : (str->pt "20,15") -> (20.0 15.0 0.0) (defun STR->PT (str / n s l c) (setq n (1+ (strlen str)) s "" ) (while (< 0 (setq n (1- n))) (setq c (substr str n 1)) (if (= c ",") (if (STRINGP s) (setq l (cons s l) s "" ) ) (setq s (strcat c s)) ) ) (if (STRINGP s) (setq l (cons s l)) ) (if (POINTP (mapcar 'read l)) (trans (mapcar 'read l) 0 0) ) ) Dans la même optique, pour la saisie du dernier angle, remplacer : par : ((or (member key '((2 13) (2 32))) (eq (car key) 25)) (if (and (not (zerop (strlen value))) (numberp (read value)) ) (setq a2 (/ (* pi (read value)) 180) loop nil pta2 nil ) (progn (princ "\nNécessite un angle numérique correct, 2ème point, ou une entrée au clavier." ) (setq value "") ) ) ) Encore une fois, un gros merci à tous !!!!

Oups... J'ai laissé passer un appel à une fonction vlisp. Il suffit de remplacer par : ;;; Vérifie si tous les membres d'une liste retournent T comme résultat à l'exécution d'une fonction ;;; (EVERY 'numberp '(10 5.5 0)) -> T (fonction vlisp -> vl-every) (defun EVERY (fun lst) (and (consp lst) (apply '= (cons T (mapcar fun lst))) ) ) ;;; une liste non vide ? ;;; (fonction vlisp -> vl-consp) (defun consp (l) (and l (listp l)) )

Voilà le code "définitif" (enfin, j'espère) Il me semble tenir la route : protections, gestion des erreurs, saisie possible au clavier ou à l'écran... C'est une version "passe-partout" sans fonctions vlisp ni (ai_setCmdEcho) ;;; Fonction TRAPEZE avec affichage dynamique 04/05/05 ;;; GR-OSMODE Piqué à Bonuscad, affichage des modes d'accrochage aux objets (defun gr-osmode (pt-i str-md / n pt md rap pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt56 pt67 pt78 pt85 one_o) (setq n (/ (cadr (getvar "screensize")) 5.0)) (setq pt (osnap pt-i str-md)) (while (and (eq (strlen (setq md (substr str-md 1 4))) 4) (not one_o) ) (repeat 3 (setq rap (/ (getvar "viewsize") n) pt1 (list (- (car pt) rap) (- (cadr pt) rap) (caddr pt)) pt2 (list (+ (car pt) rap) (- (cadr pt) rap) (caddr pt)) pt3 (list (+ (car pt) rap) (+ (cadr pt) rap) (caddr pt)) pt4 (list (- (car pt) rap) (+ (cadr pt) rap) (caddr pt)) pt5 (list (car pt) (- (cadr pt) rap) (caddr pt)) pt6 (list (+ (car pt) rap) (cadr pt) (caddr pt)) pt7 (list (car pt) (+ (cadr pt) rap) (caddr pt)) pt8 (list (- (car pt) rap) (cadr pt) (caddr pt)) pt56 (polar pt (- (/ pi 4.0)) rap) pt67 (polar pt (/ pi 4.0) rap) pt78 (polar pt (- pi (/ pi 4.0)) rap) pt85 (polar pt (+ pi (/ pi 4.0)) rap) n (- n 16) ) (if (equal (osnap pt-i md) pt) (setq one_o T) ) (cond ((and (eq "_end" md) one_o) (grdraw pt1 pt2 1) (grdraw pt2 pt3 1) (grdraw pt3 pt4 1) (grdraw pt4 pt1 1) ) ((and (eq "_mid" md) one_o) (grdraw pt1 pt2 1) (grdraw pt2 pt7 1) (grdraw pt7 pt1 1) ) ((and (eq "_cen" md) one_o) (grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1) (grdraw pt5 pt7 7) (grdraw pt6 pt8 7) ) ((and (eq "_nod" md) one_o) (grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1) (grdraw pt1 pt3 1) (grdraw pt2 pt4 1) ) ((and (eq "_qua" md) one_o) (grdraw pt5 pt6 1) (grdraw pt6 pt7 1) (grdraw pt7 pt8 1) (grdraw pt8 pt5 1) ) ((and (eq "_int" md) one_o) (grdraw pt1 pt3 1) (grdraw pt2 pt4 1) ) ((and (eq "_ins" md) one_o) (grdraw pt5 pt2 1) (grdraw pt2 pt6 1) (grdraw pt6 pt8 1) (grdraw pt8 pt4 1) (grdraw pt4 pt7 1) (grdraw pt7 pt5 1) ) ((and (eq "_per" md) one_o) (grdraw pt1 pt2 1) (grdraw pt1 pt4 1) (grdraw pt8 pt 1) (grdraw pt pt5 1) ) ((and (eq "_tan" md) one_o) (grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1) (grdraw pt3 pt4 1) ) ((and (eq "_nea" md) one_o) (grdraw pt1 pt2 1) (grdraw pt2 pt4 1) (grdraw pt4 pt3 1) (grdraw pt3 pt1 1) ) ) ) (setq str-md (substr str-md 6) n (/ (cadr (getvar "screensize")) 5.0) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; C:TRAPEZE Fonction Trapèze avc grread et entmake (defun c:trapeze (/ old_echo o mode pt1 pt2 pt3 pt4 pta2 a0 a1 a01 a2 a02 a3 a4 alpha key value lst) (setq m:err *error* *error* GR_TRPZ_ERR ) (command "_undo" "_begin") (setq old_echo (getvar "cmdecho")) (setvar "cmdecho" 0) (princ "Trapeze") ;; Accrochage aux objets (setq o (getvar "osmode")) (if (or (zerop o) (= (logand o 16384) 16384)) (setq mod "_none") (progn (setq mod "") (mapcar '(lambda (xi xs) (if (not (zerop (logand o xi))) (if (zerop (strlen mod)) (setq mod (strcat mod xs)) (setq mod (strcat mod "," xs)) ) ) ) '(1 2 4 8 16 32 64 128 256 512) '("_end" "_mid" "_cen" "_nod" "_qua" "_int" "_ins" "_per" "_tan" "_nea") ) ) ) ;; Saisie classique (if (not (numberp *larg*)) (setq *larg* 10) ) (while (not (setq pt1 (getpoint (strcat "\nLa largeur courante est de " (rtos *larg*) "\nSpécifiez le premier sommet ou <Largeur>: " ) ) ) ) (initget 6) (setq *larg* (getdist "\nSpécifiez la largeur: ")) ) ;;; Si pt1 n'est pas danx le plan XY du SCU courant ;;;;;;;;; (if (not (equal (caddr pt1) 0 1e-009)) ; (progn ; (setq scu_init T ; h (caddr pt1) ; ) ; (command "_ucs" "_move" "z" (caddr pt1)) ; (setq pt1 (list (car pt1) (cadr pt1) 0.0)) ; ) ; ) ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (initget 1) (setq a1 (getangle pt1 "\nSpécifiez l'angle décrit par ce côté: ")) (prompt "\nSpécifiez le second sommet: ") ;; Affichage dynamique pour la saisie de pt2 (setq loop T value "" ) (while (and (setq key (grread T 4 0)) (/= (car key) 3) loop) (cond ((eq (car key) 5) (redraw) (setq pt2 (cadr key)) (if (and (/= mod "_none") (osnap pt2 mod)) (gr-osmode pt2 mod) ) (setq pt3 (polar pt1 a1 *larg*)) (grvecs (list pt1 pt2 pt2 pt3 pt3 pt1)) ) ((or (member key '((2 13) (2 32))) (eq (car key) 25)) (if (and (not (zerop (strlen value))) (POINTP (STR->PT value)) ) (setq pt2 (STR->PT value)) ) (setq loop nil) ) (T (if (eq (cadr key) 8) (progn (setq value (substr value 1 (1- (strlen value)))) (princ (chr 8)) (princ (chr 32)) ) (setq value (strcat value (chr (cadr key)))) ) (princ (chr (cadr key))) ) ) ) ;; Redétermination des points après accrochage aux objets ou saisie au clavier (if (osnap pt2 mod) (setq pt2 (osnap pt2 mod)) ) (setq a0 (angle pt1 pt2) a01 (- a1 a0) ) (if (minusp a01) (setq a01 (+ a01 (* 2 pi))) ) (if (EQUALKPI a01) (TRPZ_ERR "un des côtés est aligné avec les sommets.") ) (if (not (equal (caddr pt1) (caddr pt2) 1e-009)) (TRPZ_ERR "les sommets ne sont pas dans un plan parallèle au SCU courant." ) ) (prompt "\nSpécifiez l'angle décrit par ce côté: ") ;; Affichage dynamique pour la saisie de a2 (setq loop T value "" ) (while (and (setq key (grread T 4 0)) (/= (car key) 3) loop) (cond ((eq (car key) 5) (redraw) (setq pta2 (cadr key)) (if (and (/= mod "_none") (osnap pta2 mod)) (gr-osmode pta2 mod) ) (setq a2 (angle pt2 pta2) a02 (- a2 a0) ) (if (minusp a02) (setq a02 (+ a02 (* 2 pi))) ) (cond ((or (and (< 0 a01 pi) (< 0 a02 pi)) (and (< pi a01 (* 2 pi)) (< pi a02 (* 2 pi))) ) (setq pt3 (polar pt1 a1 (/ *larg* (abs (sin a01)))) pt4 (polar pt2 a2 (/ *larg* (abs (sin a02)))) ) (grvecs (list pt1 pt2 pt2 pt4 pt4 pt3 pt3 pt1)) ) ((or (and (< 0 a01 pi) (< pi a02 (* 2 pi))) (and (< pi a01 (* 2 pi)) (< 0 a02 pi)) ) (cond ((<= *larg* (distance pt1 pt2)) (setq alpha (acos (/ *larg* (distance pt1 pt2)))) (if (< a01 pi) (setq a3 (- alpha a01) a4 (- alpha a02 pi) ) (setq a3 (+ alpha a01) a4 (+ alpha a02 pi) ) ) (cond ((and (not (EQUALKPI (+ a3 (/ pi 2)))) (not (EQUALKPI (+ a4 (/ pi 2)))) ) (setq pt3 (polar pt1 a1 (/ *larg* (cos a3))) pt4 (polar pt2 a2 (/ *larg* (cos a4))) ) (grvecs (list pt1 pt3 pt3 pt2 pt2 pt4 pt4 pt1)) ) ) ) ) ) ) ) ((or (member key '((2 13) (2 32))) (eq (car key) 25)) (if (and (not (zerop (strlen value))) (or (eq (type (read value)) 'INT) (eq (type (read value)) 'REAL) ) ) (setq a2 (/ (* pi (read value)) 180) loop nil pta2 nil ) ) ) (T (if (eq (cadr key) 8) (progn (setq value (substr value 1 (1- (strlen value)))) (princ (chr 8)) (princ (chr 32)) ) (setq value (strcat value (chr (cadr key)))) ) (princ (chr (cadr key))) ) ) ) ;; Calcul définitif après accrochage aux objets ou saisie au clavier (if (and pta2 (osnap pta2 mod)) (setq pta2 (osnap pta2 mod) a2 (angle pt2 pta2) ) ) (setq a02 (- a2 a0)) (if (minusp a02) (setq a02 (+ a02 (* 2 pi))) ) (if (EQUALKPI a02) (TRPZ_ERR "un des côtés est aligné avec les sommets.") ) ;;; Si pt1 n'est pas danx le plan XY du SCU courant ;;;;;;;;; (if scu_init ; (progn ; (foreach n '(pt1 pt2 pt3 pt4) ; (set n (trans (eval n) 1 0)) ; ) ; (command "_ucs" "_prev") ; (foreach n '(pt1 pt2 pt3 pt4) ; (set n (trans (eval n) 0 1)) ; ) ; (setq scu_init nil) ; ) ; ) ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (if (or (and (< 0 a01 pi) (< 0 a02 pi)) (and (< pi a01 (* 2 pi)) (< pi a02 (* 2 pi))) ) (setq pt3 (polar pt1 a1 (/ *larg* (abs (sin a01)))) pt4 (polar pt2 a2 (/ *larg* (abs (sin a02)))) lst (list pt1 pt2 pt4 pt3) ) (if (< (distance pt1 pt2) *larg*) (TRPZ_ERR "la largeur est plus grande que la diagonale.") (progn (setq alpha (acos (/ *larg* (distance pt1 pt2)))) (if (< a01 pi) (setq a3 (- alpha a01) a4 (- alpha a02 pi) ) (setq a3 (+ alpha a01) a4 (+ alpha a02 pi) ) ) (if (or (equal (cos a3) 0 1e-009) (equal (cos a4) 0 1e-009) ) (TRPZ_ERR "un des côtés est aligné avec une des bases.") (setq pt3 (polar pt1 a1 (/ *larg* (cos a3))) pt4 (polar pt2 a2 (/ *larg* (cos a4))) lst (list pt1 pt3 pt2 pt4) ) ) ) ) ) (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) (cons 38 (- (caddr pt1) (caddr (trans '(0 0) 0 1)))) (cons 10 (trans (nth 0 lst) 1 (extr_dir))) (cons 10 (trans (nth 1 lst) 1 (extr_dir))) (cons 10 (trans (nth 2 lst) 1 (extr_dir))) (cons 10 (trans (nth 3 lst) 1 (extr_dir))) (cons 210 (extr_dir)) ) ) (redraw) (command "_undo" "_end") (setvar "cmdecho" old_echo) (setq *error* m:err m:err nil ) (princ) ) ;;; Sous-routines ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; EXTR_DIR Retourne la direction d'extrusion du SCU courant (defun EXTR_DIR (/ vec org) (mapcar '- (trans '(0 0 1) 1 0) (trans '(0 0 0) 1 0)) ) ;;; ACOS Retourne l'arc cosinus du nombre, en radians (defun ACOS (num) (if (<= -1 num 1) (atan (sqrt (- 1 (expt num 2))) num) (princ "\nErreur: L'argument pour ACOS doit être compris entre -1 et 1" ) ) ) ;;; EQUALKPI - Évalue si un angle est égal à k pi radians à 0.000000001 près. (defun EQUALKPI (ang) (or (equal (rem ang pi) 0 1e-009) (equal (abs (rem ang pi)) pi 1e-009) ) ) ;;; POINTP - Évalue si l'élément est un point (defun POINTP (ele) (and (EVERY 'numberp ele) (<= 2 (length ele) 3) ) ) ;;; Vérifie si tous les membres d'une liste retournent T comme résultat à l'exécution d'une fonction ;;; (EVERY 'numberp '(10 5.5 0)) -> T (fonction vlisp -> vl-every) (defun EVERY (fun lst) (and (vl-consp lst) (apply '= (cons T (mapcar fun lst))) ) ) ;;; Chaine non vide ? (defun stringp (s) (and (= 'STR (type s)) (/= s "") ) ) ;;; STR->PT Transforme une chaine en point ;;; ex : (str->pt "20,15") -> (20.0 15.0 0.0) (defun str->pt (str / n s l c) (setq n (1+ (strlen str)) s "" ) (while (< 0 (setq n (1- n))) (setq c (substr str n 1)) (if (= c ",") (if (stringp s) (setq l (cons s l) s "" ) ) (setq s (strcat c s)) ) ) (if (stringp s) (setq l (cons s l)) ) (trans (mapcar 'read l) 0 0) ) ;;; TRPZ_ERR - Envoie un message explicatif et quitte l'application. (defun TRPZ_ERR (msg) (princ (strcat "\nErreur: " msg)) (exit) ) ;;; GR_TRPZ_ERR (defun gr_trpz_err (msg) (if (or (= msg "Fonction annulée") (= msg "quitter / sortir abandon") ) (princ) (princ (strcat "\nErreur: " msg)) ) (redraw) (if scu_init (progn (command "_ucs" "_prev") (setq scu_init nil ) ) ) (command "_undo" "_end") (setvar "cmdecho" old_echo) (setq *error* m:err m:err nil ) )

Merci encore, Bonuscad T'inquiètes pas, à Marseille , on la craint pas, l'ombre... ...Souvent même, on la cherche ! C'est vrai que j'ai livré une routine un peu brute de décoffrage, je n'y avais même pas intégré les protections existantes dans la première version (pas dynamique, voir tout en haut). Je vérifie bien tout et retravaille un peu le style avant de rendre une copie définitive.

Voici le lien vers la FAQ AutoLISP de reini Urban (traduite en français). J'y ai trouvé énormément de chose qui m'ont permis d'apprendre ce que je connais en LISP aujoud'hui.

Ouf, çà y est ! Ce fut laborieux, mais j'ai réussi à intégrer (grread) dans la fonction trapèze. Juste un truc, pour que çà fonctionne dans un plan en élévation par rapport au plan XY du SCU je jongle avec le SCU et je ne trouve pas çà très élégant. Y a peut être moyen avec (trans) mais je n'y suis pas arrivé, si quelqu'un a une idée... En tous cas un gros merci à Bonuscad, Patrick_35, Tramber et les autres... ;;; GR-OSMODE Piqué à Bonuscad (defun gr-osmode (pt-i str-md / n pt md rap pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt56 pt67 pt78 pt85 one_o) (setq n (/ (cadr (getvar "screensize")) 5.0)) (setq pt (osnap pt-i str-md)) (while (and (eq (strlen (setq md (substr str-md 1 4))) 4) (not one_o) ) (repeat 3 (setq rap (/ (getvar "viewsize") n) pt1 (list (- (car pt) rap) (- (cadr pt) rap) (caddr pt)) pt2 (list (+ (car pt) rap) (- (cadr pt) rap) (caddr pt)) pt3 (list (+ (car pt) rap) (+ (cadr pt) rap) (caddr pt)) pt4 (list (- (car pt) rap) (+ (cadr pt) rap) (caddr pt)) pt5 (list (car pt) (- (cadr pt) rap) (caddr pt)) pt6 (list (+ (car pt) rap) (cadr pt) (caddr pt)) pt7 (list (car pt) (+ (cadr pt) rap) (caddr pt)) pt8 (list (- (car pt) rap) (cadr pt) (caddr pt)) pt56 (polar pt (- (/ pi 4.0)) rap) pt67 (polar pt (/ pi 4.0) rap) pt78 (polar pt (- pi (/ pi 4.0)) rap) pt85 (polar pt (+ pi (/ pi 4.0)) rap) n (- n 16) ) (if (equal (osnap pt-i md) pt) (setq one_o T) ) (cond ((and (eq "_end" md) one_o) (grdraw pt1 pt2 1) (grdraw pt2 pt3 1) (grdraw pt3 pt4 1) (grdraw pt4 pt1 1) ) ((and (eq "_mid" md) one_o) (grdraw pt1 pt2 1) (grdraw pt2 pt7 1) (grdraw pt7 pt1 1) ) ((and (eq "_cen" md) one_o) (grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1) (grdraw pt5 pt7 7) (grdraw pt6 pt8 7) ) ((and (eq "_nod" md) one_o) (grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1) (grdraw pt1 pt3 1) (grdraw pt2 pt4 1) ) ((and (eq "_qua" md) one_o) (grdraw pt5 pt6 1) (grdraw pt6 pt7 1) (grdraw pt7 pt8 1) (grdraw pt8 pt5 1) ) ((and (eq "_int" md) one_o) (grdraw pt1 pt3 1) (grdraw pt2 pt4 1) ) ((and (eq "_ins" md) one_o) (grdraw pt5 pt2 1) (grdraw pt2 pt6 1) (grdraw pt6 pt8 1) (grdraw pt8 pt4 1) (grdraw pt4 pt7 1) (grdraw pt7 pt5 1) ) ((and (eq "_per" md) one_o) (grdraw pt1 pt2 1) (grdraw pt1 pt4 1) (grdraw pt8 pt 1) (grdraw pt pt5 1) ) ((and (eq "_tan" md) one_o) (grdraw pt5 pt56 1) (grdraw pt56 pt6 1) (grdraw pt6 pt67 1) (grdraw pt67 pt7 1) (grdraw pt7 pt78 1) (grdraw pt78 pt8 1) (grdraw pt8 pt85 1) (grdraw pt85 pt5 1) (grdraw pt3 pt4 1) ) ((and (eq "_nea" md) one_o) (grdraw pt1 pt2 1) (grdraw pt2 pt4 1) (grdraw pt4 pt3 1) (grdraw pt3 pt1 1) ) ) ) (setq str-md (substr str-md 6) n (/ (cadr (getvar "screensize")) 5.0) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; GR_TRAPEZE Fonction principale avec GRREAD et ENTMAKE (defun c:gr_trapeze (/ o mode pt1 pt2 pt3 pt4 pta2 a0 a1 a01 a2 a02 a3 a4 alpha key lst) (vl-load-com) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)) ) (setq m:err *error* *error* gr_trpz_err ) (setq o (getvar "osmode")) (if (or (zerop o) (= (logand o 16384) 16384)) (setq mod "_none") (progn (setq mod "") (mapcar '(lambda (xi xs) (if (not (zerop (logand o xi))) (if (zerop (strlen mod)) (setq mod (strcat mod xs)) (setq mod (strcat mod "," xs)) ) ) ) '(1 2 4 8 16 32 64 128 256 512) '("_end" "_mid" "_cen" "_nod" "_qua" "_int" "_ins" "_per" "_tan" "_nea") ) ) ) (if (not (numberp *larg*)) (setq *larg* 10) ) (while (not (setq pt1 (getpoint (strcat "\nLa largeur courante est de " (rtos *larg*) "\nSpécifiez le premier sommet ou <Largeur>: " ) ) ) ) (initget 6) (setq *larg* (getdist "\nSpécifiez la largeur: ")) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (if (not (equal (caddr pt1) 0 1e-009)) (progn (setq scu_init T old_echo (getvar "cmdecho") h (caddr pt1) ) (setvar "cmdecho" 0) (command "_ucs" "_move" "z" (caddr pt1)) (setq pt1 (list (car pt1) (cadr pt1) 0.0)) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (initget 1) (setq a1 (getangle pt1 "\nSpécifiez l'angle décrit par ce côté: ")) (prompt "\nSpécifiez le second sommet: ") (while (and (setq key (grread T 4 0)) (/= (car key) 3)) (cond ((eq (car key) 5) (redraw) (setq pt2 (cadr key) a0 (angle pt1 pt2) a01 (- a1 a0) alpha (acos (/ *larg* (distance pt1 pt2))) ) (if (and (/= mod "_none") (osnap pt2 mod)) (gr-osmode pt2 mod) ) (if (minusp a01) (setq a01 (+ a01 (* 2 pi))) ) (cond ((< a01 pi) (setq a3 (- alpha a01))) ((> a01 pi) (setq a3 (+ alpha a01))) (T (setq a3 nil)) ) (cond (a3 (setq pt3 (polar pt1 a1 (/ *larg* (cos a3)))) (grvecs (list pt1 pt2 pt2 pt3 pt3 pt1)) ) ) ) ) ) (if (osnap pt2 mod) (setq pt2 (osnap pt2 mod)) ) (setq a0 (angle pt1 pt2) alpha (acos (/ *larg* (distance pt1 pt2))) ) (prompt "\nSpécifiez l'angle décrit par ce côté: ") (while (and (setq key (grread T 4 0)) (/= (car key) 3)) (cond ((eq (car key) 5) (redraw) (setq pta2 (cadr key)) (if (and (/= mod "_none") (osnap pta2 mod)) (gr-osmode pta2 mod) ) (setq a2 (angle pt2 pta2) a01 (- a1 a0) a02 (- a2 a0) ) (foreach n '(a01 a02) (if (minusp (eval n)) (set n (+ (eval n) (* 2 pi))) ) ) (cond ((or (and (< 0 a01 pi) (< 0 a02 pi)) (and (< pi a01 (* 2 pi)) (< pi a02 (* 2 pi))) ) (setq pt3 (polar pt1 a1 (/ *larg* (abs (sin a01)))) pt4 (polar pt2 a2 (/ *larg* (abs (sin a02)))) lst (list pt1 pt2 pt2 pt4 pt4 pt3 pt3 pt1) ) ) ((or (and (< 0 a01 pi) (< pi a02 (* 2 pi))) (and (< pi a01 (* 2 pi)) (< 0 a02 pi)) ) (cond ((< a01 pi) (setq a4 (- alpha a02 pi))) ((> a01 pi) (setq a4 (+ alpha a02 pi))) (T (setq a4 nil)) ) (setq pt4 (polar pt2 a2 (/ *larg* (cos a4))) lst (list pt1 pt3 pt3 pt2 pt2 pt4 pt4 pt1) ) ) ) (grvecs lst) ) ) ) (if (osnap pta2 mod) (setq pta2 (osnap pta2 mod)) ) (setq a2 (angle pt2 pta2) a02 (- a2 a0) ) (if (minusp a02) (setq a02 (+ a02 (* 2 pi))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (if scu_init (progn (foreach n '(pt1 pt2 pt3 pt4) (set n (trans (eval n) 1 0)) ) (command "_ucs" "_prev") (setvar "cmdecho" old_echo) (foreach n '(pt1 pt2 pt3 pt4) (set n (trans (eval n) 0 1)) ) (setq old_echo nil scu_init nil ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (if (or (and (< 0 a01 pi) (< 0 a02 pi)) (and (< pi a01 (* 2 pi)) (< pi a02 (* 2 pi))) ) (setq pt3 (polar pt1 a1 (/ *larg* (abs (sin a01)))) pt4 (polar pt2 a2 (/ *larg* (abs (sin a02)))) lst (list pt1 pt2 pt4 pt3) ) (progn (if (< a01 pi) (setq a3 (- alpha a01) a4 (- alpha a02 pi) ) (setq a3 (+ alpha a01) a4 (+ alpha a02 pi) ) ) (setq pt3 (polar pt1 a1 (/ *larg* (cos a3))) pt4 (polar pt2 a2 (/ *larg* (cos a4))) lst (list pt1 pt3 pt2 pt4) ) ) ) (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) (cons 38 (- (caddr pt1) (caddr (trans '(0 0) 0 1)))) (cons 10 (trans (nth 0 lst) 1 (extr_dir))) (cons 10 (trans (nth 1 lst) 1 (extr_dir))) (cons 10 (trans (nth 2 lst) 1 (extr_dir))) (cons 10 (trans (nth 3 lst) 1 (extr_dir))) (cons 210 (extr_dir)) ) ) (redraw) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)) ) (setq *error* m:err m:err nil ) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; EXTR_DIR Retourne la direction d'extrusion du SCU courant (defun EXTR_DIR (/ vec org) (mapcar '- (trans '(0 0 1) 1 0) (trans '(0 0 0) 1 0)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ACOS Retourne l'arc cosinus du nombre, en radians (defun ACOS (num) (if (<= -1 num 1) (atan (sqrt (- 1 (expt num 2))) num) (princ "\nErreur: L'argument pour ACOS doit être compris entre -1 et 1" ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; GR_TRPZ_ERR (defun gr_trpz_err (msg) (if (or (= msg "Fonction annulée") (= msg "quitter / sortir abandon") ) (princ) (princ (strcat "\nErreur: " msg)) ) (if scu_init (progn (command "_ucs" "_prev") (setvar "cmdecho" old_echo) (setq old_echo nil scu_init nil ) ) ) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)) ) (setq *error* m:err m:err nil ) )

Merci bonuscad, çà marche ton truc, mais l'intérêt de ma fonction est de pouvoir choisir les sommets indifféremment sur la même base ou chacun sur une base différente (sur la diagonale). C'est utile pour dessiner une pièce de triangulation dont on connait la position des deux sommets opposés. Encore une fois, un dessin vaut mieux qu'un long discours.

Pour la migration des personnalisations, je propose un truc ici. Mais entre 2002 et 2004 les icones ont changé, il faut donc tout refaire pour les barres d'outils ! J'ai donc 2 dossiers "MonSupport2002" et "MonSupport2004" !

Salut Thierry, Pour ce qu'il en est spécifiquement des palettes d'outils, je ne suis pas sûr mais elles doivent être enregistrées dans le fichier *.mns que tu utilise ("acad.mns" par défaut). Personnelllement, comme je veux trimbaler ma personnalisation sur les différents postes où je suis amené à travailler, j'ai fait un dossier "MonSupport" dans lequel j'ai mis : - un fichier "MonMenu.mns" qui est une copie de "acad.mns" dans laquelle j'ai modifié à mon gré les menus, les "accelerators" et les barres d'outils. - un fichier "MonMenu.mnl" qui contient du code LISP pour le chargement de "acad.mnl" ex : (load "acad.mnl") (load "MaFonction.lsp") ... - mes Lisp nécessaires aux menus (ceux appelés par "MonMenu.mnl"). - toutes mes icones nécesssaires aux barres d'outils Une fois chargé. Après avoir indiqué à AutoCAD le chemin de ce dossier (dans Outils -> Options... -> Fichiers -> Chemins de recherche de fichiers support) et ouvert un nouveau Profil d'utilisateur (Outils -> Options... -> Profil), je charge "MonMenu.mns", ce qui génère deux autres fichiers dans le dossier ("monmenu.mnc" et "monmenu.mnr"). Le dossier à présent complet peut être installé ailleurs de la même façon.

Je ne suis pas sûr que ce soit d'une grande utilité, mais j'ai trouvé, pour ce cas, un moyen de contourner l'impossibilté d'extruder suivant un chemin non plan. Code LISP : ;;; Redéfinition de *ERROR* (defun res_err (msg) (if (not (= msg "Fonction annulée")) (princ (strcat "\nErreur: " msg)) ) (command) (command "_ucs" "_restore" "scu_init") (command "_ucs" "_del" "scu_init") (command "_undo" "_end") (REST_VAR) (setq *error* m:err m:err nil ) (princ) ) ;;; SAVE_VAR Enregistre la valeur initiale des variables système dans une liste associative (defun SAVE_VAR (lst) (setq varlist (mapcar '(lambda (x) (cons x (getvar x))) lst)) ) ;;; REST_VAR Restaure leurs valeurs initiales aux variables système de la liste SAVE_VAR (defun REST_VAR () (foreach pair varlist (if (/= (getvar (car pair)) (eval (cdr pair))) (setvar (car pair) (eval (cdr pair))) ) ) (setq varlist nil) ) ;;; ADD_Z Ajoute "val" à la coordonnée Z du point "pt" -accepte les points type (x y) (defun ADD_Z (pt val) (setq pt (trans pt 0 0)) (list (car pt) (cadr pt) (+ (caddr pt) val)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; CREAT_RESSORT Création du solide (defun CREAT_RESSORT (sp seg diam bdn pas sens axe / v1 v2 r ang pt1 pt2 pt3 pointA point1 point2 point3 arc cercle boudin) (setq m:err *error* *error* res_err ) (SAVE_VAR '("cmdecho" "osmode")) (command "_undo" "_begin") (princ "Ressort") (setvar "cmdecho" 0) (command "_ucs" "_save" "scu_init") (setq r (- (/ diam 2) (/ bdn 2)) pt2 (polar axe 0 r) pt1 (polar axe (/ (* 2 pi) seg) r) ang (atan (distance pt2 pt1) (/ pas seg)) axe (ADD_Z axe (- (/ pas (* seg 2)))) boudin (ssadd) ) (if (= sens "Gauche") (setq pas (- pas) seg (- seg) ) ) (setvar "osmode" 0) (repeat (* sp (abs seg)) (setq pt1 pt2 axe (ADD_Z axe (/ pas seg)) pt2 (polar axe (+ (angle axe pt1) (/ (* 2 pi) seg)) r) pt2 (ADD_Z pt2 (/ pas (* seg 2))) pt3 (polar axe (+ (angle axe pt1) (/ pi seg)) r) pointA (trans axe 1 0) point1 (trans pt1 1 0) point2 (trans pt2 1 0) point3 (trans pt3 1 0) ) (command "_ucs" "_new" "3" axe pt1 pt3) (command "_ellipse" "_arc" "_c" (trans pointA 0 1) ; Centre de l'ellipse (trans point3 0 1) ; Extrémité du petit axe (/ r (sin ang)) ; Demie longueur du grand axe (trans point1 0 1) ; Départ de l'arc (trans point2 0 1) ; Fin de l'arc ) (setq arc (entlast)) (command "_ucs" "_new" "x" 90) (command "_circle" (trans point1 0 1) (/ bdn 2) ) (setq cercle (entlast)) (command "_extrude" cercle "" "_path" arc) (ssadd (entlast) boudin) (command "_erase" cercle arc "") (command "_ucs" "_restore" "scu_init") ) (grtext -2 "Union des segments.") (command "union" boudin "") (command "_ucs" "_delete" "scu_init") (command "_undo" "_end") (REST_VAR) (setq *error* m:err m:err nil ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; C:RESSORT Boite de dialogue (defun c:ressort (/ dcl_id what_next sp pas sens diam bdn axe) (setq dcl_id (load_dialog "ressort.dcl")) (setq what_next 2) (while (>= what_next 2) (if (not (new_dialog "ressort" dcl_id)) (exit) ) (if (not *seg_res*) (setq *seg_res* 12) ) (foreach n '("nb_seg" "sldr_seg") (set_tile n (itoa *seg_res*)) ) (if sp (set_tile "nb_sp" (itoa sp)) ) (if pas (set_tile "val_pas" (rtos pas)) ) (if diam (set_tile "dia_ext" (rtos diam)) ) (if bdn (set_tile "dia_bdn" (rtos bdn)) ) (if sens (if (equal sens "Droite") (set_tile "drte" "1") (set_tile "gche" "1") ) ) (if (not axe) (setq axe '(0 0 0)) ) (set_tile "x_coord" (rtos (car axe))) (set_tile "y_coord" (rtos (cadr axe))) (set_tile "z_coord" (rtos (caddr axe))) (action_tile "sldr_seg" (strcat "(if (or (= $reason 1) (= $reason 3))" "(progn (set_tile \"nb_seg\" $value)" "(setq *seg_res* (atoi $value))))" ) ) (action_tile "nb_seg" (strcat "(if (or (= $reason 1) (= $reason 2))" "(progn (set_tile \"sldr_seg\" $value)" "(setq *seg_res* (atoi $value))))" ) ) (action_tile "nb_sp" "(setq sp (atoi $value))") (action_tile "val_pas" "(setq pas (atof $value))") (action_tile "drte" "(if (= (atoi $value) 1) (setq sens \"Droite\"))" ) (action_tile "gche" "(if (= (atoi $value) 1) (setq sens \"Gauche\"))" ) (action_tile "dia_ext" "(setq diam (atof $value))") (action_tile "dia_bdn" "(setq bdn (atof $value))") (action_tile "x_coord" "(setq axe (subst (atof $value) (car axe) axe))" ) (action_tile "y_coord" "(setq axe (subst (atof $value) (cadr axe) axe))" ) (action_tile "z_coord" "(setq axe (subst (atof $value) (caddr axe) axe))" ) (action_tile "b_axe" "(done_dialog 3)") (action_tile "accept" (strcat "(cond" "((< *seg_res* 2)" "(alert \"Le nombre de segments ne peut être inférieur à 2.\")" "(mode_tile \"nb_seg\" 2))" "((<= sp 0)" "(alert \"Le nombre de spires doit être positif et non nul.\")" "(mode_tile \"nb_sp\" 2))" "((<= pas 0)" "(alert \"La valeur du pas doit être positive et non nulle.\")" "(mode_tile \"val_pas\" 2))" "((<= diam 0)" "(alert \"Le diamètre du ressort doit être positif et non nul.\")" "(mode_tile \"dia_ext\" 2))" "((<= bdn 0)" "(alert \"Le diamètre du boudin doit être positif et non nul.\")" "(mode_tile \"dia_bdn\" 2))" "((<= diam (* 2 bdn))" "(alert \"Le diamètre du boudin doit être inférieur au rayon du ressort.\"))" "((< pas bdn)" "(alert \"Le diamètre du boudin ne peut être supérieur au pas.\"))" "(T (done_dialog 1)))" ) ) (setq what_next (start_dialog)) (cond ((= what_next 3) (initget 1) (setq axe (getpoint "\nSélectionnez le point à la base du ressort: " ) ) ) ((= what_next 1) (CREAT_RESSORT sp *seg_res* diam bdn pas sens axe) ) ) ) (unload_dialog dcl_id) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; C:-RESSORT Ligne de commande (defun c:-ressort (/ seg sp pas sens diam bdn axe) (if (not *seg_res*) (setq *seg_res* 12) ) (princ "\nEntrez le nombre de segments par spire <") (princ *seg_res*) (princ ">: ") (if (setq seg (getint)) (setq *seg_res* seg) (setq seg *seg_res*) ) (while (< seg 2) (alert "Le nombre de segments ne peut être inférieur à 2." ) (setq seg (getint "\nEntrez un nouveau nombre de segments: ") *seg_res* seg ) ) (initget 7) (setq sp (getint "\nEntrez le nombre de spires: ")) (initget 7) (setq pas (getdist "\nSpécifiez le pas du ressort: ")) (initget "Droite Gauche") (if (not (setq sens (getkword "\nIndiquez le sens du pas [Droite/Gauche] : ")) ) (setq sens "Droite") ) (initget 7) (setq diam (getdist "\nSpécifiez le diamètre extérieur du ressort: ")) (initget 7) (setq bdn (getdist "\nSpécifiez le diamètre du boudin: ")) (cond ((<= diam (* 2 bdn)) (alert "ERREUR : Le rayon du ressort doit être supérieur au diamètre du boudin. \nFONCTION ANNULÉE" ) (exit) ) ((< pas bdn) (alert "ERREUR : Le diamètre du boudin ne peut être supérieur au pas. \nFONCTION ANNULÉE" ) (exit) ) ) (initget 1) (setq axe (getpoint "\nSpécifiez le point à la base l'axe: ")) (CREAT_RESSORT sp seg diam bdn pas sens axe) (princ) ) Code DCL de la boite de dialogue à enregistrer sous "Ressort.dcl" dans le Dossier Support d'ACAD par exemple : //Ressort.dcl //Boite de dialogue de la fonction Ressort ressort:dialog{ label="Ressort"; initial_focus="nb_sp"; :column{ :boxed_column{ label="Spires"; :row{ :edit_box{ label="Segments par spire :"; key="nb_seg"; edit_width=4; allow_accept=true; } :slider{ key="sldr_seg"; min_value=2; max_value=24; big_increment=1; small_increment=1; width=16; is_tab_stop=false; } } :edit_box{ label="Nombre de spires (nombre entier) :"; key="nb_sp"; edit_width=4; allow_accept=true; } } :boxed_row{ label="Pas du ressort"; :radio_column{ :radio_button{ label="Pas à droite"; key="drte"; value="1"; } :radio_button{ label="Pas à gauche"; key="gche"; } } :edit_box{ label="Valeur du pas:"; key="val_pas"; edit_width=8; fixed_width=true; allow_accept=true; } } :boxed_column{ label="Dimensions"; :edit_box{ label="Diamètre extérieur du ressort:"; key="dia_ext"; edit_width=8; allow_accept=true; } :edit_box{ label="Diamètre du boudin:"; key="dia_bdn"; edit_width=8; allow_accept=true; } } :boxed_row{ label="Base de l'axe"; :row{ :retirement_button{ label="Choisir le point <"; key="b_axe"; fixed_width=true; alignment=centered; } } :column{ :edit_box{ label="X:"; key="x_coord"; edit_width=10; allow_accept=true; } :edit_box{ label="Y:"; key="y_coord"; edit_width=10; allow_accept=true; } :edit_box{ label="Z:"; key="z_coord"; edit_width=10; allow_accept=true; } } } } ok_cancel; } Et une image pour décrire la fonction.

Effectivement il faut rajouter un (initget 1) avant chaque (getangle). Sinon pour comprendre comment çà marche un petit dessin vaut mieux qu'un long discours

Un petit dessin vaut mieux qu'un long discours

Test image http://img256.echo.cx/img256/2523/trpz2ut.jpg