Détection/Sélection des Points/Blocs en doublons

[lecrabe]

 

Hello

 

N'ayant pas trouvé mon bonheur, je fais appel "aux cakes" du Forum ;)

 

La routine DELDUP_BLK.lsp d'Autodesk me permet de nettoyer un dessin au niveau des blocs/symboles en double par rapport au point d'insertion XY !

 

Nettoyer/Effacer automatiquement c un peu rapide et dangeureux ! :o

 

Mon besoin est légèrement différent, je désire traiter par moi même

visuellement ultérieurement ... :P

 

SVP je désire une routine pour trouver, sélectionner et forcer dans une couleur tous les blocs ou points qui sont en double (ou plus) au niveau du point d'insertion XY. On ne traite pas le Z.

 

C pour les trouver facilement et les "rectifier" plus tard ...

 

--- Deroulement de la routine ---

 

Demande du code couleur (1-255) pour le forcage ulterieure de la couleur

 

Demande du rayon de recherche R (Defaut R = 0.1) :

 

Sélection classique AutoCAD

 

Forcage des blocs et points "se trouvant dans la même zone" avec la couleur voulue

 

Résultat : N objets sélectionnés dont M ont ete forcés ...

 

Merci d'avance et Bonne reprise à tous, Le Decapode

 

[Patrick_35]

Salut Lecrabe

 

Quelque chose de ce style ?

 

(defun c:recd(/ coul doc ent lst rech sel tot)
 (vl-load-com)
 (if (ssget (list (cons 0 "INSERT,POINT")))
   (progn
     (setq doc (vla-get-activedocument (vlax-get-acad-object))
    tot 0
     )
     (or (setq coul (getint "\nVeuillez indiquer la couleur à forcer : "))
(setq coul 7)
     )
     (initget 2)
     (or (setq rech (getreal "\nVeuillez indiquer le rayon de recherche <0.10> : "))
(setq rech 0.1)
     )
     (vlax-for ent (setq sel (vla-get-activeselectionset doc))
(setq lst (cons ent lst))
     )
     (foreach ent lst
(foreach dou (cdr lst)
  (and	(not (equal ent dou))
	(equal	(vla-get-objectname ent) (vla-get-objectname dou))
	(equal	(vlax-get ent (if (eq (vla-get-objectname ent) "AcDbBlockReference")
				'insertionpoint
				'coordinates
			      )
		)
		(vlax-get dou (if (eq (vla-get-objectname dou) "AcDbBlockReference")
				'insertionpoint
				'coordinates
			      )
		)
		rech
	)
    (setq tot (1+ tot)
	  lst (vl-remove ent lst)
    )
    (vla-put-color dou coul)
  )
)
     )
     (princ (strcat "\n" (itoa (vla-get-count sel)) " objet(s) traité(s), " (itoa tot) " objet(s) forcé(s)."))
     (vla-delete sel)
   )
 )
 (princ)
)

 

@+

[lecrabe]

 

Hello P35

 

Thank you very much, cela semble bien fonctionner sur MAP 3D 2006 ! :)

 

Par contre la routine a tourné pendant environ 45 mn pour traiter environ 3600 blocs

ce qui me parait un peu long, mais c peut etre normal !

 

Bon Appétit à tous, Merci, Le Decapode

 

[lecrabe]

ReHello

 

Par contre j'ai un petit souci, les blocs/points en double (ou plus) ne sont pas TOUS forcés

en Rouge, il semblerait seuls les 2eme, 3eme, etc soient forcés en Rouge

 

Un peu comme si le 1er bloc/point trouvé soit la référence et que les suivants

qui sont dans le rayon de recherche sont les "mauvais" !

 

Vois tu ce que je veux dire ?

 

Le Decapode

 

 

[Edité le 27/8/2009 par lecrabe]

[Patrick_35]

Oui, c'était volontaire.

Comme c'est des doubles, je laissai le 1er et changeai la couleur des autres.

 

Voici une version suivant ta demande et plus rapide.

 

(defun c:recd(/ cac coul doc enc ent fin lst rech sel tab tot)
 (vl-load-com)
 (if (ssget (list (cons 0 "INSERT,POINT")))
   (progn
     (setq doc (vla-get-activedocument (vlax-get-acad-object))
    tot 0
    enc 0
     )
     (or (setq coul (getint "\nVeuillez indiquer la couleur à forcer : "))
(setq coul 7)
     )
     (initget 2)
     (or (setq rech (getreal "\nVeuillez indiquer le rayon de recherche <0.10> : "))
(setq rech 0.1)
     )
     (vlax-for ent (setq sel (vla-get-activeselectionset doc))
(setq lst (cons ent lst))
     )
     (princ (strcat "\nRecherche en cours ... " (setq cac (strcat "0/" (setq fin (itoa (vla-get-count sel)))))))
     (while lst
(setq ent (car lst)
      enc (1+ enc)
      tab (cdr lst)
)
(foreach dou tab
  (and	(equal	(vla-get-objectname ent) (vla-get-objectname dou))
	(equal	(vlax-get ent (if (eq (vla-get-objectname ent) "AcDbBlockReference")
				'insertionpoint
				'coordinates
			      )
		)
		(vlax-get dou (if (eq (vla-get-objectname dou) "AcDbBlockReference")
				'insertionpoint
				'coordinates
			      )
		)
		rech
	)
    (setq tot (1+ tot)
	  enc (1+ enc)
	  ok T
	  lst (vl-remove dou lst)
    )
    (vla-put-color dou coul)
  )
)
(and ok
  (setq tot (1+ tot))
  (vla-put-color ent coul)
)
(repeat (strlen cac)
  (princ (chr 8))
)
(princ (setq cac (strcat (itoa enc) "/" fin)))
(princ)
(setq lst (cdr lst)
      ok nil
)
     )
     (princ (strcat "\n" fin " objet(s) traité(s), " (itoa tot) " objet(s) forcé(s)."))
     (vla-delete sel)
   )
 )
 (princ)
)

 

@+

[lecrabe]

 

ReHello

 

Super Tip-Top, la nouvelle routine est plus rapide (au minimum 2-4 fois)

et elle force bien tous les blocs en doublons ! :)

 

Le petit compteur est aussi fort sympathique ! :D

 

Routine testée sur MAP 2006 ... :P

 

J'espère qu'elle sera utile à de nombreuses personnes ...

 

Merci beaucoup, Le Decapode