Cotation de polylignes

[DenisHen]

Bonsoir à tous...

 

Voilà, je créé ce sujet que j'ai à peine commencé à la fin de "aide sur un progs" qui n'avait pas grand chose à voir avec le mien... Je m'en excuse... Quand je suis lancé dans un problème, j'oublie souvent celui des autres... Ma concentration est limité... Je vous présente toutes mes "confuses"...

 

Bon, ceci étant fait, dans le cadre d'un gros lotissement (avec une cinquantaine de lots), j'ai fais des "petites" routines pour nous aider à établir ce lotissement (tout le monde sais ce que c'est ?). Toutes créent un calque et lance une commande ou une routine, mais deux reste à développer, et je vais devoir m'y mettre tout le week-end... (Pfffff....) J'écouterais un petit Floyd pour faire passer la pillule ;)

 

Je vais essayé de faire simple... Mais vous verrez comme moi que ce n'est pas facile...

 

Prenons l'exemple pour le lot 4 :

 

Etape 1 : déclaration du lot courant par une routine existante ( avec (vlax-ldata-put... Merci CadXP ;) )

 

Etape 2 : il faut une polyligne pour dessiner le contour du lot :

- création du calque "Lot 4 (contour) en rouge (par routine existante)

- lancement de la commande _.pline

 

Etape 3 : il faut écrire le numéro du lot à l'intérieur...

- création du calque "Lot 4 (numéro) en blanc (routine)

- lancement d'une routine existante : on clique un point et elle écrit le texte "Lot 4" automatiquement

 

Etape 4 : il faut écrire la superficie du lot...

- création du calque "Lot 4 (superficie) en jaune (routine)

- lancement d'une routine : on clique la polyligne du contour puis un point et elle écrit la superficie.

 

Etape 5 : il faut coter la polyligne :

- création du calque "Lot 4 (cotation) en jaune (routine)

- c'est en cours... Mais pour l'instant, je fais des cotations linéaires de chaque sommet de toutes les polylignes ! ! Une routine est en cours... Mais je cale...

 

Etape 6 : il faut teinte le périmètre du lot :

- création du calque "Lot 4 (trame) en ....... (routine en cours)

- Je le fait avec une Multiligne... Mais je n'arrive pas à en créer depuis Lisp (depuis VBA nom plus d'ailleurs ;) )

 

Etape 7 : il faut identifier les coordonnées de chaque sommet du lot (pour le document d'arpentage et l'implantation) :

- création du calque "Lot 4 (coordonnées) en rouge (routine)

