Ajuster lignes de cotes.

[Bred]

Salut, suite à ce message.

Ci-dessous une routine permettant d'ajuster les lignes de cotes sur tout type d'objet (ligne, polyligne, spline, cercle ...)

L'ajustement se fait même si la ligne à ajuster n'est pas assez longue.

 

Taper adjc pour lancer la commande.

 

- J'ai mélangé du (entmake) avec du (vla-) ... mais là, j'ai pas trouvé ....

 

Edit1 : Correction du bug pour ajustement sur cercle ou arc.

Edit2 : Ajout test si coordonnées exite (gile).

Edit3 : Correction (suppression ligne de construction si pas de coordonnées).

Edit4 : Choix d'une cote comme base d'ajustement. .

 

; Ajustement lignes de cotes par Fred BONNAUD	-
; version 1.4					-
(defun c:ajc (/ ACDOC COORD1 COORD2 COT COTE ENT L1 L2 LIN N SEL VLA-COT VLA-LIN COORDT1 COORDT2 W)
 (vl-load-com)
 (setq AcDoc (getSpace))
 (prompt "Choix des cotes :")

 (while (not sel)  
 (setq sel (ssget '((0 . "DIMENSION")))))

 (while (not lin)
   (setq lin (car (entsel "\n Choix de la limite d'ajustement (ou cote à reproduire):")))) 

 (if lin
   (progn
     (if (equal (cdr (assoc 0 (entget lin))) "DIMENSION")
(progn
  (setq lin (vlax-vla-object->ename
	      (vla-AddLine AcDoc (vlax-3d-point (cdr (assoc 13 (entget lin)))) (vlax-3d-point (cdr (assoc 14 (entget lin))))))
	w "oui")
  )
(setq w nil)
)

     (repeat (setq n (sslength sel))
(setq cote (ssname sel (setq n (1- n)))
      ent (entget cote)
      vla-cot (vlax-ename->vla-object cote)
      vla-lin (vlax-ename->vla-object lin)	      
      l1 (vla-AddLine AcDoc (vlax-3d-point (cdr (assoc 14 ent))) (vlax-3d-point (cdr (assoc 10 ent))))
      l2 (vla-copy l1))

(vla-move l2 (vlax-3d-point (cdr (assoc 14 ent))) (vlax-3d-point (cdr (assoc 13 ent))))

(if (and
      (setq coord1 (vlax-invoke l1 'IntersectWith (vlax-ename->vla-object lin) acExtendBoth))
      (setq coord2 (vlax-invoke l2 'IntersectWith (vlax-ename->vla-object lin) acExtendBoth)))
  (progn
    (if (> (length coord1) 3)
      (progn
	(setq coordt1 (list (caddr (reverse coord1))(cadr (reverse coord1))(car (reverse coord1)))
	      coordt2 (list (car coord1)(cadr coord1)(caddr coord1)))
	(if (> (distance (cdr (assoc 14 ent)) coordt1)
	       (distance (cdr (assoc 14 ent)) coordt2))
	  (setq coord1 coordt2)
	  (setq coord1 coordt1))))

    (if (> (length coord2) 3)
      (progn
	(setq coordt1 (list (caddr (reverse coord2))(cadr (reverse coord2))(car (reverse coord2)))
	      coordt2 (list (car coord2)(cadr coord2)(caddr coord2)))
	(if (> (distance (cdr (assoc 14 ent)) coordt1)
	       (distance (cdr (assoc 14 ent)) coordt2))
	  (setq coord2 coordt2)
	  (setq coord2 coordt1))))	    

    (setq cot (entmod (subst (cons 13 coord1) (assoc 13 ent) ent)))
    (entmod (subst (cons 14 coord2) (assoc 14 ent) cot))
    )
  )
(vla-delete l1)
(vla-delete l2)
)
     )
   )
 (if w (vla-delete vla-lin))
 (princ)
)

;;;;;;;;;Getspace Retourne l'espace courant (Modèle ou Papier)		;
(defun getSpace ()
 (if (= (getvar "CVPORT") 1)
   (vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
   (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
   )
)

 

... j'attends vos remarques !!!

 

[Edité le 17/4/2007 par Bred]

[Bred]

Edition du code - Correction du bug d'ajustement sur cercle ou arc.

[(gile)]

Super :D

 

Juste un détail, faire un test si les intersections existent bien pour éviter un message d'erreur, du style :

 

(if (and (setq coord1 ...) (setq coord ...)) (progn ...))

[Bred]

merci (gile), j'en tiens compte (edit2).

 

Encore une petite correction : si pas de coordonnées, les ligne de construction restait. (edit3)

 

[Edité le 12/4/2007 par Bred]

[Bred]

Ajout d'un choix suplémentaire (Edit 4) :

Comme choix de référence d'alignement, il est possible de choisir une cote existante : les autre cotes seront ajuster selon un vecteur passant par les deux point d'accrochage de la cote selectionné en référence.

Ceci permettant par exemple de choisir une cote avec 2 points d'accroches bien aligné et d'alignés à l'identique toutes les cotes continus rattachés.

[Tramber]

Pas sympa le GETSPACE même si on comprend

 

 

 

[Bred]

Hop là désolé ! :red:

une erreur de copier/coller à l'édition

c'est corrigé.

[(gile)]

GETSPACE...

...il me semble savoir d'où ça vient.

 

En fait c'est un peu comme GETVAL, très pratique en phase de développement et de test mais dorénavent, j'essaie d'éviter quand je publie des routines, je l'oublie une fois sur deux.

 

J'essaye plutôt de faire, à lintérieur de la routine :

 

(setq space (if (= (getvar "CVPORT") 1)

(vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object)))

(vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))

)

)

[Bred]

GETSPACE...

...il me semble savoir d'où ça vient.

Ah bon ??? ;)

Je te promet que ce n'est presque pas fait exprès .... :P