usegomme

Merci pour les encouragements. Essaye de faire un peu plus précis comme critique , car je ne suis pas un rapide en lisp et mon temps libre est limité , alors il vaut mieux que j'évite de me perdre en conjonctures. a+

Ah! je viens de trouver mon bug , je corrige au-dessus, et j'espère qu'il n'y en a pas d'autre.

Salut , il y a du progrés . voici le dernier jus. ;;; BIGBURST.LSP adaptation de burst.lsp 12-03-09 ind C ;;; (Defun C:BIGBURST (/ item bitset bump att-text lastent burst-one burst BCNT BLAYER BCOLOR ELAST BLTYPE ETYPE PSFLAG ENAME ) ;----------------------------------------------------- ; Item from association list ;----------------------------------------------------- (Defun ITEM (N E) (CDR (Assoc N E))) ;----------------------------------------------------- ; Error Handler ;----------------------------------------------------- (acet-error-init (list (list "cmdecho" 0 "highlight" 1 ) T ;flag. True means use undo for error clean up. );list );acet-error-init ;----------------------------------------------------- ; BIT SET ;----------------------------------------------------- (Defun BITSET (A B) (= (Boole 1 A B) B)) ;----------------------------------------------------- ; BUMP ;----------------------------------------------------- (Setq bcnt 0) (Defun bump (prmpt) (Princ (Nth bcnt '("\r-" "\r\\" "\r|" "\r/")) ) (Setq bcnt (Rem (1+ bcnt) 4)) ) ;----------------------------------------------------- ; Convert Attribute Entity to Text Entity or MText Entity ;----------------------------------------------------- (Defun ATT-TEXT (AENT / ANAME TENT ILIST INUM) (setq ANAME (cdr (assoc -1 AENT))) ; (if (_MATTS_UTIL ANAME) ;*** ; (progn ;*** ; Multiple Line Text Attributes (MATTS) - ; make an MTEXT entity from the MATTS data ; (_MATTS_UTIL ANAME 1) ;*** ; ) ;*** ; (progn ;*** ; else -Single line attribute conversion (Setq TENT '((0 . "TEXT"))) (ForEach INUM '(8 6 38 39 62 67 210 10 40 1 50 41 51 7 71 72 73 11 74 ) (If (Setq ILIST (Assoc INUM AENT)) (Setq TENT (Cons ILIST TENT)) ) ) (Setq tent (Subst (Cons 73 (item 74 aent)) (Assoc 74 tent) tent ) ) (EntMake (Reverse TENT)) ; ) ;*** ; ) ;*** ) ;----------------------------------------------------- ; Find True last entity ;----------------------------------------------------- (Defun LASTENT (/ E0 EN) (Setq E0 (EntLast)) (While (Setq EN (EntNext E0)) (Setq E0 EN) ) E0 ) ;----------------------------------------------------- ; See if a block is explodable. Return T if it is, ; otherwise return nil ;----------------------------------------------------- (Defun EXPLODABLE (BNAME / B expld) (vl-load-com) (setq BLOCKS (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object))) ) (vlax-for B BLOCKS (if (and (= :vlax-false (vla-get-islayout B)) (= (strcase (vla-get-name B)) (strcase BNAME))) (setq expld (= :vlax-true (vla-get-explodable B))) ) ) expld ) ;----------------------------------------------------- ; Burst one entity ;----------------------------------------------------- (Defun BIGBURST-ONE (BNAME / BENT ANAME ENT ATYPE AENT AGAIN ENAME ENT BBLOCK SS-COLOR SS-LAYER SS-LTYPE mirror ss-mirror mlast) (Setq BENT (EntGet BNAME) BLAYER (ITEM 8 BENT) BCOLOR (ITEM 62 BENT) BBLOCK (ITEM 2 BENT) BCOLOR (Cond ((> BCOLOR 0) BCOLOR) ;;; ((= BCOLOR 0) "BYBLOCK") ;;; 0 = byblock ;*** ((= BCOLOR 0) "BYLAYER") ;*** ("BYLAYER") ) BLTYPE (Cond ((ITEM 6 BENT)) ("BYLAYER")) ) ;*** rajout (if (setq BEPL (item 370 bent)) (if (= bepl -2) ;;; -2 = byblock (setq bepl nil) (if (> bepl 0)(setq bepl (* bepl 0.01))) ) ) ;*** fin rajout (Setq ELAST (LASTENT)) (If (and (EXPLODABLE BBLOCK) (= 1 (ITEM 66 BENT))) (Progn (Setq ANAME BNAME) (While (Setq ANAME (EntNext ANAME) AENT (EntGet ANAME) ATYPE (ITEM 0 AENT) AGAIN (= "ATTRIB" ATYPE) ) (bump "Converting attributes") (ATT-TEXT AENT) ) ) ) (Progn (bump "Exploding block") (acet-explode BNAME) ;(command "_.explode" bname) ) (Setq SS-LAYER (SsAdd) ENAME ELAST ) (While (Setq ENAME (EntNext ENAME)) (bump "Gathering pieces") (Setq ENT (EntGet ENAME) ETYPE (ITEM 0 ENT) ) (If (= "ATTDEF" ETYPE) (Progn (If (BITSET (ITEM 70 ENT) 2) (ATT-TEXT ENT) ) (EntDel ENAME) ) (Progn ;; (If (= "0" (ITEM 8 ENT)) ;*** (SsAdd ENAME SS-LAYER) ; toutes les entités seront changées de calque ;; ) ; propriétés du calque de l'entité avant changement ;; ajout *** (setq EL-COLOR (cdr (assoc 62 (entget (tblobjname "LAYER" (ITEM 8 ENT)))))) (setq EL-TPL (cdr (assoc 6 (entget (tblobjname "LAYER" (ITEM 8 ENT)))))) (if (< 0 (setq EL-EPL (cdr (assoc 370 (entget (tblobjname "LAYER" (ITEM 8 ENT))))))) (setq EL-EPL (* EL-EPL 0.01)) (if (= EL-EPL -3) (setq EL-EPL "BYLAYER")) ) (If (= 0 (ITEM 62 ENT)) (Command "_.chprop" ename "" "_C" BCOLOR "") ) (If (and (not (ITEM 62 ENT))(/= "0" (ITEM 8 ENT)) ) (Command "_.chprop" ename "" "_C" EL-COLOR "") ) (If (= "ByBlock" (ITEM 6 ENT)) ;*** remplacé "BYBLOCK" par "ByBlock" (Command "_.chprop" ename "" "_LT" BLTYPE "") ) (If (and (not (ITEM 6 ENT))(/= "0" (ITEM 8 ENT))) (Command "_.chprop" ename "" "_LT" EL-TPL "") ) (If (and (not BEPL) (= -2 (ITEM 370 ENT))) (Command "_.chprop" ename "" "ep" "BYLAYER" "") ) (If (and BEPL (= -2 (ITEM 370 ENT))) (Command "_.chprop" ename "" "ep" BEPL "") ) (If (and (not (ITEM 370 ENT))(/= "0" (ITEM 8 ENT))) (Command "_.chprop" ename "" "ep" EL-EPL "") ) ) ) ) (If (> (SsLength SS-LAYER) 0) (Progn (bump "Fixing layers") (Command "_.chprop" SS-LAYER "" "_LA" BLAYER "" ) ) ) ) ;----------------------------------------------------- ; BURST MAIN ROUTINE ;----------------------------------------------------- (Defun BIGBURST (/ SS1) ;*** (setq PSFLAG (if (= 1 (caar (vports))) 1 0 ) ) (Setq SS1 (SsGet (list (cons 0 "INSERT")(cons 67 PSFLAG)))) (If SS1 (Progn (Setvar "highlight" 0) (terpri) (Repeat (SsLength SS1) (Setq ENAME (SsName SS1 0)) (SsDel ENAME SS1) (BIGBURST-ONE ENAME) ;*** ) (princ "\n") ) ) ) ;----------------------------------------------------- ; BURST COMMAND ;----------------------------------------------------- (BIGBURST) ;*** (acet-error-restore) );end defun (princ) [Edité le 10/3/2009 par usegomme] [Edité le 12/3/2009 par usegomme]