- Je le fait avec sommet par sommet grace à une routine récupéré sur le net de Serge MILLES (http://serge.milles.club.fr/index.html)

 

Voilà, c'est tout l'historique du dessin d'un lotissement... Sans compter les Pb d'urba et tout et tout.....

 

Merci pour vos éventuelles réponses... Tout est bienvenue, même des bout de routine ou des trucs pas finis ! !

 

Merci aussi à CadXP, sans quoi, rien n'aurait pu exister...

 

Si non, bon week-end à tous...

 

Denis... Qui a du pain sur la planche ( <- clin d'oeil au décapode, qui me lira peut-être)

[didier]

coucou,

 

celà a l'air prometteur,

 

une première chose qui me plaît,

plusieurs "petites" routines remplacent avantageusement une usine à gaz,

 

ensuite vouloir "rendre intelligent" un dessin n'est pas pour me déplaire.

 

il y a tant de gens qui se contentent de "faire du papier" avec leur fichier,

ils se contentent d'un beau tracé, c'est navrant,

il y a une telle valeur ajoutée dans un fichier bien agencé que 95 %

des "dessinateurs" ignorent.

 

ce qui n'a pas l'air d'être le cas de DenisH, et je l'en félicite.

 

que tous les AutoCadiens d'opérette soient atomisés sur l'autel du traceur.

 

non mais ça vas pas didier,

comment est ce que tu parles aux gens ?

ils t'ont rien fait,

 

ahahah, j'en rit de me voir si vieux sur mon clavier,

 

je blague, vous l'aviez compris sans doute, mais aujourd'hui il est de bon ton de le préciser,

(les pisse froids sont la majorité)

 

amicalement

longue vie informatique à ceux qui ne baissent pas les bras

[Tramber]

J'écouterais un petit Floyd pour faire passer la pillule ;)

Ca me prends aussi assez souvent le WE.

 

- lancement de la commande _.pline

2 pistes sympas si tu n'as pas déjà fait :

 

(setq p (getpoint))
(command "_.pline" p (while p (command (setq p (getpoint p)))))

célèbre code de l'illustre collègue juste au dessus de moi.

 

ou a lire aussi, on y parle de CMDACTIVE.

 

Pour le reste, y a toujours les solutions, essaie et dis-nous si tu t'amuses bien !

[DenisHen]

WAOW ! ! Tramber, pour une fois (de plus...) Je suis sur le Q ! !

 

Ca fait longtemp que je cherchais un truc comme :

(defun c:mapoly (/)
 (setvar "CMDECHO" 1)
 (setq ETL (entlast))
 (command "_.pline"
          (while (not (zerop (getvar "cmdactive")))
            (command pause)
          ) ;_ Fin de while
 ) ;_ Fin de command
 (if (/= (cdr (assoc 5 (entget (entlast)))) (cdr (assoc 5 (entget ETL))))
   (command "_.change" (entlast) "" "_properties" "_color" 3 "")
 ) ;_ Fin de if
 (princ)
) ;_ Fin de defun

 

Avec ça, je vais peut-être controler mes épaisseurs de mur... Mais aussi, pour les lotissement, faire, en un coup, plusieurs étapes qui suivent la construction de la première polyligne (contour)...

 

Un million de mercis à CadXP ! ! (je ne dis plus à qui, CadXP est un tout).

 

Tiens, je suis en train de relire avant de publier... J'ai encore trouvé une autre utilisation à cette routine... Waow... Je vais faire péter "Live at Pompeï" ! ! ! (tiens, je vais chercher le CD...)

 

Merci encore,

 

Denis...

[Patrick_35]

Salut

Didier a raison. Mieux vaux plusieurs routines qu'une grosse usine à gaz

Sinon, pour tes surfaces, tu as les lisps rea et rea-att dans la liste que j'ai mise à disposition

 

@+

[DenisHen]

WAOW ! ! rea et rea-att ! ! ! J'y cours ! !

 

Et merci pour m'avoir lancé les truc sur le (vlax-ldata-get et put ...) Tu peut pas savoir à quel point je l'utilise ! !

 

Lier une variable à un dessin ! ! C'est extraordinaire (pour moi) ! ! Et qu'es-ce que ça sera quand je maitriserais les listes ! !

 

Mais il me manque 2 cours, et j'en appel à votre secours ! !

 

Il faut que j'apprenne à controler les "listes" et les "saisie" (ssget.....)

 

Je vous en supplie ! ! Je cherche, je lis, je fais tous ce qui est en mon pauvre pouvoir... Mais je n'y arrive pas ! ! J'ai les idées, j'ai le "fonds" et la "forme" mais pas le langage... Je connais un peu le VBA, mais je sais que la puissance du LiSP est beaucoup plus grande avec AutoCAD ! ! Et en plus, la force est avec lui... ;)

 

Il faut que je termine mes LiSP avant lundi ! ! Waow ! ! Je sais que je n'y arriverais pas, Car je veux les faires moi-même, mais je ne permet pas qu'un autre me les servent, Merci à tous...

 

Je bosse... ( pour une fois ! ! ;) )

[(gile)]

Salut,

 

Pour l'aire et le périmètre, si tu veux utiliser des champs dynamiques, vois ce sujet.

[DenisHen]

Merci à tous....

 

J'ai plein de boulo grace à vous ! :casstet:

 

Mais je pense progresser avec tous çà :)

 

Il ne me reste plus, enfin presque, qu'à coter ma Polyligne...

 

J'ai réccupérer cette routine de Dominique Vaquant que j'ai retouché pour mes besoins (le or avec POLYLIGNE et LWPOLYLIGNE ) Mais c'ést loin d'être fini... Une fois les coordonnées récupérées, je pourrais coter ses segments...

 

(defun c:sompoly ()

 (setq poly (car (entsel "\nSelectionnez la polyligne: ")))
 (princ (strcat "\nEntité sélectionnée : une " (cdr (assoc 0 (entget poly)))))
 (if (or
       (= (cdr (assoc 0 (entget poly))) "POLYLINE")
       (= (cdr (assoc 0 (entget poly))) "LWPOLYLINE")
     ) ;_ Fin de or
   (progn
    
     (princ ent)
     (while (/= "SEQEND" (cdr (assoc 0 (entget ent))))
       (setq som (cdr (assoc 10 (entget ent))))
       (setq som_x (rtos (car som) 2 (getvar "luprec")))
       (setq som_y (rtos (cadr som) 2 (getvar "luprec")))
       (setq som_z (rtos (caddr som) 2 (getvar "luprec")))

       (setq ent (entnext ent))

     ) ;_ Fin de while
   ) ;_ Fin de progn
   (princ "\nMaivaise pioche")
 ) ;_ Fin de if
 (princ)
)

 

Mais elle ne fonctionne pas :

erreur: type d'argument incorrect: lentityp nil

 

à mon avis, il est trop vieux (1990) et ne comprend pas les LWPolylognes..., je pense donc que c'est dans

 (setq ent (entnext poly))

qu'il y a un problème...

 

