Cadastre : Regrouper le nom des voies selon leur polyligne.

[Fraid]

Bonjour,

 

Un petit lisp qui sert à regrouper les textes des noms de voies sur les planches cadastrales téléchargeable Ici

 

Si c'est bien un truc qui m'agace, c'est bien cela, le nom des rues éclatés le long de son axe...

Il aurais pu mettre une x-data avec le nom entier, mais non...

 

Me suis donc pris la tête avec l'algorithme pour choisir les bon textes en sélectionnant la polyligne représentant l'axe.

Au début je pensais m'en tirer avec la rotation, mais il ne sont que rarement parallèle au segment.

Puis en mesurant la distance du texte au point perpendiculaire au segment grâce inters et polar, cela aurais du fonctionner, mais non, j'ai des textes pollueurs...

Me suis donc rabattu sur les distances des vertices au texte.

En plus, le texte final (le nom de la rue) est placé dans le presse papier de Windows et dans une xdata dans la polyligne.

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;RegrouptextCada V2.0 07/12/2018;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Tappez RGTC ou regrouptextcada pour lancer le lisp
;Regroupe les textes se trouvant le long d'une polyligne en un seul texte placé dans le presse papier et en xdata dans la polyligne.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;By Fraiddd and Cadxp Stars ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:regrouptextcada ( / sst_var *error* _StartUndo _EndUndo end_msg ;Fonctions internes
                        acdoc entpline IOI OoO textes n txt pttxt listetexte finaltexte pt1 O< ;Variables
                        sst_val listevoie expttxt ind longseg distpt1 distpt2 listseltext listetextetmp
                        )