Aprés l'évéque révisionniste , en voici un, capo chef, bien décidé à faire respecter le réglement de son église quoi qu'il en coûte, sans coeur et sans jugeotte, le parfait crétin qui fait semblant de croire que le réglement de sa caserne vient de Dieu. Comme si Dieu voulait qu'une fillette de 9 ans fût enceinte. Il y a longtemps qu'il aurait du comprendre que la volonté de Dieu n'est pas faite sur la terre et l'exemple du Christ bon et charitable est d'abord pour lui qui se prétend représentant de Dieu . Il faudrait qu'un jour ils arrivent à comprendre que Dieu est Amour et que c'est vers l'amour qu'il faut tendre même si pour nous c'est un bien grand mot.

Merci beaucoup (gile), avec ça je vais peut être arriver à terminer la modif de burst. Bon weekend

Bonjour , Je voudrais pouvoir connaitre l'épaisseur de ligne attribué à un calque. Avec tblsearch je n'obtient pas cette information et je ne sais pas comment faire.

Tout compte fait , on n'a pas besoin de ce _MATTS_UTIL , aussi je l'ai désactivé dans le lisp. je le met à jour dans le post au dessus.

Bonjour , envoie -moi le burst de la 2007 pour que je regarde ce qui change par rapport à 2008. usegomme chez hotmail.fr A+

