Cde Rectangle couteau suisse

[lili2006]

Bonjour à toutes et tous,

 

Merci pour l'info usegomme !

 

Je te laisse donc le "Tramberiser " en paix et verrai le résultat final proposé,... :P

[Tramber]

La cde rectangle 2004 n'a pas l'option rotation d'aprés ce que je vois sur ce que tu as posté.

 

Oh pétard, j'avais pas vu cette nouvelle option dans la commande rectangle :o

 

Merci Utiliserubber !

[usegomme]

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)
)

 

[usegomme]

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

[lili2006]

Bonjour à toutes et tous,

 

Cela commence sérieusement à faire gadget

 

Ben, j'aime bien moi ce p'tit gadget ! ;)

 

Je n'avais pas remarqué qu'ECR permettait également de modifier d'autres formes géométriques,...

 

Merci usegomme,

 

Pus que gadget, pratique aussi en topographie par exemple ou bâtiment,...

:P