Etirer rectangle par coin comme si vrai rectangle

[usegomme]

Bonjour ,

suite au post de lili2006 souhaitant de vrai entité rectangle , et en attendant qu'autodesk lui fasse ce plaisir, j'ai fait un lisp qui permet d'étirer un rectangle par un sommet comme s'il s'agissait d'un vrai rectangle . Ca reste limité (au moins pour l'instant) car le rectangle ne doit pas être pivoté et doit être en LWPOLYLINE pour être reconnu , dans les autres cas le lisp réagit à peu près comme ce que j'avais fait dans ce post ci et qui m'a servi de base.

Le code suit.

[usegomme]

Voilà j'espère qu'il a quelques intérêts.

 

p0 point de sélection

p1 sommet le plus proche

p2 milieu du segment select.

p3 sommet de l'autre coté du segment

F sommet fixe opposé à p1

M sommet mobile opposé à p3

p4 nouveau sommet p1

p5 nouveau sommet M

p6 nouveau sommet p3

 

 

;ECR   Etire Cotés Rectangle , polygone et polyligne
; usegomme le 19-01-2009
(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:ECR (/ 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)       
) 

[lili2006]

Bonjour à toutes et tous,

 

Ouh là, un vrai rectangle ?????!!!

 

Il me tarde de tester ça (pas avnt ce soir,..).

 

Merci en tout cas usegomme de t'être penché sur le problème.

 

Car je ne sais pas pour vous, autres utilisateurs, mais pour moi ces purées de rectangles AutoCAD, c'est une vrai galère,...

 

 

[usegomme]

Ouh là, un vrai rectangle ?????!!!

Non, non, pas un vrai, seulement comme si , encore que ça reste moins bien que les poignées avec l'affichage dynamique des dimensions . Mais bon , je fais avec mes petits moyens.

[Tramber]

Car je ne sais pas pour vous, autres utilisateurs, mais pour moi ces purées de rectangles AutoCAD, c'est une vrai galère,...

Moi je selectionne 2 poignées avec MAJ en même temps et j'étire.

Ce qui fait que je m'en fous !

[lili2006]

Re,

 

Oui, bien sûr Tramber, c'est une solution qui marche bien si tout est dans le SCG ou le même SCU, sinon, galère et c'est souvent le cas sur un plan topo, d'où mon interrogation sur la possibilité d'avoir un "vrai rectangle", c'est dingue tout de même c'thistoire, non ??!!!

 

Et puis avec cette méthode tu ne peux "étirer" qu'un seul côté à la fois,...,

 

 

usegomme, je suis déjà devenu fan,...

 

Merci encore, pour moi, c'est tip-top comme ça !

 

Adjugé.

 

[Tramber]

Et puis avec cette méthode tu ne peux "étirer" qu'un seul côté à la fois,...,

 

C'est pas faux, faudra que j'essaie vot' lisp. Toutes les CAO ont des rectangles ou presque sauf AutoCAD !