Salut , voilà BURST.LSP des express est modifié pour ton usage , ça semble fonctionner correctement. si tu t' intêresses au lisp j'ai indiqué les modifs par ;*** JE SIGNALE EN PASSANT UNE ERREUR DANS BURST Il faut remplacer "BYBLOCK" par "ByBlock" dans la ligne suivante (If (= "BYBLOCK" (ITEM 6 ENT)) ------------------------- ;;; ;;; BIGBURST.LSP adaptation de BURST.LSP 04-03-09 modifié le 05-03-09 ;;; (Defun C:BIGBURST (/ item bitset bump att-text lastent burst-one burst ;*** BCNT BLAYER BCOLOR ELAST BLTYPE ETYPE PSFLAG ENAME ) ;----------------------------------------------------- ; Item from association list ;----------------------------------------------------- (Defun ITEM (N E) (CDR (Assoc N E))) ;----------------------------------------------------- ; Error Handler ;----------------------------------------------------- (acet-error-init (list (list "cmdecho" 0 "highlight" 1 ) T ;flag. True means use undo for error clean up. );list );acet-error-init ;----------------------------------------------------- ; BIT SET ;----------------------------------------------------- (Defun BITSET (A B) (= (Boole 1 A B) B)) ;----------------------------------------------------- ; BUMP ;----------------------------------------------------- (Setq bcnt 0) (Defun bump (prmpt) (Princ (Nth bcnt '("\r-" "\r\\" "\r|" "\r/")) ) (Setq bcnt (Rem (1+ bcnt) 4)) ) ;----------------------------------------------------- ; Convert Attribute Entity to Text Entity or MText Entity ;----------------------------------------------------- (Defun ATT-TEXT (AENT / ANAME TENT ILIST INUM) (setq ANAME (cdr (assoc -1 AENT))) ; (if (_MATTS_UTIL ANAME) ;*** ; (progn ;*** ; Multiple Line Text Attributes (MATTS) - ; make an MTEXT entity from the MATTS data ; (_MATTS_UTIL ANAME 1) ;*** ; ) ;*** ; (progn ;*** ; else -Single line attribute conversion (Setq TENT '((0 . "TEXT"))) (ForEach INUM '(8 6 38 39 62 67 210 10 40 1 50 41 51 7 71 72 73 11 74 ) (If (Setq ILIST (Assoc INUM AENT)) (Setq TENT (Cons ILIST TENT)) ) ) (Setq tent (Subst (Cons 73 (item 74 aent)) (Assoc 74 tent) tent ) ) (EntMake (Reverse TENT)) ; ) ;*** ; ) ;*** ) ;----------------------------------------------------- ; Find True last entity ;----------------------------------------------------- (Defun LASTENT (/ E0 EN) (Setq E0 (EntLast)) (While (Setq EN (EntNext E0)) (Setq E0 EN) ) E0 ) ;----------------------------------------------------- ; See if a block is explodable. Return T if it is, ; otherwise return nil ;----------------------------------------------------- (Defun EXPLODABLE (BNAME / B expld) (vl-load-com) (setq BLOCKS (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object))) ) (vlax-for B BLOCKS (if (and (= :vlax-false (vla-get-islayout B)) (= (strcase (vla-get-name B)) (strcase BNAME))) (setq expld (= :vlax-true (vla-get-explodable B))) ) ) expld ) ;----------------------------------------------------- ; Burst one entity ;----------------------------------------------------- (Defun BIGBURST-ONE (BNAME / BENT ANAME ENT ATYPE AENT AGAIN ENAME ;*** ENT BBLOCK SS-COLOR SS-LAYER SS-LTYPE mirror ss-mirror mlast) (Setq BENT (EntGet BNAME) BLAYER (ITEM 8 BENT) BCOLOR (ITEM 62 BENT) BBLOCK (ITEM 2 BENT) BCOLOR (Cond ((> BCOLOR 0) BCOLOR) ;;; ((= BCOLOR 0) "BYBLOCK") ;*** ((= BCOLOR 0) "BYLAYER") ;*** ("BYLAYER") ) BLTYPE (Cond ((ITEM 6 BENT)) ("BYLAYER")) ) ;*** rajout (if (setq bepl (item 370 bent)) (if (= bepl -2) (setq bepl nil) (setq bepl (* bepl 0.01)) ) ) ;*** fin rajout (Setq ELAST (LASTENT)) (If (and (EXPLODABLE BBLOCK) (= 1 (ITEM 66 BENT))) (Progn (Setq ANAME BNAME) (While (Setq ANAME (EntNext ANAME) AENT (EntGet ANAME) ATYPE (ITEM 0 AENT) AGAIN (= "ATTRIB" ATYPE) ) (bump "Converting attributes") (ATT-TEXT AENT) ) ) ) (Progn (bump "Exploding block") (acet-explode BNAME) ;(command "_.explode" bname) ) (Setq SS-epl (SsAdd) ;*** rajout SS-LAYER (SsAdd) SS-COLOR (SsAdd) SS-LTYPE (SsAdd) ENAME ELAST ) (While (Setq ENAME (EntNext ENAME)) (bump "Gathering pieces") (Setq ENT (EntGet ENAME) ETYPE (ITEM 0 ENT) ) (If (= "ATTDEF" ETYPE) (Progn (If (BITSET (ITEM 70 ENT) 2) (ATT-TEXT ENT) ) (EntDel ENAME) ) (Progn (if (= -2 (item 370 ent)) (ssadd ename ss-epl)) ;*** rajout ;; (If (= "0" (ITEM 8 ENT)) ;*** (SsAdd ENAME SS-LAYER) ;; ) ;*** (If (= 0 (ITEM 62 ENT)) (SsAdd ENAME SS-COLOR) ) (If (= "ByBlock" (ITEM 6 ENT)) ;*** remplacé "BYBLOCK" par "ByBlock" (SsAdd ENAME SS-LTYPE) ) ) ) ) (If (> (SsLength SS-LAYER) 0) (Progn (bump "Fixing layers") (Command "_.chprop" SS-LAYER "" "_LA" BLAYER "" ) ) ) (If (> (SsLength SS-COLOR) 0) (Progn (bump "Fixing colors") (Command "_.chprop" SS-COLOR "" "_C" BCOLOR "" ) ) ) (If (> (SsLength SS-LTYPE) 0) (Progn (bump "Fixing linetypes") (Command "_.chprop" SS-LTYPE "" "_LT" BLTYPE "" ) ) ) ;*** rajouté (If (> (SsLength SS-EPL) 0) (Progn (bump "Fixing Epaisseur_ligne") (Command "_.chprop" SS-EPL "" ) (if bepl (command "ep" bepl) (command "ep" "BYLAYER")) ; pas trouvé "ep" en anglais "_.." ? (command "") ) ) ;*** fin rajout ) ;----------------------------------------------------- ; BURST MAIN ROUTINE ;----------------------------------------------------- (Defun BIGBURST (/ SS1) ;*** (setq PSFLAG (if (= 1 (caar (vports))) 1 0 ) ) (Setq SS1 (SsGet (list (cons 0 "INSERT")(cons 67 PSFLAG)))) (If SS1 (Progn (Setvar "highlight" 0) (terpri) (Repeat (SsLength SS1) (Setq ENAME (SsName SS1 0)) (SsDel ENAME SS1) (BIGBURST-ONE ENAME) ;*** ) (princ "\n") ) ) ) ;----------------------------------------------------- ; BURST COMMAND ;----------------------------------------------------- (BIGBURST) ;*** (acet-error-restore) );end defun (princ) [Edité le 5/3/2009 par usegomme]

J'ai aussi modifié xboxt pour qu'il soit compatible avec 2004 , du moins j'espère.

Salut , et oui j'utilise toujours la gomme et le crayon. J'ai donc modifié xbox pour que la hauteur du rectangle soit en mémoire comme pour xboxt, sauf que là c'est un point qui est demandé et pas une distance et donc ce que vous taper au clavier sera en fonction de l'orientation donnée avec la souris. J' ai remplacé la ligne de construction fictive (grdraw) par une ligne normale pour pouvoir se raccrocher dessus . Si point 3 = pt 2 -> carré Si point 3 = pt 1 -> hexagone si sur la même ligne pt 3 entre 1 et 2 -> triangle si sur la même ligne pts 1 2 3 -> rectangle si sur la même ligne pts 3 1 2 -> losange + en option trapèze et polygone. et normalement ça doit fonctionner aussi sur 2004 car je vérifie la release. Cela commence sérieusement à faire gadget ! mais bon faut bien s'amuser un peu. ; XBOX de usegomme le 03-03-2009 ;; version Tramberisée avec hauteur précédente mémorisée. ;; dessine rectangle par diagonale ;;et si a et b horiz ou vertical, options parallélogramme,carré,triangle équilatéral,losange équil. ;;Hexagone, polygone, trapèze. (defun er:xbox (msg) (setvar "plinewid" pw)(setvar "CMDECHO" 1) (setq *error* m:err m:err nil) (princ) ) (defun cvcp (coord1 coord2) (= (rtos coord1 2 4) (rtos coord2 2 4))) (defun modif:sommet ( ent lent typent pd pf / l1 s xs ys xp yp i ) (setq pd (trans pd 1 0) ok nil xp (car pd) yp (cadr pd)) (if (= typent "POLYLINE") (progn (setq l1 (entget (entnext (cdr (assoc -1 lent))))) ;analyse sommets (while (and (= ok nil) (/= "SEQEND" (cdr (assoc 0 l1)))) (setq s (cdr (assoc 10 l1)) xs (car s) ys (cadr s)) (if (and (cvcp xs xp)(cvcp ys yp)) ;modif sommet (progn (setq ok T pf (trans pf 1 0) l1 (subst (cons 10 pf) (assoc 10 l1) l1)) (entmod l1) (entupd ent) ) (setq l1 (entget (entnext (cdr (assoc -1 l1))))) ) ) ;fin while ) ;fin progn (progn ;; pour LWPOLYLINE (setq i 9) (while (and (= ok nil) (nth (setq i (+ i 1)) lent)) (if (= 10 (car (nth i lent))) (progn (setq s (cdr (nth i lent)) xs (car s) ys (cadr s)) (if (and (cvcp xs xp)(cvcp ys yp)) ;modif sommet (progn (setq ok T pf (trans pf 1 0) lent (subst (cons 10 pf) (nth i lent) lent)) (entmod lent) (entupd ent) ) ;fin progn ) ; fin if ) ;fin progn ) ; fin if ) ;fin while ) ;fin progn ) ) (defun c:EtirCotRect (/ sel lent typent p0 p1 p2 p3 p4 p5 p6 M F disetir angetir rect-ok) (setq m:err-ecr *error* *error* err-ecr) (setq rect-ok nil) (setq sel (entsel "\n Choix du rectangle à Modifier :")) (setq ent (car sel) lent (entget ent) typent (cdr (assoc 0 lent))) (cond ((or (= typent "POLYLINE")(= typent "LWPOLYLINE")) (redraw ent 3) (setq p0 (cadr sel) p1 (osnap p0 "_endp") p2 (osnap p0 "_mid") ang (angle p1 p2) dis (distance p1 p2) p3 (polar p2 ang dis) ) (setq x1 (car p1) y1 (cadr p1) x3 (car p3) y3 (cadr p3)) ;; trouver 2 autres sommets (if (= typent "LWPOLYLINE") (progn (setq i 9 ok 0) (while (and (/= ok 3) (nth (setq i (+ i 1)) lent)) (if (= 10 (car (nth i lent))) (progn (setq s (cdr (nth i lent)) xs (car s) ys (cadr s)) (cond ((and (not (cvcp xs x1)) (not (cvcp ys y1))) (setq F s xF (car s) yF (cadr s) ok (+ ok 1))) ((and (not (cvcp xs x3)) (not (cvcp ys y3))) (setq M s xM (car s) yM (cadr s) ok (+ ok 1))) ) ) ;fin progn ) ; fin if ) ;fin while ; verification (if (and (= ok 2)(or (and (cvcp xF x3) (cvcp yF yM) (cvcp xM x1) (cvcp y1 y3)) (and (cvcp yF y3) (cvcp xF xM) (cvcp yM y1) (cvcp x1 x3)))) (setq rect-ok T) ) );fin progn ) (if rect-ok (progn (setq p4 (getcorner "\n nouveau sommet :" F)) (if (not p4) (setq p4 (getpoint "\n nouveau sommet:" p1)) ) (setq x4 (car p4) y4 (cadr p4)) (modif:sommet ent lent typent p1 p4) ;modif 1 er sommet ; mise a jour de la liste necessaire pour LWPOLYLIGNE avant modif 2 eme sommet (setq lent (entget ent)) (cond ((cvcp x3 xF) (setq p6 (list xF y4))) ((cvcp y3 yF) (setq p6 (list x4 yF)))) (modif:sommet ent lent typent p3 p6) ; modif 2 eme sommet (setq lent (entget ent)) ; mise a jour (cond ((cvcp xM xF) (setq p5 (list xF y4))) ((cvcp yM yF) (setq p5 (list x4 yF)))) (modif:sommet ent lent typent M p5) ; modif 3 eme sommet (setq lent (entget ent)) ; mise a jour (setq ent nil) ) (progn (setq d1 (distance p0 p1) d2 (distance p0 p2)) (if (< d1 d2)(setq p2 p1)) (setq p4 (getpoint "\n nouvelle position du segment:" p2)) (setq angetir (angle p2 p4) disetir (distance p2 p4)) (setq p5 (polar p1 angetir disetir) p6 (polar p3 angetir disetir)) (modif:sommet ent lent typent p1 p5) ;modif 1 er sommet (setq lent (entget ent)); mise a jour (modif:sommet ent lent typent p3 p6) ;modif 2 eme sommet (setq ent nil) ) ) ) (T (setq ent nil) (prompt "\n * CE N'EST PAS UNE POLYLIGNE * ") (princ)) ) (gc) (setq *error* m:err-ecr m:err-ecr nil) (princ) ) (defun rectrubber (a b / c d angl_base long angl_haut larg nc tpz) (setq m:err *error* *error* er:xbox) (setvar "CMDECHO" 0) (setq angl_base (angle a b) long (distance a b) tpz nil nc nil) (if (not hxbox) (setq hxbox long)) (command "_line" "_none" a "_none" b "") ; ligne de construction remplace grdraw (initget "Polygone Carré tRiangle Losange Hexagone Trapèze") (setq c (getpoint (strcat "\nLargeur ou [Trapèze/Polygone/Hexagone/Carré/Losange/tRiangle] <"(rtos hxbox 2 4)"> :") b)) (cond ((= c "Carré") (setq c nil nc 4)) ((= c "Hexagone") (setq c nil nc 6)) ((= c "tRiangle")(setq c (polar b (+ angl_base pi)(* 0.5 long)))) ((= c "Losange")(setq c (polar b (+ angl_base pi)(* 1.5 long)))) ((= c "Polygone") (setq c nil) (if (not (setq nc (getint "\nNombre de cotés ou <5>]: "))) (setq nc 5)) ) ((= c "Trapèze") (setq c nil) (if (not (setq tpz (getpoint b "\n3eme sommet du trapèze ou ]: "))) (setq tpz (polar b (+ angl_base (/ pi 1.5)) (* 0.5 long))) ) ) ((equal c a) (setq c nil nc 6)) ;;; Hexagone ) (entdel (entlast)) (if c (if (and (= (rtos (car b) 2 2) (rtos (car c) 2 2)) ;;; carré (= (rtos (cadr b) 2 2) (rtos (cadr c) 2 2)) ) (setq c nil nc 4) ) ) (cond ((and (not c)(not nc)(not tpz) );;; -> rectangle hauteur= hxbox (setq c (polar b (+ angl_base (* 0.5 pi)) hxbox)) (setq d (polar a (+ angl_base (* 0.5 pi)) hxbox)) ;(setq hxbox (abs (- (cadr c)(cadr b)))) ) ((and (not c)(not nc) tpz );;; -> trapèze (setq c tpz) (setq d (polar a (- (+ pi (* 2 (angle a b))) (angle b c)) (distance b c))) ) (c ;; if c (setq angl_haut (angle b c)) (setq ab (angle a b)) (cond ((= (angtos angl_haut 0 1) (angtos angl_base 0 1)) ;;; orientation incorrecte pour rectangle ou parallèlogr. (setq larg (distance b c)) (setq c (polar b (+ angl_base (* 0.5 pi)) larg)) ; replacé à 90° (setq d (polar c (+ angl_base pi) long)) ) ((or (= (angtos (+ angl_haut pi) 0 1) (angtos angl_base 0 1)) (= (angtos (- angl_haut pi) 0 1) (angtos angl_base 0 1)) ) ;;; orientation incorrecte pour rectangle ou parallèlogr. (setq larg (distance b c) ) (setq c (polar a (+ angl_base (/ pi 3)) long));;; ->triangle équilatéral (cond ((> larg long) (setq d (polar a (+ angl_base (* 5 (/ pi 3))) long)) ;;-> losange ;;permutation des points (setq pt c c b b pt) ) ) ) (t (setq d (polar c (+ angl_base pi) long)) (setq hxbox (abs (- (cadr c)(cadr b)))) ) ) ) ; fin if c ) (cond ((and a b c d) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" b "_none" c "_none" d "_c") (setvar "plinewid" pw) ) ((and a b c ) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" b "_none" c "_c") (setvar "plinewid" pw) ) ((and a b nc ) (if (< nc 3) (setq nc 3)) (setq xnc nc) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" b) (repeat (- nc 2) (command "_none" (setq b (polar b (setq angl_base (+ angl_base (/ (* 2 pi) nc))) long))) ) (command "_c") (setvar "plinewid" pw) ) ) (er:xbox) ) (defun c:XBOX (/ xa ya xb yb a b tolang angl_base ) (setvar "CMDECHO" 1) (setq pw (getvar "plinewid")) ; svgd epais polylign (setq xa (getvar "lastpoint")) ;pour controle cde rectang (setq a "Epaisseur" b nil) (while (= a "Epaisseur") (initget "Epaisseur éTirer.cotés") (setq a (getpoint "\nPremier coin ou [Epaisseur/<éTirer.cotés>]: ")) (if (= a "éTirer.cotés")(setq a nil)) (cond ((not a)(c:EtirCotRect)) ((= a "Epaisseur") (if epaisseur_box (if (setq b (getdist (strcat "\n Epaisseur du trait <"(rtos epaisseur_box 2 4)">:")))(setq epaisseur_box b)) (setq epaisseur_box (getdist "\n Epaisseur du trait:")) ) ) ) ;cond ) (cond (a (command "_rectang" "_t" (getvar "thickness")"_c" "0" "0" "_f" "0" "_w" (if epaisseur_box epaisseur_box 0.0) "_none" a ) (if (> (atof (substr (getvar "ACADVER")1 4)) 16.1) ;; ok si supérieur à autocad 2005 (command "_r" "0" ) ) (command pause) (setq b (getvar "LASTPOINT")) (if (or (equal a b)(equal xa b)) (setq b nil)) (if b (entdel (entlast))) ) ) (cond (b ;; if b (setq tolang 1.0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TOLERANCE ANGULAIRE + ou - 1° (setq xa (car a) ya (cadr a) xb (car b) yb (cadr b)) (setq angl_base (* (angle a b) (/ 180 pi))) (cond ((or (= angl_base 0.0) (or (= angl_base 0.0)(and (< angl_base (+ 0.0 tolang))(> angl_base (- 0.0 tolang)))(> angl_base (- 360.0 tolang))) (or (= angl_base 180.0)(and (< angl_base (+ 180.0 tolang))(> angl_base (- 180.0 tolang)))) ) (setq b (list xb ya)) (rectrubber a b) ) ((or (or (= angl_base 90.0)(and (< angl_base (+ 90.0 tolang))(> angl_base (- 90.0 tolang)))) (or (= angl_base 270.0)(and (< angl_base (+ 270.0 tolang))(> angl_base (- 270.0 tolang)))) ) (setq b (list xa yb)) (rectrubber a b) ) (t ;; rectangle par diagonale (setq hxbox (abs (- (cadr b)(cadr a)))) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" (list xa yb) "_none" b "_none" (list xb ya) "_c") (setvar "plinewid" pw) ) ) ) ) (princ) )

J'ai regardé "burst" des express , il ne décompose que les blocs mais tous les blocs avec ou sans attribut et fait ce que fait lexplode au niveau des calques aussi ce dernier ne sert à rien, et je suis d'avis d' adapter burst à ton besoin plutôt que de tenter de l'intégrer.

Merci excalibur.

Bonjour , je souhaiterais savoir si la commande rectangle possède l'option rotation dans autocad 2005. Merci

Salut C'est trés bien ce que tu dis, et même intelligent sauf que si l'imagination est sans borne , il n'en est pas de même pour l'intelligence , être cartésien c'est une grande qualité cependant il ne faut pas faire passer la lettre avant l'esprit et se limiter au rationnalisme c'est ce mettre des bornes bien inutiles car le monde dit rationnel est battu en brêche par biens des faits que l'on met commodément et pêle-mêle dans le registre charlatanisme ou équivalent , sans compter que la science se trouve elle même incapable de comprendre par exemple "l'infiniment grand" comme "l'infiniment petit" , c'est pour ça que j'aime bien parlé de chose scientifique qui en plus de leurs intêrets permettent d'avoir des éléments concrets de reflexion. Voici ce qui est dit par exemple dans un article de science&vie de février : Dans le monde quantique un chat peut être "vivant et mort" et les particules sont doués de télépathie. Un vrai défi à la raison,....... les expériences valident cette" folie quantique". "Mon cerveau reptilien n'est pas cablé pour comprendre le quantique" .J-M. Raymond physicien. "Aujourd'hui, les physiciens manipulent le formalisme quantique sans même comprendre à quoi ça renvoie. On a perdu le lien avec le sens cela conduit à des aberrations. Si notre intelligence ne nous permet pas de comprendre le monde qui nous supporte , comment pourrait-elle expliquer Dieu . Cependant par la logique me semble -t-il ,on peut comprendre qu'il existe un créateur , sans pour autant souscrire aux croyances religieuses obscures et tenaces issue d'un lointain passé . Et de ce point de vu , ce que dit Autospeed du hasard me parait tout à fait convaincant .Pour les autres thèmes, je ne partage pas son point de vu, mais ça pourrait être l'objet d'une autre discussion. C'est à ce genre de pensée qu' à conduit l'ignorance religieuse , croire sans comprendre ou comprendre tout de travers. Alors que la foi et la logique vont de pair, si c'était vraiment le contraire c'est que Dieu n'existe pas .

C'est avec plaisir, et ça fait avancer le schmi.. le shmilili..le schmilblick , et je vais pouvoir améliorer mon lexplode . Bon faire et défaire des blocs ça m'a pris un peu la tête mais j'ai vu comment fonctionner épaisseur de ligne que je n'utilise pas ,ce qui est peut être à reconsidérer. Est-ce que c'est vraiment bien , pratique ? Pour la suite il faudra attendre un peu , je ne sais pas si l'intégration de burst.lsp va être aisé. A+

J'ai rajouté la partie change épaisseur au lisp post n°2 , j'espère que c'est correct parce que ça m' a gavé ! A+

Regarde si ça commence à ressembler à ce que tu souhaites. ;; usegomme 26-02-2009 indice A avec epaisseur ligne ;; decompose en concervant le calque de l'objet et ses propriétés (defun c:expl2po (/ js ent lent typent ss ca ca0 i1 i2 CO LT ep epb) (setvar "cmdecho" 0) (setq ca0 (cdr (assoc 70 (tblsearch "layer" "0")))) (if (>= ca0 4)(command "_layer" "_u" "0" "")) (setq js (ssget)) (setq i1 0) (repeat (sslength js) (setq ent (ssname js i1)) (setq lent (entget ent)) (setq typent (cdr (assoc 0 lent))) (setq ca (cdr (assoc 8 lent))) (if (setq epb (cdr (assoc 370 lent)))(setq epb (* epb 0.01))) (command "_explode" ent) (if (not (zerop (getvar "cmdactive")))(command)) (if (and (setq ss (ssget "p"))(/= typent "3DSOLID") (/= typent "SURFACE")(/= typent "REGION")) (progn (setq i2 0) (repeat (sslength ss) (setq ent (ssname ss i2)) (if (= 0 (setq co (cdr (assoc 62 (entget ent))))) (setq co "bylayer")) (if (= "ByBlock" (setq lt (cdr (assoc 6 (entget ent))))) (setq lt "bylayer")) (if (= -2 (cdr (assoc 370 (entget ent)))) (setq ep "bylayer")(setq ep nil)) (command "_change" ent "" "_p" "_layer" ca ) (if co (command "_co" co)) (if lt (command "_lt" lt)) (cond ((and epb ep)(command "ep" epb)) (ep (command "ep" ep)) ) (command "") (setq i2 (1+ i2)) ) ) ) (setq i1 (1+ i1)) ) (if (>= ca0 4)(command "_layer" "_lo" "0" "")) (setvar "cmdecho" 1) (princ) ) [Edité le 26/2/2009 par usegomme]

Salut BIGC-ROMU Je vais voir ce que je peux faire en attendant tu devrais utiliser la 1er version de lexplode qui correspond mieux à ton besoin et qui est dans le même post. Je la met ci-dessous mais j'ai changé son nom . ;; usegomme 03-09-2008 ;; decompose en concervant le calque de l'objet (defun c:expl2lo (/ js ent lent typent ss ca ca0 i1 i2) (setvar "cmdecho" 0) (setq ca0 (cdr (assoc 70 (tblsearch "layer" "0")))) (if (>= ca0 4)(command "_layer" "_u" "0" "")) (setq js (ssget)) (setq i1 0) (repeat (sslength js) (setq ent (ssname js i1)) (setq lent (entget ent)) (setq typent (cdr (assoc 0 lent))) (setq ca (cdr (assoc 8 lent))) (command "_explode" ent) (if (not (zerop (getvar "cmdactive")))(command)) (if (and (setq ss (ssget "p"))(/= typent "3DSOLID") (/= typent "SURFACE")(/= typent "REGION")) (progn (setq i2 0) (repeat (sslength ss) (setq ent (ssname ss i2)) (command "_change" ent "" "_p" "_layer" ca "") (setq i2 (1+ i2)) ) ) ) (setq i1 (1+ i1)) ) (if (>= ca0 4)(command "_layer" "_lo" "0" "")) (setvar "cmdecho" 1) (princ) ) [Edité le 26/2/2009 par usegomme]

Pour Lilian , j'ai intégré ecr.lsp dans xbox et je compte le Tramberiser un peu.

Salut La cde rectangle 2004 n'a pas l'option rotation d'aprés ce que je vois sur ce que tu as posté. Je l'ai donc supprimé dans la routine. Je pense que ça devrait aller. ;;;; XBOXT2004 usegomme le 26-02-09 ;; version Tramber 2004 ;; dessine rectangle par diagonale ;;et si a et b horiz ou vertical, options parallélogramme,carré,rect,triangle équilatéral,losange équil (defun er:xbox (msg) (setvar "plinewid" pw)(setvar "CMDECHO" 1) (setq *error* m:err m:err nil) (princ) ) (defun err-ecr (msg) (if ent (progn (redraw ent 4) (setq ent nil))) (setq *error* m:err-ecr m:err-ecr nil) (princ ) ) (defun cvcp (coord1 coord2) (= (rtos coord1 2 4) (rtos coord2 2 4))) (defun modif:sommet ( ent lent typent pd pf / l1 s xs ys xp yp i ) (setq pd (trans pd 1 0) ok nil xp (car pd) yp (cadr pd)) (if (= typent "POLYLINE") (progn (setq l1 (entget (entnext (cdr (assoc -1 lent))))) ;analyse sommets (while (and (= ok nil) (/= "SEQEND" (cdr (assoc 0 l1)))) (setq s (cdr (assoc 10 l1)) xs (car s) ys (cadr s)) (if (and (cvcp xs xp)(cvcp ys yp)) ;modif sommet (progn (setq ok T pf (trans pf 1 0) l1 (subst (cons 10 pf) (assoc 10 l1) l1)) (entmod l1) (entupd ent) ) (setq l1 (entget (entnext (cdr (assoc -1 l1))))) ) ) ;fin while ) ;fin progn (progn ;; pour LWPOLYLINE (setq i 9) (while (and (= ok nil) (nth (setq i (+ i 1)) lent)) (if (= 10 (car (nth i lent))) (progn (setq s (cdr (nth i lent)) xs (car s) ys (cadr s)) (if (and (cvcp xs xp)(cvcp ys yp)) ;modif sommet (progn (setq ok T pf (trans pf 1 0) lent (subst (cons 10 pf) (nth i lent) lent)) (entmod lent) (entupd ent) ) ;fin progn ) ; fin if ) ;fin progn ) ; fin if ) ;fin while ) ;fin progn ) ) (defun c:EtirCotRect (/ sel lent typent p0 p1 p2 p3 p4 p5 p6 M F disetir angetir rect-ok) (setq m:err-ecr *error* *error* err-ecr) (setq rect-ok nil) (setq sel (entsel "\n Choix du rectangle à Modifier :")) (setq ent (car sel) lent (entget ent) typent (cdr (assoc 0 lent))) (cond ((or (= typent "POLYLINE")(= typent "LWPOLYLINE")) (redraw ent 3) (setq p0 (cadr sel) p1 (osnap p0 "_endp") p2 (osnap p0 "_mid") ang (angle p1 p2) dis (distance p1 p2) p3 (polar p2 ang dis) ) (setq x1 (car p1) y1 (cadr p1) x3 (car p3) y3 (cadr p3)) ;; trouver 2 autres sommets (if (= typent "LWPOLYLINE") (progn (setq i 9 ok 0) (while (and (/= ok 3) (nth (setq i (+ i 1)) lent)) (if (= 10 (car (nth i lent))) (progn (setq s (cdr (nth i lent)) xs (car s) ys (cadr s)) (cond ((and (not (cvcp xs x1)) (not (cvcp ys y1))) (setq F s xF (car s) yF (cadr s) ok (+ ok 1))) ((and (not (cvcp xs x3)) (not (cvcp ys y3))) (setq M s xM (car s) yM (cadr s) ok (+ ok 1))) ) ) ;fin progn ) ; fin if ) ;fin while ; verification (if (and (= ok 2)(or (and (cvcp xF x3) (cvcp yF yM) (cvcp xM x1) (cvcp y1 y3)) (and (cvcp yF y3) (cvcp xF xM) (cvcp yM y1) (cvcp x1 x3)))) (setq rect-ok T) ) );fin progn ) (if rect-ok (progn (setq p4 (getcorner "\n nouveau sommet :" F)) (if (not p4) (setq p4 (getpoint "\n nouveau sommet:" p1)) ) (setq x4 (car p4) y4 (cadr p4)) (modif:sommet ent lent typent p1 p4) ;modif 1 er sommet ; mise a jour de la liste necessaire pour LWPOLYLIGNE avant modif 2 eme sommet (setq lent (entget ent)) (cond ((cvcp x3 xF) (setq p6 (list xF y4))) ((cvcp y3 yF) (setq p6 (list x4 yF)))) (modif:sommet ent lent typent p3 p6) ; modif 2 eme sommet (setq lent (entget ent)) ; mise a jour (cond ((cvcp xM xF) (setq p5 (list xF y4))) ((cvcp yM yF) (setq p5 (list x4 yF)))) (modif:sommet ent lent typent M p5) ; modif 3 eme sommet (setq lent (entget ent)) ; mise a jour (setq ent nil) ) (progn (setq d1 (distance p0 p1) d2 (distance p0 p2)) (if (< d1 d2)(setq p2 p1)) (setq p4 (getpoint "\n nouvelle position du segment:" p2)) (setq angetir (angle p2 p4) disetir (distance p2 p4)) (setq p5 (polar p1 angetir disetir) p6 (polar p3 angetir disetir)) (modif:sommet ent lent typent p1 p5) ;modif 1 er sommet (setq lent (entget ent)); mise a jour (modif:sommet ent lent typent p3 p6) ;modif 2 eme sommet (setq ent nil) ) ) ) (T (setq ent nil) (prompt "\n * CE N'EST PAS UNE POLYLIGNE * ") (princ)) ) (gc) (setq *error* m:err-ecr m:err-ecr nil) (princ) ) (defun rectramber (a b / c d angl_base long angl_haut larg pt h nc) (setq m:err *error* *error* er:xbox) (setvar "CMDECHO" 0) (setq angl_base (angle a b) long (distance a b) h nil nc nil) (if (not hxbox) (setq hxbox long)) (setq pt nil) ; pour losange (grdraw a b -1) (initget "Parallelogr Carré Triangle Losange Hexagone") (if (setq c (getdist (strcat "\nLargeur ou [Carré/Hexagone/Losange/Parallelogr/Triangle]<"(rtos hxbox 2 4)">:") b)) (if (and (/= c "Carré")(/= c "Parallelogr")(/= c "Triangle")(/= c "Losange")(/= c "Hexagone")) (setq h c hxbox c c nil) ) (setq h hxbox) ) (cond ((= c "Hexagone") (setq c nil nc 6)) ((= c "Triangle")(setq c (polar b (+ angl_base pi)(* 0.5 long)))) ((= c "Losange")(setq c (polar b (+ angl_base pi)(* 1.5 long)))) ((= c "Parallelogr") (if (not (setq c (getpoint b "\nPoint suivant ou [] : ")))(setq c "Carré")) ) ) (cond ((= c "Carré") (setq c (polar b (+ angl_base (* 0.5 pi)) long)) (setq d (polar a (+ angl_base (* 0.5 pi)) long)) ;(setq hxbox (abs (- (cadr c)(cadr b)))) ) (c ;; if c (setq angl_haut (angle b c)) (setq ah angl_haut)(setq ab (angle a b)) (cond ((= (angtos angl_haut 0 1) (angtos angl_base 0 1)) ;;; orientation incorrecte pour rectangle ou parallèlogr. (setq larg (distance b c)) (setq c (polar b (+ angl_base (* 0.5 pi)) larg)) ; replacé à 90° (setq d (polar c (+ angl_base pi) long)) ) ((or (= (angtos (+ angl_haut pi) 0 1) (angtos angl_base 0 1)) (= (angtos (- angl_haut pi) 0 1) (angtos angl_base 0 1)) ) ;;; orientation incorrecte pour rectangle ou parallèlogr. (setq larg (distance b c) ) (setq c (polar a (+ angl_base (/ pi 3)) long));;; ->triangle équilatéral (cond ((> larg long) (setq d (polar a (+ angl_base (* 5 (/ pi 3))) long)) ;;-> losange ;;permutation des points (setq pt c c b b pt) ) ) ) (t (setq d (polar c (+ angl_base pi) long)) (setq hxbox (abs (- (cadr c)(cadr b)))) ) ) ) ; if c ((and (not c)(not nc) );;; -> rectangle hauteur= hxbox (setq c (polar b (+ angl_base (* 0.5 pi)) hxbox)) (setq d (polar a (+ angl_base (* 0.5 pi)) hxbox)) ;(setq hxbox (abs (- (cadr c)(cadr b)))) ) ) (if pt (grdraw a c -1)(grdraw a b -1)) (cond ((and a b c d) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" b "_none" c "_none" d "_c") (setvar "plinewid" pw) ) ((and a b c ) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" b "_none" c "_c") (setvar "plinewid" pw) ) ((and a b nc ) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" b) (repeat (- nc 2) (command "_none" (setq b (polar b (setq angl_base (+ angl_base (/ pi (/ nc 2))))long))) ) (command "_c") (setvar "plinewid" pw) ) ) (er:xbox) ) (defun c:xboxT (/ xa ya xb yb a b tolang angl_base ) (setvar "CMDECHO" 1) (setq pw (getvar "plinewid")) ; svgd epais polylign (setq xa (getvar "lastpoint")) ;pour controle cde rectang (setq a "Epaisseur" b nil) (while (= a "Epaisseur") (initget "Epaisseur éTirer.cotés") (setq a (getpoint "\nPremier coin ou [Epaisseur/<éTirer.cotés>]: ")) (if (= a "éTirer.cotés")(setq a nil)) (cond ((not a)(c:EtirCotRect)) ((= a "Epaisseur") (if epaisseur_box (if (setq b (getdist (strcat "\n Epaisseur du trait <" (rtos epaisseur_box 2 4) ">:")))(setq epaisseur_box b)) (setq epaisseur_box (getdist "\n Epaisseur du trait:")) ) ) ) ;cond ) (cond (a (command "_rectang" "_t" (getvar "thickness")"_c" "0" "0" "_f" "0" "_w" (if epaisseur_box epaisseur_box 0.0) "_none" a pause) (setq b (getvar "LASTPOINT")) (if (or (equal a b)(equal xa b)) (setq b nil)) (if b (entdel (entlast))) ) ) (cond (b ;; if b (setq tolang 1.0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TOLERANCE ANGULAIRE + ou - 1° (setq xa (car a) ya (cadr a) xb (car b) yb (cadr b)) (setq angl_base (* (angle a b) (/ 180 pi))) (cond ((or (= angl_base 0.0) (or (= angl_base 0.0)(and (< angl_base (+ 0.0 tolang))(> angl_base (- 0.0 tolang)))(> angl_base (- 360.0 tolang))) (or (= angl_base 180.0)(and (< angl_base (+ 180.0 tolang))(> angl_base (- 180.0 tolang)))) ) (setq b (list xb ya)) (rectramber a b) ) ((or (or (= angl_base 90.0)(and (< angl_base (+ 90.0 tolang))(> angl_base (- 90.0 tolang)))) (or (= angl_base 270.0)(and (< angl_base (+ 270.0 tolang))(> angl_base (- 270.0 tolang)))) ) (setq b (list xa yb)) (rectramber a b) ) (t ;; rectangle par diagonale (setq hxbox (abs (- (cadr b)(cadr a)))) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" (list xa yb) "_none" b "_none" (list xb ya) "_c") (setvar "plinewid" pw) ) ) ) ) (princ) ) [Edité le 26/2/2009 par usegomme]