Bon, c'est dimanche et je doute qu'il y ai foule sur le site...

 

Je vais donc faire ma promenade familliale le long du Canal de Bourgogne...

 

Bonne fin de W-E à tous,

 

Denis...

[(gile)]

Salut,

 

Les polylignes "anciennes" et les polylignes "optimisées" n'ont pas leurs sommets stockées de la même manière. Les premières, dans des sous entités accessibles avec (entnext ...), les secondes dans les gorupes DXF 10 de la liste DXF de l'entité.

 

Pour les sommets d'une polyligne optimisée revois cet ancien sujet que tu avais réveilléici.

[zebulon_]

Pour completer un peu sur les polylignes, voici 2 fonctions bien intéressantes quand on se frotte à des polylignes avec des parties courbes.

 

(defun getPolySegs (ent / entl p1 pt bulge seg ptlst)
 (cond (ent
        (setq entl (entget ent))
        ;; save start point if polyline is closed
        (if (= (logand (cdr (assoc 70 entl)) 1) 1)
          (setq p1 (cdr (assoc 10 entl)))
        )
        ;; run thru entity list to collect list of segments
        (while (setq entl (member (assoc 10 entl) entl))
          ;; if segment then add to list
          (if (and pt bulge)
            (setq seg (list pt bulge))
          )
          ;; save next point and bulge
          (setq pt    (cdr (assoc 10 entl))
                bulge (cdr (assoc 42 entl))
          )
          ;; if segment is build then add last point to segment
          ;; and add segment to list
          (if seg
            (setq seg (append seg (list pt))
                  ptlst (cons seg ptlst))
          )
          ;; reduce list and clear temporary segment
          (setq entl  (cdr entl)
                seg   nil
          )
        )
       )
 )
 ;; if polyline is closed then add closing segment to list
 (if p1 (setq ptlst (cons (list pt bulge p1) ptlst)))
 ;; reverse and return list of segments
 (reverse ptlst)
)


(defun getArcInfo (segment / a p1 bulge p2 c p3 p4 p r s result)
 ;; assigner variables avec les valeurs de l'argument
 (mapcar 'set '(p1 bulge p2) segment)
 (if (not (zerop bulge))
   (progn
     ;; trouver la corde
     (setq c (distance p1 p2))
     ;; trouver la flèche
     (setq s (* (/ c 2.0) (abs bulge)))
     ;; trouver le rayon par Pythagore
     (setq r (/ (+ (expt s 2.0) (expt (/ c 2.0) 2.0)) (* 2.0 s)))
     ;; distance au centre
     (setq a (- r s))
     ;; coordonnées du milieu de p1 et P2
     (setq P4 (polar P1 (angle P1 P2) (/ c 2.0)))
     ;; coordonnées du centre
     (setq p
       (if (>= bulge 0)
         (polar p4 (+ (angle p1 p2) (/ pi 2.0)) a)
         (polar p4 (- (angle p1 p2) (/ pi 2.0)) a)
       )  
     )
     ;; coordonnées de P3
     (setq p3
       (if (>= bulge 0)
         (polar p4 (- (angle p1 p2) (/ pi 2.0)) s)
         (polar p4 (+ (angle p1 p2) (/ pi 2.0)) s)
       )  
     )
     (setq result (list p r))
   )
   (setq result nil)
 )
 result
)

 

 

donc, un

(setq e (getpolysegs (car (entsel))))

te donne une liste des segments du polyligne sous la forme

(

(premier point segment0) bulge0 (deuxième point segment0)

(premier point segment1) bulge1 (deuxième point segment1)

...

)

 

Comme le "bulge" (courbure ?) est quelque chose de concis mais difficilement exploitable, il est intéressant d'avoir quelque chose qui transforme le "bulge" en un point de centre de cercle et une valeur de rayon.

Ce qui est réalisé par la fonction :

(getarcinfo (nth 1 e))

qui renvoie soit nil, si le 2ème segment est une droite, soit le centre est le rayon dans le cas contraire.

 

Tout ceci est très bien expliqué ici Merci à Stig Madsen

 

Amicalement

 

Zebulon_

 

[Edité le 16/10/2006 par zebulon_]

[(gile)]

Comme le "bulge" (courbure ?) est quelque chose de concis mais difficilement exploitable

 

Pour info, la valeur du bulge correspond à la tangente du quart de l'angle de l'arc, un petit dessin ici

 

[pierrevigneux]

 defun getPolySegs 

J,ai essayé la fonction et ça ne fonctionne pas, ce serait très intéressant de pouvour la faire fonctionner, pour la version 2004

Quelqu'un pourrais m'aider, je suis nul dans le lisp!

Merci!

[zebulon_]

Bonjour,

 

elle fonctionne pour la version 2004. Que veux-tu faire ou obtenir exactement ?

 

