Aller au contenu
Problème de lien d'inscription (résolu ?) ×

Transformer un segment droit en arc

(gile)

Par (gile)
dans Routines LISP

 Partager

Messages recommandés

(gile) Proficient

(gile)

Posté(e)
Posté(e)

Une (deux en fait) nouvelle commande pour modifier les polylignes.

 

CURV permet de transformer un segment de polyligne droit en arc (ou de modifier la courbure d'un segment en arc).

Il est possible de spécifier la courbure:

- à l'aide du pointeur,

- en entrant la flèche (positive ou négative, voir la flèche courante affichée dans la bare d'état, à gauche des coordonnées)

- avec le centre : entrer "c" puis spécifier le point,

- avec la direction : entrer"d" puis spécifier la direction.

 

RECT transforme le segment en arc sélectione en segment rectiligne.

 

NOTA : CURV + 0 + Entrée a le même effet que RECT

 

;; CURV
;; Transforme un segment de polyligne droit en arc
;; La courbure est spécifiée à l'aide du pointeur ou au clavier (flèche, centre ou direction)


(defun c:curv (/ err pl pt no scu pa p1 p2 bu mid cor loop gr pm fl str ce di)
 (vl-load-com)
 (or *acdoc*
     (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
 )

 (defun err (msg)
   (if	(= msg "Fonction annulée")
     (princ)
     (princ (strcat "Erreur: " msg))
   )
   (vla-SetBulge pl pa bu)
   (and scu
 (vl-cmdf "_.ucs" "_restore" "scuinit")
 (vl-cmdf "_.ucs" "_delete" "scuinit")
   )
   (grtext)
   (redraw)
   (vla-EndUndoMark *acdoc*)
   (setq *error* m:err
  m:err	nil
   )
 )

 (if
   (and
     (setq pl (entsel))
     (setq pt (trans (osnap (cadr pl) "_nea") 1 0))
     (setq no (cdr (assoc 210 (entget (car pl)))))
     (setq pl (vlax-ename->vla-object (car pl)))
     (= (vla-get-ObjectName pl) "AcDbPolyline")
   )
    (progn
      (setq m:err *error*
     *error* err
      )
      (vla-StartUndoMark *acdoc*)
      (if (not
     (and (equal '(0 0 1)
		 (trans '(0 0 1) no 1 T)
		 1e-9
	  )
	  (equal 0.0 (vla-get-elevation pl) 1e-9)
     )
   )
 (and
   (vl-cmdf "_.ucs" "_save" "scuinit")
   (setq scu T)
   (vl-cmdf "_.ucs" "_object" (vlax-vla-object->ename pl))
 )
      )
      (setq pa	  (fix (vlax-curve-getParamAtPoint pl pt))
     p1	  (trans (vlax-curve-getPointatParam pl pa) 0 no)
     p2	  (trans (vlax-curve-getPointatParam pl (1+ pa)) 0 no)
     bu	  (vla-GetBulge pl pa)
     mid  (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0)) p1 p2)
     cor  (distance mid p1)
     loop T
      )
      (princ "\nSpécifiez la flèche ou [Centre/Direction]: ")
      (while (and (setq gr (grread T 12 0)) (/= (car gr) 3) loop)
 (cond
   ((= (car gr) 5)
   (redraw)
    (setq pm (trans (cadr gr) 1 no)
	  fl (distance mid pm)
    )
    (and (		 (setq fl (- fl))
    )
    (vla-setBulge
      pl
      pa
      ((lambda (a) (/ (sin a) (cos a)))
	(/ (- (angle p2 pm) (angle pm p1)) 2.0)
      )
    )
    (grdraw (trans mid no 1) (trans (vlax-curve-getPointAtParam pl (+ pa 0.5)) 0 1) -1 1)
    (grtext -1 (strcat "Flèche = " (rtos fl)))
   )
   ((member (cadr gr) '(13 32))
    (cond
      ((and str (numberp (read str)))
	(vla-setBulge pl pa (/ (read str) cor))
	(setq loop nil)
      )
      ((and str (member (strcase str) '("C" "D")))
	(setq loop nil)
	(cond
	  ((= (strcase str) "C")
	   (while
	     (not (and
		    (setq
		      ce (trans	(getpoint "\nSpécifiez le centre: ")
				1
				no
			 )
		    )
		    (equal (distance ce p1) (distance ce p2) 1e-9)
		  )
	     )
	   )
	   (vla-SetBulge
	     pl
	     pa
	     (/	(- (distance ce p1) (distance ce mid))
		(if (			  (distance p1 mid)
		  (- (distance p1 mid))
		)
	     )
	   )
	  )
	  ((= (strcase str) "D")
	   (while (not (setq di (getpoint (trans p1 no 1)
					   "\nSpécifiez la direction: "
				 )
		       )
		  )
	   )
	   ((lambda (a)
	      (vla-SetBulge pl pa (/ (sin a) (cos a)))
	    )
	     (/ (- (angle p1 p2) (angle p1 (trans di 1 no))) 2.0)
	   )
	  )
	)
      )
      (T
	(princ
	  "\nNécessite un nombre, une option valide ou une saisie au pointeur.
	 \nSpécifiez la flèche ou [Centre/Direction]: "
	)
	(setq str "")
      )
    )
   )
   (T
    (if	(= (cadr gr) 8)
      (or
	(and str
	     (/= str "")
	     (setq str (substr str 1 (1- (strlen str))))
	     (princ (chr 8))
	     (princ (chr 32))
	)
	(setq str nil)
      )
      (or
	(and str (setq str (strcat str (chr (cadr gr)))))
	(setq str (chr (cadr gr)))
      )
    )
    (and str (princ (chr (cadr gr))))
   )
 )
      )
      (and scu
    (vl-cmdf "_.ucs" "_restore" "scuinit")
    (vl-cmdf "_.ucs" "_delete" "scuinit")
      )
   (grtext)
   (redraw)
      (vla-EndUndoMark *acdoc*)
      (setq *error* m:err
     m:err nil
      )
    )
 )
 (princ)
)

;; RECT
;; ;; Transforme un arc de polyligne en segment rectiligne

(defun c:rect (/ pl pt pa)
 (vl-load-com)
 (or *acdoc*
     (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
 )
 (if
   (and
     (setq pl (entsel))
     (setq pt (trans (cadr pl) 1 0))
     (setq pl (vlax-ename->vla-object (car pl)))
     (= (vla-get-ObjectName pl) "AcDbPolyline")
   )
    (progn
      (setq pa	(fix (vlax-curve-getParamAtPoint
	       pl
	       (vlax-curve-getClosestPointTo pl pt)
	     )
	)
      )
      (vla-StartUndoMark *acdoc*)
      (vla-setBulge pl pa 0.0)
      (vla-EndUndoMark *acdoc*)
    )
 )
 (princ)
)

[Edité le 13/12/2007 par (gile)]

 

[Edité le 14/12/2007 par (gile)]

Gilles Chanteau - gileCAD - GitHub
Développements sur mesure pour AutoCAD

Lien vers le commentaire
Partager sur d’autres sites
Matt666 Newbie

Matt666

Posté(e)
Posté(e)

Raaah la la mais ca a l'air dément !!!!

 

Un jour, je pourrais lire du vlisp et en insérer des mes codes.... Mais c'est pas prêt d'arriver... Snifffffff. La version V8 de bricsCAD doit lire le vlisp. Mais elle est encore pleine de bug...

Enfin bon un jour peut-être !

 

Je suppose que ta routine est impossible/trop longue à faire en autolisp...

 

Bravo, en tout cas !!

 

A bientot.

Matt.

"Chacun compte pour un, et nul ne compte pour plus d'un."

Lien vers le commentaire
Partager sur d’autres sites
ElpanovEvgeniy Newbie

ElpanovEvgeniy

Posté(e)
Posté(e)

Le salut gile! :)

Fais attention à mon vieux programme.

Dans elle l'autre calcul de la courbure...

http://www.theswamp.org/index.php?topic=8878.msg132615#msg132615

(defun C:LW_ARC (/ LW i P1 P2 P3)

               ;**************** lw_arc.lsp *************************************
               ;   Substitution of a linear segment in a polyline
               ;   The arc segment.
               ;   Writer Evgeniy Elpanov.
               ;   Last edit 04.06.06
(vl-load-com)
(or doc (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
(if (and (setq lw (entsel "\n Select the necessary segment in a polyline. "))
         (= (cdr (assoc 0 (entget (car lw)))) "LWPOLYLINE")
    ) ;_  and
 (progn (setq i  (fix (vlax-curve-getParamAtPoint (car lw) ;_  car
                                                  (vlax-curve-getClosestPointTo (car lw) (cadr lw))
                      ) ;_  vlax-curve-getParamAtPoint
                 ) ;_  fix
              p1 (vlax-curve-getPointAtParam (car lw) i)
              p3 (vlax-curve-getPointAtParam (car lw) (1+ i))
              lw (vlax-ename->vla-object (car lw))
        ) ;_  setq
        (princ "\n Set visually a curvature of a segment. ")
        (vla-StartUndoMark doc)
        (while (and (setq p2 (grread 5)) (= (car p2) 5))
         (vla-SetBulge lw
                       i
                       ((lambda (a) (/ (sin a) (cos a)))
                        (/ (- (angle p1 (cadr p2)) (angle (cadr p2) p3)) -2.)
                       )
         ) ;_  vla-SetBulge
        ) ;_  while
        (vla-EndUndoMark doc)
 ) ;_  progn
 (princ "\n It is selected nothing or plant not a polyline. ")
) ;_  if
) ;_  defun

Evgeniy

Lien vers le commentaire
Partager sur d’autres sites
ElpanovEvgeniy Newbie

ElpanovEvgeniy

Posté(e)
Posté(e)
Very nice ! Très joli !

 

J'ai juste mis quelques options en plus. Et j'utilise aussi l'autre mode de calcul de la courbue (option "D")

 

 

Je voulais montrer seulement un autre moyen de l'instruction du point - lui plus confortablement...

Mon programme précédent, comme tienne, utilisait l'instruction de l'angle.

http://www.theswamp.org/index.php?topic=8878.msg114384#msg114384

(defun C:LW_ARC (/ A1 ENT GR I LST LW PAR PT)
               ;**************** lW_arc.lsp *************************************
               ;   Substitution of a linear segment in a polyline
               ;   The arc segment.
               ;   Writer Evgeniy Elpanov.
(vl-load-com)
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(setq lw (entsel "\n Select the necessary segment in a polyline. "))
(if (and lw (= (cdr (assoc 0 (entget (car lw)))) "LWPOLYLINE"))
 (progn (setq par (vlax-curve-getParamAtPoint (car lw)
                                              (vlax-curve-getClosestPointTo (car lw) (cadr lw))
                  ) ;_  vlax-curve-getParamAtPoint
              a1  (angle (vlax-curve-getPointAtParam (car lw) (fix par))
                         (vlax-curve-getPointAtParam (car lw) (1+ (fix par)))
                  ) ;_  angle
        ) ;_  setq
        (princ "\n Set visually a curvature of a segment. ")
        (while (and (setq gr (grread 5)) (= (car gr) 5))
         (setq i   0
               lst nil
               ent (entget (car lw))
         ) ;_  setq
         (while (or (/= (caar ent) 42)
                    (if (< i (fix par))
                     (setq i (1+ i))
                    ) ;_  if
                ) ;_  or
          (setq lst (cons (car ent) lst)
                ent (cdr ent)
          ) ;_  setq
         ) ;_  while
         (redraw)
         (grdraw (setq pt (vlax-curve-getPointAtParam (car lw) (fix par))
                 ) ;_  setq
                 (cadr gr)
                 6
                 1
         ) ;_  grdraw
         (entmod (append (reverse (cons (cons 42
                                              (/ (sin (/ (- a1 (angle pt (cadr gr))) 2.))
                                                 (cos (/ (- a1 (angle pt (cadr gr))) 2.))
                                              ) ;_  /
                                        ) ;_  cons
                                        lst
                                  ) ;_  cons
                         ) ;_  reverse
                         (cdr ent)
                 ) ;_  append
         ) ;_  entmod
         (entupd (car lw))
        ) ;_  while
 ) ;_  progn
 (princ "\n It is selected nothing or plant not a polyline. ")
) ;_  if
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(redraw)
(princ)
)

Evgeniy

Lien vers le commentaire
Partager sur d’autres sites

Créer un compte ou se connecter pour commenter

Vous devez être membre afin de pouvoir déposer un commentaire

Créer un compte

Créez un compte sur notre communauté. C’est facile !

Créer un nouveau compte

Se connecter

Vous avez déjà un compte ? Connectez-vous ici.

Connectez-vous maintenant
 Partager
Aller sur la liste des sujets
×
×
  • Créer...

Information importante

Nous avons placé des cookies sur votre appareil pour aider à améliorer ce site. Vous pouvez choisir d’ajuster vos paramètres de cookie, sinon nous supposerons que vous êtes d’accord pour continuer. Politique de confidentialité