Raaaa! tu te marres alors que j'ai passé des heuuuuuuuuures à essayer de remplacer rtos. A que oui ! J'ai mis le e mais je ne suis pas convaincu et je n'ai plus de version antérieure à 2008. Est-ce que la cde rectangle était identique ? S'il y en a qui peuvent et qui ont le temps de tester, à votre bon coeur. A+ Tramber l' impitoyable.

Oui , je mettrai l'autre version à jour après . Merci lili2006 , heureusement que tu es là !

Bonjour et oui , misère je suis bien imparfait. et toujours bricoleur ,je n'arrive pas à faire différemment. C' est fait . Mais non, mais non , c'est avec plaisir. (murmure) eh, les gars , toujours comme ça Tramber ?.... Fichtre !

Bonsoir , voici une version spéciale pour Tramper et ses adeptes, j'espère que je suis sur la bonne voie. ; XBOXT de usegomme le 24-02-2009 ;; version Tramber 1ER indice C 03-03-2009 compatible 2004 ;; dessine rectangle par diagonale ;;et si a et b horiz ou vertical, options parallélogramme,carré,rect,triangle équilatéral,losange équil. (defun er:xbox (msg) (setvar "plinewid" pw)(setvar "CMDECHO" 1) (setq *error* m:err m:err nil) (princ) ) (defun err-ecr (msg) (if ent (progn (redraw ent 4) (setq ent nil))) (setq *error* m:err-ecr m:err-ecr nil) (princ ) ) (defun cvcp (coord1 coord2) (= (rtos coord1 2 4) (rtos coord2 2 4))) (defun modif:sommet ( ent lent typent pd pf / l1 s xs ys xp yp i ) (setq pd (trans pd 1 0) ok nil xp (car pd) yp (cadr pd)) (if (= typent "POLYLINE") (progn (setq l1 (entget (entnext (cdr (assoc -1 lent))))) ;analyse sommets (while (and (= ok nil) (/= "SEQEND" (cdr (assoc 0 l1)))) (setq s (cdr (assoc 10 l1)) xs (car s) ys (cadr s)) (if (and (cvcp xs xp)(cvcp ys yp)) ;modif sommet (progn (setq ok T pf (trans pf 1 0) l1 (subst (cons 10 pf) (assoc 10 l1) l1)) (entmod l1) (entupd ent) ) (setq l1 (entget (entnext (cdr (assoc -1 l1))))) ) ) ;fin while ) ;fin progn (progn ;; pour LWPOLYLINE (setq i 9) (while (and (= ok nil) (nth (setq i (+ i 1)) lent)) (if (= 10 (car (nth i lent))) (progn (setq s (cdr (nth i lent)) xs (car s) ys (cadr s)) (if (and (cvcp xs xp)(cvcp ys yp)) ;modif sommet (progn (setq ok T pf (trans pf 1 0) lent (subst (cons 10 pf) (nth i lent) lent)) (entmod lent) (entupd ent) ) ;fin progn ) ; fin if ) ;fin progn ) ; fin if ) ;fin while ) ;fin progn ) ) (defun c:EtirCotRect (/ sel lent typent p0 p1 p2 p3 p4 p5 p6 M F disetir angetir rect-ok) (setq m:err-ecr *error* *error* err-ecr) (setq rect-ok nil) (setq sel (entsel "\n Choix du rectangle à Modifier :")) (setq ent (car sel) lent (entget ent) typent (cdr (assoc 0 lent))) (cond ((or (= typent "POLYLINE")(= typent "LWPOLYLINE")) (redraw ent 3) (setq p0 (cadr sel) p1 (osnap p0 "_endp") p2 (osnap p0 "_mid") ang (angle p1 p2) dis (distance p1 p2) p3 (polar p2 ang dis) ) (setq x1 (car p1) y1 (cadr p1) x3 (car p3) y3 (cadr p3)) ;; trouver 2 autres sommets (if (= typent "LWPOLYLINE") (progn (setq i 9 ok 0) (while (and (/= ok 3) (nth (setq i (+ i 1)) lent)) (if (= 10 (car (nth i lent))) (progn (setq s (cdr (nth i lent)) xs (car s) ys (cadr s)) (cond ((and (not (cvcp xs x1)) (not (cvcp ys y1))) (setq F s xF (car s) yF (cadr s) ok (+ ok 1))) ((and (not (cvcp xs x3)) (not (cvcp ys y3))) (setq M s xM (car s) yM (cadr s) ok (+ ok 1))) ) ) ;fin progn ) ; fin if ) ;fin while ; verification (if (and (= ok 2)(or (and (cvcp xF x3) (cvcp yF yM) (cvcp xM x1) (cvcp y1 y3)) (and (cvcp yF y3) (cvcp xF xM) (cvcp yM y1) (cvcp x1 x3)))) (setq rect-ok T) ) );fin progn ) (if rect-ok (progn (setq p4 (getcorner "\n nouveau sommet :" F)) (if (not p4) (setq p4 (getpoint "\n nouveau sommet:" p1)) ) (setq x4 (car p4) y4 (cadr p4)) (modif:sommet ent lent typent p1 p4) ;modif 1 er sommet ; mise a jour de la liste necessaire pour LWPOLYLIGNE avant modif 2 eme sommet (setq lent (entget ent)) (cond ((cvcp x3 xF) (setq p6 (list xF y4))) ((cvcp y3 yF) (setq p6 (list x4 yF)))) (modif:sommet ent lent typent p3 p6) ; modif 2 eme sommet (setq lent (entget ent)) ; mise a jour (cond ((cvcp xM xF) (setq p5 (list xF y4))) ((cvcp yM yF) (setq p5 (list x4 yF)))) (modif:sommet ent lent typent M p5) ; modif 3 eme sommet (setq lent (entget ent)) ; mise a jour (setq ent nil) ) (progn (setq d1 (distance p0 p1) d2 (distance p0 p2)) (if (< d1 d2)(setq p2 p1)) (setq p4 (getpoint "\n nouvelle position du segment:" p2)) (setq angetir (angle p2 p4) disetir (distance p2 p4)) (setq p5 (polar p1 angetir disetir) p6 (polar p3 angetir disetir)) (modif:sommet ent lent typent p1 p5) ;modif 1 er sommet (setq lent (entget ent)); mise a jour (modif:sommet ent lent typent p3 p6) ;modif 2 eme sommet (setq ent nil) ) ) ) (T (setq ent nil) (prompt "\n * CE N'EST PAS UNE POLYLIGNE * ") (princ)) ) (gc) (setq *error* m:err-ecr m:err-ecr nil) (princ) ) (defun rectramber (a b / c d angl_base long angl_haut larg pt h nc) (setq m:err *error* *error* er:xbox) (setvar "CMDECHO" 0) (setq angl_base (angle a b) long (distance a b) h nil nc nil) (if (not hxbox) (setq hxbox long)) (setq pt nil) ; pour losange (grdraw a b -1) (initget "Parallelogr Carré Triangle Losange Hexagone") (if (setq c (getdist (strcat "\nLargeur ou [Carré/Hexagone/Losange/Parallelogr/Triangle]<"(rtos hxbox 2 4)">:") b)) (if (and (/= c "Carré")(/= c "Parallelogr")(/= c "Triangle")(/= c "Losange")(/= c "Hexagone")) (setq h c hxbox c c nil) ) (setq h hxbox) ) (cond ((= c "Hexagone") (setq c nil nc 6)) ((= c "Triangle")(setq c (polar b (+ angl_base pi)(* 0.5 long)))) ((= c "Losange")(setq c (polar b (+ angl_base pi)(* 1.5 long)))) ((= c "Parallelogr") (if (not (setq c (getpoint b "\nPoint suivant ou []: ")))(setq c "Carré")) ) ) (cond ((= c "Carré") (setq c (polar b (+ angl_base (* 0.5 pi)) long)) (setq d (polar a (+ angl_base (* 0.5 pi)) long)) ;(setq hxbox (abs (- (cadr c)(cadr b)))) ) (c ;; if c (setq angl_haut (angle b c)) (setq ah angl_haut)(setq ab (angle a b)) (cond ((= (angtos angl_haut 0 1) (angtos angl_base 0 1)) ;;; orientation incorrecte pour rectangle ou parallèlogr. (setq larg (distance b c)) (setq c (polar b (+ angl_base (* 0.5 pi)) larg)) ; replacé à 90° (setq d (polar c (+ angl_base pi) long)) ) ((or (= (angtos (+ angl_haut pi) 0 1) (angtos angl_base 0 1)) (= (angtos (- angl_haut pi) 0 1) (angtos angl_base 0 1)) ) ;;; orientation incorrecte pour rectangle ou parallèlogr. (setq larg (distance b c) ) (setq c (polar a (+ angl_base (/ pi 3)) long));;; ->triangle équilatéral (cond ((> larg long) (setq d (polar a (+ angl_base (* 5 (/ pi 3))) long)) ;;-> losange ;;permutation des points (setq pt c c b b pt) ) ) ) (t (setq d (polar c (+ angl_base pi) long)) (setq hxbox (abs (- (cadr c)(cadr b)))) ) ) ) ; if c ((and (not c)(not nc) );;; -> rectangle hauteur= hxbox (setq c (polar b (+ angl_base (* 0.5 pi)) hxbox)) (setq d (polar a (+ angl_base (* 0.5 pi)) hxbox)) ;(setq hxbox (abs (- (cadr c)(cadr b)))) ) ) (if pt (grdraw a c -1)(grdraw a b -1)) (cond ((and a b c d) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" b "_none" c "_none" d "_c") (setvar "plinewid" pw) ) ((and a b c ) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" b "_none" c "_c") (setvar "plinewid" pw) ) ((and a b nc ) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" b) (repeat (- nc 2) (command "_none" (setq b (polar b (setq angl_base (+ angl_base (/ pi (/ nc 2))))long))) ) (command "_c") (setvar "plinewid" pw) ) ) (er:xbox) ) (defun c:xboxT (/ xa ya xb yb a b tolang angl_base ) (setvar "CMDECHO" 1) (setq pw (getvar "plinewid")) ; svgd epais polylign (setq xa (getvar "lastpoint")) ;pour controle cde rectang (setq a "Epaisseur" b nil) (while (= a "Epaisseur") (initget "Epaisseur éTirer.cotés") (setq a (getpoint "\nPremier coin ou [Epaisseur/<éTirer.cotés>]: ")) (if (= a "éTirer.cotés")(setq a nil)) (cond ((not a)(c:EtirCotRect)) ((= a "Epaisseur") (if epaisseur_box (if (setq b (getdist (strcat "\n Epaisseur du trait <"(rtos epaisseur_box 2 4)">:")))(setq epaisseur_box b)) (setq epaisseur_box (getdist "\n Epaisseur du trait:")) ) ) ) ;cond ) (cond (a (command "_rectang" "_t" (getvar "thickness")"_c" "0" "0" "_f" "0" "_w" (if epaisseur_box epaisseur_box 0.0) "_none" a ) (if (> (atof (substr (getvar "ACADVER")1 4)) 16.1) ;; ok si supérieur à autocad 2005 (command "_r" "0" ) ) (command pause) (setq b (getvar "LASTPOINT")) (if (or (equal a b)(equal xa b)) (setq b nil)) (if b (entdel (entlast))) ) ) (cond (b ;; if b (setq tolang 1.0) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TOLERANCE ANGULAIRE + ou - 1° (setq xa (car a) ya (cadr a) xb (car b) yb (cadr b)) (setq angl_base (* (angle a b) (/ 180 pi))) (cond ((or (= angl_base 0.0) (or (= angl_base 0.0)(and (< angl_base (+ 0.0 tolang))(> angl_base (- 0.0 tolang)))(> angl_base (- 360.0 tolang))) (or (= angl_base 180.0)(and (< angl_base (+ 180.0 tolang))(> angl_base (- 180.0 tolang)))) ) (setq b (list xb ya)) (rectramber a b) ) ((or (or (= angl_base 90.0)(and (< angl_base (+ 90.0 tolang))(> angl_base (- 90.0 tolang)))) (or (= angl_base 270.0)(and (< angl_base (+ 270.0 tolang))(> angl_base (- 270.0 tolang)))) ) (setq b (list xa yb)) (rectramber a b) ) (t ;; rectangle par diagonale (setq hxbox (abs (- (cadr b)(cadr a)))) (if epaisseur_box (setvar "plinewid" epaisseur_box)(setvar "plinewid" 0)) (command "_PLINE" "_none" a "_none" (list xa yb) "_none" b "_none" (list xb ya) "_c") (setvar "plinewid" pw) ) ) ) ) (princ) ) 25-02-09 intégré ex ECR.lsp , rajouté option hexagone [Edité le 25/2/2009 par usegomme][Edité le 25/2/2009 par usegomme][Edité le 25/2/2009 par usegomme][Edité le 26/2/2009 par usegomme] [Edité le 3/3/2009 par usegomme]