(vl-load-com)
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;FONCTIONS INTERNES;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun sst_var (var val);Sauvegarde des variables Autocad modifiées
(cond((getvar var)
	(setq sst_val (cons (list 'setvar var (getvar var)) sst_val))
	(if val (setvar var val))
))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun *error* ( msg );Redéfinition de la fonction *error*
   (if acdoc (_EndUndo acdoc))
(mapcar 'eval sst_val)
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun _StartUndo ( doc ) (_EndUndo doc);Marqueur de retour
   (vla-StartUndoMark doc)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun _EndUndo ( doc )
   (if (= 8 (logand 8 (getvar 'UNDOCTL)))
     (vla-EndUndoMark doc)
   )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun end_msg nil (princ "\nOpération réussie.") (princ "\nLe texte suivant est placé dans le presse papier Windows") (princ (strcat "\n" finaltexte)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Test la validitité du plan de cadastre ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (memberwcmatch "*ZONCOM*" (listecalque acdoc)) 
(progn ;Si valide
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;CODE PRINCIPAL;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(_StartUndo acdoc);Debut marqueur de retour 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;si le SCU /= de général on le met
   (if (= (getvar "worlducs") 0)(progn (command "_.ucs" "")(setq O< 1)))
;Variables Autocad
(mapcar '(lambda (x) (sst_var (car x) (cdr x)))
	 '(("angdir" . 0)
	  ("osmode" . 0)
	  ("auprec" . 4)
	  ("luprec" . 4)
	  ("cmdecho" . 0)
	  ("menuecho" . 1)
     )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Suppression des textes supperposés (s'effectue qu'une seul fois dans le dessin grace au marqueur ldata)
(if (not (vlax-ldata-get "CADA" "DelSupText"))
	(progn
	(DelSuperposition (ssget "_x" (list (cons 0 "TEXT")(cons 8 "3ZONCOMMTEX")))) (vlax-ldata-put "CADA" "DelSupText" 1)
	)
)
;Isolation des calques concernés
(command "_clayer" "1ZONCOMM")
(isolay "*ZONCOM*" acdoc)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Sélection de la polyligne
(setq IOI 0 ;Drapeau qui évite l'erreur quand on clique dans le vide.
      OoO  0 ;Drapeau anti gogol
);Fin setq
(while  (= IOI 0) 
  (setq entpline  (entsel "\nSélectionnez une polyligne: "))
  (if entpline 
  (if (= (cdr (assoc 0 (entget (car entpline)))) "LWPOLYLINE") (setq IOI 1))
  (if (< OoO 222)
     (progn
        (princ "\nVeuillez Sélectionner une polyligne")
	    (setq OoO (1+ OoO))
	 )
	 (progn
	     (princ "\n!!!!! ALERTE !!!!! Votre chat est allongé sur votre clavier et/ou il dévore votre souris")
		 (exit)
	 )
  )
  )
)
(if (null (setq finaltexte (get-xdata "NOMV" entpline)));si la polyligne ne contient pas le nom de la voirie en xdata
(progn
(setq textes (ssget "_x" (list (cons 0 "TEXT")(cons 8 "3ZONCOMMTEX")));Sélection des textes dans le calque "3ZONCOMMTEX"
      listevoie '("AUTOROUTE" "Rue" "Boulevard" "Bd" "Avenue" "Av" "Route" "Ruelle" "Rte" "Route départementale" 
	              "R.d." "Route nationale" "R.n." "Voie" "Chemin" "Ch" "Ch." "Impasse" "Imp" "Imp." "Allée" 
				  "Passage" "Chaussée" "Quai" "C.R." "V.C." "C.E.")
)
(if textes (progn
    ;Pour chaque vertice de la polyligne
    (mapcar '(lambda (pt2)
	(setq n -1 ;Compteur pour ssname
	      listetextetmp nil
	)
	(if pt1 ;A la 1er passe, il ne se passe rien
	;pour chaque texte
	(progn
	(repeat (sslength textes)
	   (setq txt (entget (ssname textes (setq n (1+ n))));Extraction du texte dans la liste du jeu de sélection
	         ind (cdr (assoc 1 txt));Contenu du texte
			 pttxt (cdr (assoc 10 txt));Liste des coordonnées du point d'insertion du texte
			 longseg (distance pt1 pt2);Longueur du segment
			 distpt1 (distance pt1 pttxt);Distance du point 1 au texte
			 distpt2 (distance pt2 pttxt);Distance du point 2 au texte
	   );Fin setq
	    ;(if (= rottxt 0.0) (setq rottxt (* 2 pi)))
		(if (and (not (member (cdr (assoc 5 txt)) listseltext));On verifie que ce texte n'a pas été déjà selectionné
				 (< (- (+ distpt1 distpt2) longseg) 3);La somme des distances du point d'insertion du texte au 2 points d'un segment, moins la longueur du segment, doit etre inferieur à 3
				 (> (+ longseg 3) distpt1) ;la longueur du segment + 3 (3 pour prendre en charge les textes juste au dessus d'un vertices)
				 (> (+ longseg 3) distpt2);doit etre superieur au distances du point d'insertion du texte au 2 points d'un segment
				 					 
			)
			(setq listetextetmp (append listetextetmp (list(list distpt1 ind)));on ajoute a la liste temporaire le contenu du texte avec la distance au pt1 
			      listseltext (append listseltext (list(cdr (assoc 5 txt))));Permet de ne pas reselectionné un texte qui se trouve au dessus du vertice
			)
		 )
	);Fin repeat
	(if listetextetmp
	(if  (> (length listetextetmp) 1)
		(mapcar '(lambda (x) (setq listetexte (append  listetexte (list(cadr x))))) (trilistlist listetextetmp 0));on ajoute la liste temporaire triée par distpt1 a la liste de texte
		(setq listetexte (append  listetexte (list (cadr (car listetextetmp)))));on ajoute le texte a la liste de texte
	)
	)
	);Fin du progn
	);Fin du if pt1
    (setq pt1 pt2);pt2 devient pt1
	);Fin lambda
    (vertices (car entpline));Liste des vertices d'une polyligne
	);Fin mapcar
);Fin progn
);Fin if textes
);Fin progn
);Fin if
(command "_laythw" ;Dégel tout les calques
         "_clayer" "0" ;Calque 0 courant
)

(if listetexte (progn 
   (if (member (car (reverse listetexte)) listevoie) (setq listetexte (reverse listetexte)));Si un nom de voie figure en dernier, on inverse la liste
   (setq finaltexte (replace "  " " " (lst2str listetexte " ")));liste de str en str
   ;Placement du texte assemblé dans le presse papier. Peut planter selon la config de Windows.
   (SetClipBoardText finaltexte); SetClipBoardText Peut etre remplacé par dos_clipboard si doslib est installé.
   (put-xdata "NOMV" entpline finaltexte);ecriture du nom de la voirie en xdata au sein de la polyligne
      (end_msg);Message de fin
   )
   (progn
	   (if finaltexte (progn
		 (SetClipBoardText finaltexte)
		 (end_msg);Message de fin
	   )
	   (princ "\nAucun texte trouvé.")
	   )
	)
 )
(if O< (returnscu));Rétablissement du SCU si il a changé
(_EndUndo acdoc);Fin du marqueur de retour
(mapcar 'eval sst_val);Restauration des variables
(princ)
);Fin progn
   (princ "\nFichier invalide")
);Fin if 
);Fin defun c:regrouptextcada
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;FONCTIONS EXTERNES;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun memberwcmatch (str lst);Fonctionne comme member mais on peux utiliser *
(vl-member-if
'(lambda (x) (wcmatch x str))
lst
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun isolay (lay doc / listlay);Gèle tout les calques sauf ceux décrit en attribut lay
 (vlax-for listlay (vla-get-layers doc)
 (if (not (wcmatch (vla-get-Name listlay ) lay))
	(vla-put-Freeze listlay :vlax-true)
  )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;vertices (Gile)
;Renvois la liste des vertices (points) d'une polyligne
;Argument ent obtenu par exemple avec (car (entsel "\nSélectionnez une polyligne :"))
(defun vertices (ent / i lst)
 (vl-load-com)
 (setq i (1+ (fix (vlax-curve-getEndParam ent))))
 (repeat i
   (setq lst (cons (vlax-curve-getPointAtParam ent (setq i (1- i))) lst))
 )
 lst
)
;; lst2str
;; Concatène une liste et un séparateur en une chaine
;;
;; Arguments
;; lst : la liste à transformer en chaine
;; sep : le séparateur
(defun lst2str (lst sep)
 (if (cdr lst)
   (strcat (vl-princ-to-string (car lst)) sep (lst2str (cdr lst) sep))
   (vl-princ-to-string (car lst))
 )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun listecalque ( doc / lay lst);Renvois la liste des calques
  (vlax-for lay (vla-get-layers doc)
       (setq lst (cons (vla-get-name lay) lst))
     )
 lst
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun SetClipBoardText ( text / htmlfile );Place un texte dans le presse papier Windows.(TheSwamp)
(vlax-invoke
	(vlax-get
		(vlax-get
			(setq htmlfile (vlax-create-object "htmlfile"))
		   'ParentWindow
		)
	   'ClipBoardData
	)
   'SetData
	"Text"
	text
)
   (vlax-release-object htmlfile)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ReturnSCU nil ;Rétablis le SCU précédant
 (command "_ucs" "p"
          "repere" ""
 )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Replace (oldText newText text / i)
 (while (setq i (vl-string-search oldText text))
	(setq text
		(vl-string-subst
			 newText
			 oldText
			 text
			 i
		)
	)
 )
text 
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Place une xdata dans un objet sous la forme d'un texte
;Arguments: appli : Nom de l'application, crée si elle n'existe pas.
;           sel : sélection d'objet obtenue par exemple avec (entsel "\nSélectionnez une polyligne :").
;           txt : Texte
(defun put-xdata (appli sel txt)
(regapp appli)
(entmod (append (entget (car sel)) (list ( list -3 (cons appli (list (cons 1000  txt)))))))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Lire une xdata dans un objet
;Arguments: appli : Nom de l'application.
;           sel : sélection d'objet obtenue par exemple avec (entsel "\nSélectionnez une polyligne :").
(defun get-xdata (appli sel)
(cdar (cdadr (assoc -3 (entget (car sel) (list appli)))))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ListeCDR (listedListes  / k°)
 (setq K° '(""))
 (mapcar '(lambda (x) (setq K° (cons (cdr x) K°))) listedListes)
 K°
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun trilistlist (listlist i)
     (vl-sort listlist '(lambda (list1 list2)(< (nth i list1) (nth i list2))))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Efface les objets superposés (vdh bruno)
(defun DelSuperposition ( ss /  i e l m flag DefGeo)
 (defun DefGeo (l / m)
   (cons (car l)
         (cons (cadr l) (cdr (member (assoc 100 (setq m (cdr (member '(100 . "AcDbEntity") l)))) m)))
   )
 )
 (and 
      (repeat (setq i (sslength ss)) (setq l (cons (DefGeo (entget (ssname ss (setq i (1- i))))) l)))
      (while l
        (setq e (car l) m (cdr l) l nil)
        (while m
          (or (and (equal (cdr e) (cdar m) 1.e-8) (setq flag T) (entdel (cdr (assoc -1 (car m))))) (setq l (cons (car m) l)))
          (setq m (cdr m))
        )
        (if flag
          (entdel (cdr (assoc -1 e)))
        )
        (setq flag nil)
      )
 )
 (princ)
)
;Raccourci
(defun c:rgtc nil (c:regrouptextcada))

 

Par contre, je ne peux que le tester sur Autocad 2011 et Windows 7.

Quelqu’un pourrais t'il tester sur 8 et 10? et un Autocad 2018?

Merci :D

Modifié le 7 décembre 2018 par Fraid

[COME]

Salut,

 

cela fonctionne chez moi

 

Autocad Map 2013 SP2.1

Windows 7 professionnel

 

Et merci car je pourrais bien en avoir besoin dans un futur proche.

 

Bonne journée,

[hey_bapt]

Salut,

 

Autocad MAP 2017 et windows 7 ici, et ça ne marche pas.

J'y connais rien en LISP mais voilà ce que ça me fait au lancement de la commande :

 

- Seuls restent les textes de voirie et les polylignes du calque "1ZONCOMM"

- On m'invite à sélectionner une polyligne

- Lorsque j'en sélectionne une, tout se dégèle mais le texte associé à la polyligne sélectionnée ne bouge pas d'un poil.

[COME]

Salut,

 

Autocad MAP 2017 et windows 7 ici, et ça ne marche pas.

J'y connais rien en LISP mais voilà ce que ça me fait au lancement de la commande :

 

- Seuls restent les textes de voirie et les polylignes du calque "1ZONCOMM"

- On m'invite à sélectionner une polyligne

- Lorsque j'en sélectionne une, tout se dégèle mais le texte associé à la polyligne sélectionnée ne bouge pas d'un poil.

 

Salut,

 

oui cela le colle dans le presse-papiers, donc tu lances la commande Edition-->Coller et ton nom de rue regroupé apparaît et à toi de le coller là où tu le désires.

[hey_bapt]

Ah au temps pour moi j'avais mal compris le fonctionnement.

Ca semble bon donc.

[Kegaska]

Fonctionne avec Autocad Map 3d 2018.0.1 - Windows 10

 

Merci!

[vincentp010]

Marche bien sur W10 avec autocad map 2009

 

Un petit soucis sur certaines polylignes dont le sens est inversé par rapport au texte.

Du coup j'ai des noms de rue comme "Chats des Rue" au lieu de "Rue des Chats".

Il faudrait peut être mettre un dialogue demandant laquelle des phrases est la bonne; à moins qu'il soit possible de détecter le bon sens.

[Fraid]

Et coucou,

 

Je peut enfin me reconnecter.

Merci pour vos retours.

Effectivement, quand il y a plusieurs textes sur un segment, il y a de grande chance que les textes soient placés dans le désordre.

J'ai donc repris mon algorithme, et continue a faire des testes. (pas simple)

Je mettrais en ligne ce week end la nouvelle version.

à bientôt.

[Fraid]

Bonjour,

 

J'ai donc revue ma copie.

Il y a toujours des cas ingérables qui produisent des textes dans le désordre.

Mais moins que dans la première version.

 

Si quelqu'un à une idée pour s'approché du 100% de réussite.