Amicalement

Vincent

 

[pierrevigneux]

Mais elle fonctionne pour quelle version?

Chez moi elle n fonctionne pas.

Ce que je trouve d'intéressant, ce sont les informations sur la polygne.

De plus j'aimerais pouvoir les côter automatiquement sur mon dessin, avrec leurs longueurs depuis le début de la polyligne.

 

 

[Edité le 22/1/2010 par pierrevigneux]

[bonuscad]

Bonsoir,

 

Pas exactement compris, mais j'ai déjà un bout de code, à creuser peut être...

 

(vl-load-com)
(defun c:Dim_PolyArc ( / js ename obj pr pt_sel seg_bulge deriv alpha pt_dim)
(princ "\nSélectionner une polyligne.")
(while (null (setq js (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
	(princ "\nCe n'est pas une LWPolyLine!")
)
(setq
	ename (ssname js 0)
	obj (vlax-ename->vla-object ename)
	pr -0.5
)
(repeat (fix (vlax-curve-getEndParam obj))
	(setq
		pt_sel (vlax-curve-GetPointAtParam obj (setq pr (1+ pr)))
		seg_bulge (vla-GetBulge obj (- pr 0.5))
		deriv (vlax-curve-getFirstDeriv obj pr)
		alpha (- (atan (cadr deriv) (car deriv)) (* pi 0.5))
		pt_dim (polar pt_sel alpha (* 2.0 (getvar "DIMTXT")))
	)
	(if (not (zerop seg_bulge))
		(command "_.dimarc" (trans pt_sel 0 1) "_none" (trans pt_dim 0 1))
	)
)
(prin1)
)

[pierrevigneux]

Bonsoir Bonus CAD

Voila reponse de la commande ?

Command: DIM_POLYARC

 

Sélectionner une polyligne.

Select objects:

_.dimarc Unknown command "DIMARC". Press F1 for help.

 

Command:

Command: _none Unknown command "NONE". Press F1 for help.

 

Command:

Command: _.dimarc Unknown command "DIMARC". Press F1 for help.

 

Command:

Command: _none Unknown command "NONE". Press F1 for help.

Command: DIM_POLYARC

 

Sélectionner une polyligne.

Select objects:

_.dimarc Unknown command "DIMARC". Press F1 for help.

 

Command:

Command: _none Unknown command "NONE". Press F1 for help.

 

Command:

Command: _.dimarc Unknown command "DIMARC". Press F1 for help.

 

Command:

Command: _none Unknown command "NONE". Press F1 for help.

 

[bonuscad]

Unknown command "DIMARC". Press F1 for help.

 

Tu utilises simplement une version d'AutoCad antérieure à l'apparition de DIMARC. (génération 2000)

 

Un substitut pour ces versions, mais les côtes ne seront plus associatives... :(

 

Pas testé sur une version adéquate.

 

(vl-load-com)
(defun c:Dim_PolyArc ( / js ename obj pr pt_sel seg_bulge deriv alpha pt_dim dxf_ent l_arc)
(princ "\nSélectionner une polyligne.")
(while (null (setq js (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
	(princ "\nCe n'est pas une LWPolyLine!")
)
(setq
	ename (ssname js 0)
	obj (vlax-ename->vla-object ename)
	pr -0.5
)
(repeat (fix (vlax-curve-getEndParam obj))
	(setq
		pt_sel (vlax-curve-GetPointAtParam obj (setq pr (1+ pr)))
		seg_bulge (vla-GetBulge obj (- pr 0.5))
		deriv (vlax-curve-getFirstDeriv obj pr)
		alpha (- (atan (cadr deriv) (car deriv)) (* pi 0.5))
		pt_dim (polar pt_sel alpha (* 2.0 (getvar "DIMTXT")))
	)
	(if (not (zerop seg_bulge))
     (progn
       (command "_.dimangular" (trans pt_sel 0 1) "_none" (trans pt_dim 0 1))
       (setq
         dxf_ent (entget (entlast))
         rad (distance (cdr (assoc 13 dxf_ent)) (cdr (assoc 15 dxf_ent)))
         l_arc (* rad (cdr (assoc 42 dxf_ent)))
         dxf_ent
         (subst
           (cons 1 (strcat "U " (rtos l_arc 2 (getvar "DIMDEC"))))
           (assoc 1 dxf_ent)
           dxf_ent
         )
       )
       (entmod dxf_ent)
       (entupd (cdar dxf_ent))
     )
	)
)
(prin1)
)

[pierrevigneux]

Merci BonusCAD!

Ta commande est super, sauf qu'elle me cote seulement:

- les arcs et seulement l'angle de déflection de l'arc

- ce que je recherche, est coter la polyligne en longueur à partir de son début de plus, coter tous ses segments.

[bonuscad]

et seulement l'angle de déflection de l'arc

 

Alors là je ne comprends pas !? Même si c'est la commande DIMANGULAR qui est utilisée, je lui substitut une valeur texte qui est la longueur de l'arc, c'est pour cela qu'elle n'est plus associative.

 

coter tous ses segments.

 

Alors comme ceci ?:

 

(defun c:Dim_PolyArc ( / js ename obj pr pt_sel seg_bulge deriv alpha pt_dim dxf_ent l_arc)
 (princ "\nSélectionner une polyligne.")
 (while (null (setq js (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
   (princ "\nCe n'est pas une LWPolyLine!")
 )
 (command "_.undo" "_begin")
 (setq
   ename (ssname js 0)
   obj (vlax-ename->vla-object ename)
   pr -0.5
 )
 (repeat (fix (vlax-curve-getEndParam obj))
   (setq
     pt_sel (vlax-curve-GetPointAtParam obj (setq pr (1+ pr)))
     seg_bulge (vla-GetBulge obj (- pr 0.5))
     deriv (vlax-curve-getFirstDeriv obj pr)
     alpha (- (atan (cadr deriv) (car deriv)) (* pi 0.5))
     pt_dim (polar pt_sel alpha (* 2.0 (getvar "DIMTXT")))
   )
   (if (not (zerop seg_bulge))
     (progn
       (command "_.dimangular" (trans pt_sel 0 1) "_none" (trans pt_dim 0 1))
       (setq
         dxf_ent (entget (entlast))
         rad (distance (cdr (assoc 13 dxf_ent)) (cdr (assoc 15 dxf_ent)))
         l_arc (* rad (cdr (assoc 42 dxf_ent)))
         dxf_ent
         (subst
           (cons 1 (rtos l_arc 2 (getvar "DIMDEC")))
           (assoc 1 dxf_ent)
           dxf_ent
         )
       )
       (entmod dxf_ent)
       (entupd (cdar dxf_ent))
     )
     (command "_.dimaligned" "" (trans pt_sel 0 1) "_none" (trans pt_dim 0 1))
   )
 )
 (command "_.undo" "_end")
 (prin1)
)

 

Pour les versions récentes le même

(vl-load-com)
(defun c:Dim_PolyArc ( / js ename obj pr pt_sel seg_bulge deriv alpha pt_dim)
 (princ "\nSélectionner une polyligne.")
 (while (null (setq js (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))))
   (princ "\nCe n'est pas une LWPolyLine!")
 )
 (setq
   ename (ssname js 0)
   obj (vlax-ename->vla-object ename)
   pr -0.5
 )
 (command "_.undo" "_begin")
 (repeat (fix (vlax-curve-getEndParam obj))
   (setq
     pt_sel (vlax-curve-GetPointAtParam obj (setq pr (1+ pr)))
     seg_bulge (vla-GetBulge obj (- pr 0.5))
     deriv (vlax-curve-getFirstDeriv obj pr)
     alpha (- (atan (cadr deriv) (car deriv)) (* pi 0.5))
     pt_dim (polar pt_sel alpha (* 2.0 (getvar "DIMTXT")))
   )
   (if (not (zerop seg_bulge))
     (command "_.dimarc" (trans pt_sel 0 1) "_none" (trans pt_dim 0 1))
     (command "_.dimaligned" "" (trans pt_sel 0 1) "_none" (trans pt_dim 0 1))
   )
 )
 (command "_.undo" "_end")
 (prin1)
)

 

[Edité le 23/1/2010 par bonuscad]

[pierrevigneux]

Je te remerci beaucoup, je trouve ça très utile, mais je ne crois pas qu'on se comprennent.

Si tu veux je peux te faire parvenir mon dessin-exemple et t'expliquer ce que j'aimerais qu'elle me retourne la commande.

 

Merci de ta patience!

pierre.vigneux@gmail.com [Edité le 24/1/2010 par pierrevigneux]

 

[Edité le 24/1/2010 par pierrevigneux]

[chris_mtp]

Bonjour Pierre,

 

SI j'ai bien compris depuis le début ta demande, tu veux côter une polyligne.

Et bien recherche sur ce forum un lisp seglen de Gile ou de Patrick je sais plus il fait cela très bien.

 

John

[pierrevigneux]

Bonsoir John!

Bien sur la commande de Gile ou Patrick Seglen est parfaite elle retourne la longueur de tous le segments , de plus , j'aimerais les coter et annoter leur longueurs, tel une cote, mais exprimé en P.K

soit 0+630,532 ou 630,532 mètres du début de la polyligne.

 

[Edité le 24/1/2010 par pierrevigneux]

[bonuscad]

mais je ne crois pas qu'on se comprennent.

 

En effet !

Je pense avoir maintenant compris ce que tu désires faire.

 

A une période j'avais tenté un code pour faire un truc similaire (mais pas vraiment achevé).

Je te le livre tel quel, si ça peut être une base de départ !?

 

(defun c:dim_perimeter ( / ent name_lay js n v_sd1 v_sd2 v_se1 v_se2 vlaobj pt_org pt_end param_start param_end perim_obj js_grp pt1_org pt1_end xname newdict)
 (vl-load-com)
    (if (not (tblsearch "BLOCK" "DIM_PERIMETER"))
      (progn
  (entmake
    '((0 . "BLOCK") (8 . "0") (2 . "DIM_PERIMETER") (70 . 2) (4 . "") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (10 0.0 0.0 0.0))
  )
  (entmake
   '(
     (0 . "LWPOLYLINE")
     (100 . "AcDbEntity")
     (67 . 0)
     (410 . "Model")
     (8 . "0")
     (100 . "AcDbPolyline")
     (90 . 2)
     (70 . 1)
     (43 . 0.5)
     (38 . 0.0)
     (39 . 0.0)
     (10 -0.25 0.0)
     (40 . 0.5)
     (41 . 0.5)
     (42 . 1.0)
     (10 0.25 0.0)
     (40 . 0.5)
     (41 . 0.5)
     (42 . 1.0)
     (210 0.0 0.0 1.0)
   )
 )
 (entmake '((0 . "ENDBLK") (8 . "0") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2)))
      )
    )
 (while (not (setq ent (entsel "\nChoix d'une entité sur le calque à coter: "))))
 (setq name_lay (cdr (assoc 8 (entget (car ent)))))
 (setq js (ssget (append '((0 . "*POLYLINE,LINE,ARC,CIRCLE,ELLIPSE,SPLINE")(-4 . "")) (list (cons 8 name_lay)))) n 0)
 (cond
   (js
     (command "_.undo" "_group")
     (setq v_sd1 (getvar "dimsd1") v_sd2 (getvar "dimsd2") v_se1 (getvar "dimse1") v_se2 (getvar "dimse2"))
     (setvar "dimsd1" 1)(setvar "dimsd2" 1)
     (setvar "dimse1" 1)(setvar "dimse2" 1)
     (repeat (sslength js)
       (setq
         ent (ssname js n)
         vlaobj (vlax-ename->vla-object ent)
         pt_org (vlax-curve-getStartPoint vlaobj)
         pt_end (vlax-curve-getEndPoint vlaobj)
         param_start (vlax-curve-getStartParam vlaobj)
         param_end (vlax-curve-getEndParam vlaobj)
;         perim_obj (vlax-curve-getDistAtParam vlaobj (+ param_start param_end))
         perim_obj (vlax-curve-getDistAtParam vlaobj param_end)
       )
       (redraw ent 3)
       (command "_.dimaligned" pt_org pt_end "_text" (rtos perim_obj) pause)
       (redraw ent 4)
       (setq js_grp (list (entlast)))
       (command "_.offset" "_through" ent (getvar "lastpoint") "")
       (command "_.change" (entlast) "" "_property" "_layer" (getvar "clayer") "")
       (setq js_grp (cons (entlast) js_grp))
       (setq
         vlaobj (vlax-ename->vla-object (entlast))
         pt1_org (vlax-curve-getStartPoint vlaobj)
         pt1_end (vlax-curve-getEndPoint vlaobj)
       )
       (command "_.-insert" "DIM_PERIMETER" pt1_org (/ (getvar "dimtxt") 2.0) (/ (getvar "dimtxt") 2.0) "0.0")
       (setq js_grp (cons (entlast) js_grp))
       (command "_.-insert" "DIM_PERIMETER" pt1_end (/ (getvar "dimtxt") 2.0) (/ (getvar "dimtxt") 2.0) "0.0")
       (setq js_grp (cons (entlast) js_grp))
       (command "_.line" pt_org pt1_org "")
       (setq js_grp (cons (entlast) js_grp))
       (command "_.line" pt_end pt1_end "")
       (setq js_grp (cons (entlast) js_grp))
       (if (null (dictsearch (namedobjdict) "BONUSCAD_DIM-PERIMETER"))
         (setq xname (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary")))
               newdict (dictadd (namedobjdict) "BONUSCAD_DIM-PERIMETER" xname)
         )
         (setq newdict (cdar (dictsearch (namedobjdict) "BONUSCAD_DIM-PERIMETER")))
       )
       (setq xname
         (entmakex
           (append
             '(
               (0 . "GROUP")
               (100 . "AcDbGroup")
               (300 . "Cote perimetre")
               (70 . 0)
               (71 . 1)
             )
             (mapcar '(lambda (x) (cons 340 x)) js_grp)
           )
         )
       )
       (if (not (assoc 3 (dictsearch (namedobjdict) "BONUSCAD_DIM-PERIMETER")))
         (dictadd newdict "DIM-PERIMETER_1" xname)
         (dictadd newdict (strcat "DIM-PERIMETER_" (itoa (1+ (atoi (substr (cdr (assoc 3 (dictsearch (namedobjdict) "BONUSCAD_DIM-PERIMETER"))) 8))))) xname)
       )
       (setq n (1+ n))
     )
     (setvar "dimsd1" v_sd1) (setvar "dimsd2" v_sd2)
     (setvar "dimse1" v_se1) (setvar "dimse2" v_se2)
     (command "_.undo" "_end")
   )
   (T (princ "\nPas d'objet à mesurer sur ce calque."))
 )
 (prin1)
)

[pierrevigneux]

Bonjour Bonuscad!

J'ai essayé ta commande, mais ce n'est pas exactement ce que je recherche.

 

J'aimerais puvoir coter les débuts et fin de sgments en cumulatif, en retrait de la polyligne exprimés en points kilométriques, si possible.

Si ça tintéresse je peux t'envoyer mon dessin exemple

 

Merci @+

 

Note:

Je reviens de vacances 2 semaines, voilà pourquoi je n'ai pas pris mes messages!

[bonuscad]

Un truc que j'ai dû publié sur le site sous le nom blk-at_measure

Je l'ai rapidement adapté.

 

(defun make_blk_measure ( / )
   (if (not (tblsearch "STYLE" "$BLK_MEAS"))
     (entmake '((0 . "STYLE")
     (5 . "40")
     (100 . "AcDbSymbolTableRecord")
     (100 . "AcDbTextStyleTableRecord")
     (2 . "$BLK_MEAS")
     (70 . 0)
     (40 . 0.0)
     (41 . 1.0)
     (50 . 0.0)
     (71 . 0)
     (42 . 0.1)
     (3 . "ARIAL.TTF")
     (4 . "")
    )
     )
   )
   (if (not (tblsearch "BLOCK" "BLK_MEASURE_CURVE"))
     (progn
  (entmake
   '((0 . "BLOCK") (8 . "0") (2 . "BLK_MEASURE_CURVE") (70 . 2) (4 . "") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (10 0.0 0.0 0.0))
 )
 (entmake
   (append
     '((0 . "LINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (100 . "AcDbLine"))
     (list (list 10 0.0 (/ (- (getvar "TEXTSIZE")) 100.0) 0.0))
     (list (list 11 0.0 (/ (getvar "TEXTSIZE") 100.0) 0.0))
     '((210 0.0 0.0 1.0))
   )
  )
  (entmake
   '(
 (0 . "ATTDEF")
 (100 . "AcDbEntity")
 (67 . 0)
 (410 . "Model")
 (8 . "0")
 (62 . 0)
 (6 . "ByBlock")
 (370 . -2)
 (100 . "AcDbText")
 (10 0.05 0.1 0.0)
 (40 . 1.0)
 (1 . "0.0")
 (50 . 1.570796326794896)
 (41 . 1.0)
 (51 . 0.0)
 (7 . "$BLK_MEAS")
 (71 . 0)
 (72 . 0)
 (11 0.0 0.1 0.0)
 (210 0.0 0.0 1.0)
 (100 . "AcDbAttributeDefinition")
 (3 . "measure")
 (2 . "VALUE_MEASURE")
 (70 . 0)
 (73 . 2)
 (74 . 2)
   )
 )
 (entmake '((0 . "ENDBLK") (8 . "0") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2)))
     )
   )
)
(defun z_dir (p1 p2 / )
 (trans
   '(0.0 1.0 0.0)
   (mapcar
     '(lambda (k)
       (/ k
         (sqrt
           (apply '+
             (mapcar
               '(lambda (x) (* x x))
               (mapcar '- p2 p1)
             )
           )
         )
       )
     )
     (mapcar '- p2 p1)
   )
   0
 )
)
(defun c:mesure_PK ( / js dxf_obj obj_vlax pt_start pt_end total_dist partial_dist ori_dist lst_pt increment_dist sv_luprec sv_dzin ang dxf_210 p_fix mantiss)
 (princ "\nSélectionner un objet curviligne à mesurer: ")
 (while
   (not
     (setq js
       (ssget "_+.:E:S"
         (list
           (cons 0 "*POLYLINE,LINE,ARC,CIRCLE,ELLIPSE,SPLINE")
           (cons 67 (if (eq (getvar "CVPORT") 2) 0 1))
           (cons 410 (if (eq (getvar "CVPORT") 2) "Model" (getvar "CTAB")))
           (cons -4 "            (cons -4 "&") (cons 70 112)
           (cons -4 "NOT>")
         )
       )
     )
   )
   (princ "\nCe n'est pas un objet curviligne valable pour cette fonction!")
 )
 (vl-load-com)
 (setq
   dxf_obj (entget (ssname js 0))
   obj_vlax (vlax-ename->vla-object (ssname js 0))
   pt_start (vlax-curve-getStartPoint obj_vlax)
   pt_end (vlax-curve-getEndPoint obj_vlax)
   total_dist (vlax-curve-getDistAtParam obj_vlax (vlax-curve-getEndParam obj_vlax))
   partial_dist 1000.0
 )
 (setq ori_dist (getreal "\nPK de départ 0+000 <0.0>: "))
 (if (not ori_dist) (setq ori_dist 0.0))
 (cond
   ((> total_dist partial_dist)
     (command "_.textsize" (while (not (zerop (getvar "cmdactive"))) (command pause)))
     (make_blk_measure)
     (setq
       lst_pt (list pt_start)
       increment_dist (- 1000.0 (atoi (substr (rtos ori_dist 2 3) (+ 2 (vl-string-search "." (rtos ori_dist 2 3))))))
       sv_luprec (getvar "LUPREC")
       sv_dzin (getvar "DIMZIN")
     )
     (setvar "CMDECHO" 1)
     (setvar "DIMZIN" 0)
     (command "_.luprec" 0)
     (while (< increment_dist total_dist)
       (setq
         lst_pt (cons (vlax-curve-getPointAtDist obj_vlax increment_dist) lst_pt)
         increment_dist (+ increment_dist partial_dist)
       )
     )
     (setq lst_pt (reverse (cons pt_end lst_pt)))
     (foreach n lst_pt
       (setq
         ang (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv obj_vlax (vlax-curve-getParamAtPoint obj_vlax n)))
         dxf_210 (z_dir n (polar n ang (* 0.1 partial_dist)))
         p_fix (atoi (rtos (/ (vlax-curve-getDistAtPoint obj_vlax n) 1000.0) 2 3))
         mantiss
         (+
           (-
             (vlax-curve-getDistAtPoint obj_vlax n)
             (* p_fix 1000.0)
           )
           (atoi (substr (rtos ori_dist 2 3) (+ 2 (vl-string-search "." (rtos ori_dist 2 3)))))
         )
       )
       (if (or (equal mantiss 1000.0 1E-3) (> mantiss 1000.0)) (setq p_fix (1+ p_fix) mantiss (- mantiss 1000)))
       (if (zerop (fix mantiss)) (setq mantiss "000") (setq mantiss (rtos mantiss 2 0)))
       (entmake
         (list
           (cons 0 "INSERT")
           (cons 100 "AcDbEntity")
           (assoc 67 dxf_obj)
           (assoc 410 dxf_obj)
           (cons 8 (getvar "CLAYER"))
           (cons 100 "AcDbBlockReference")
           (cons 66 1)
           (cons 2 "BLK_MEASURE_CURVE")
           (cons 10 (trans n 0 dxf_210))
           (cons 41 (* 0.1 partial_dist))
           (cons 42 (* 0.1 partial_dist))
           (cons 43 (* 0.1 partial_dist))
           (cons 50 ang)
           (cons 210 dxf_210)
         )
       )
       (entmake
         (list
           (cons 0 "ATTRIB")
           (cons 100 "AcDbEntity")
           (assoc 67 dxf_obj)
           (assoc 410 dxf_obj)
           (cons 8 (getvar "CLAYER"))
           (cons 100 "AcDbText")
           (cons 10
             (polar
               (polar (trans n 0 dxf_210) (+ (/ pi 2) ang) (* 0.1 partial_dist))
               ang
               (* 0.05 partial_dist)
             )
           )
           (cons 40 (getvar "TEXTSIZE"))
           (cons 1
             (strcat
               "PK "
               (itoa (+ p_fix (fix ori_dist)))
               "+"
               mantiss
             )
           )
           (cons 50 (+ (/ pi 2) ang))
           (cons 41 1.0)
           (cons 51 0.0)
           (cons 7 "$BLK_MEAS")
           (cons 71 0)
           (cons 72 0)
           (cons 11 (polar (trans n 0 dxf_210) (+ (/ pi 2) ang) (* 0.1 partial_dist)))
           (cons 210 dxf_210)
           (cons 100 "AcDbAttribute")
           (cons 2 "VALUE_MEASURE")
           (cons 70 0)
           (cons 73 2)
           (cons 74 2)
         )
       )
       (entmake (list (cons 0 "SEQEND") (cons 8 (getvar "CLAYER")) (cons 62 0) (cons 6 "ByBlock") (cons 370 -2)))
     )
     (setvar "LUPREC" sv_luprec)
     (setvar "DIMZIN" sv_dzin)
   )
   (T (princ "\nLa longueur est trop grande pour l'objet!"))
 )
 (prin1)
)

 

[Edité le 15/2/2010 par bonuscad]