Coordonnées communes à 2 blocs

[michouka]

Bonjour à tous,

 

Je cherche le moyen de pouvoir sélectionner un type de bloc A dans mon dessin uniquement si un type de bloc B posséde la même coordonnée en X, sachant que je débute en VBA.

j'espère être assez clair.

 

Merci d'avance pour votre aide...

[michouka]

Je pense qu'un petit dessin permettra de mieux cibler mon problème!!!

http://nsa05.casimages.com/img/2009/02/18/090218110412463611.png

Voilà, en fait je désire pouvoir isoler sur un autre caque tous les blocs verts et bleus (nommés blocs A et B) qui n'ont pas de bloc rouge associé (bloc C), je dois comparer les coordonnées en X de A et B par rapport à C mais mes connaissances en VBA sont très limitées!!!

 

 

[Edité le 18/2/2009 par michouka]

[Patrick_35]

Salut

 

Je ne pourrai t'aider en vba, mais par contre, voici un exemple en lisp

 

(defun c:test(/ bl lst sel)
 (and (ssget "x" (list (cons 0 "insert")))
   (vlax-for bl (setq sel (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
     (setq lst (cons (list (car (vlax-get bl 'insertionpoint))
		    (if (vlax-property-available-p bl 'effectivename)
		      (vla-get-effectivename bl)
		      (vla-get-name bl)
		    )
	      )
	      lst
	)
     )
   )
   (foreach bl (vl-sort lst '(lambda(a b)(< (car a)(car b))))
     (princ (strcat "\nBloc " (cadr bl) " aux coordonnées X "))
     (princ (car bl))
   )
   (vla-delete sel)
 )
 (princ)
)

 

Pour lancer la fonction, directement sur la ligne de commande test

 

@+

[michouka]

Merci pour ton intervention Patrick, de mon côté, grâce aux connaissances d'un collégue voici ce à quoi nous sommes arrivés:

Sub nettoyage_PL()

Dim entObjectID

Dim entry As AcadEntity

Dim i, tableau

i = 0

'on déverouille tous les calques

ThisDrawing.SendCommand "-calque" & vbCr & "D" & vbCr & "*" & vbCr & vbCr

'on crée le calque pour recevoir les données à supprimer et le rend courant

ThisDrawing.SendCommand "-calque" & vbCr & "E" & vbCr & "PL_DOUBLON" & vbCr & "CO" & vbCr & "U" & vbCr & "255,0,0" & vbCr & vbCr & vbCr

'on compte le nombre de blocks poteau

For Each entry In ThisDrawing.ModelSpace

entObjectID = entry.ObjectName

If entObjectID = "AcDbBlockReference" Then

If entry.Name = "POTEAU_CATENAIRE" Then

i = i + 1

End If

End If

Next

'on compte le nombre de ligne du calque PN_OA_RS

For Each entry In ThisDrawing.ModelSpace

entObjectID = entry.ObjectName

If entObjectID = "AcDbLine" Then

If entry.Layer = "CALQUE_PN_OA_RS" Then

i = i + 1

End If

End If

Next

'on dimensionne le tableau

ReDim tableau(i - 1)

'on met tous les x dans le tableau

i = 0

For Each entry In ThisDrawing.ModelSpace

entObjectID = entry.ObjectName

If entObjectID = "AcDbBlockReference" Then

If entry.Name = "POTEAU_CATENAIRE" Then

mcoordonnees = entry.InsertionPoint

xd = mcoordonnees(0)

tableau(i) = xd

i = i + 1

End If

End If

Next

For Each entry In ThisDrawing.ModelSpace

entObjectID = entry.ObjectName

If entObjectID = "AcDbLine" Then

If entry.Layer = "CALQUE_PN_OA_RS" Then

mcoordonnees = entry.StartPoint

xd = mcoordonnees(0)

tableau(i) = xd

i = i + 1

End If

End If

Next

'on cherche les blocks à supprimer

For Each entry In ThisDrawing.ModelSpace

entObjectID = entry.ObjectName

If entObjectID = "AcDbBlockReference" Then

If entry.Name = "POINT_LIBELLE_VERTICAL" Or Mid(entry.Name, 1, 7) = "PL_PLAN" Then

mcoordonnees = entry.InsertionPoint

xd = mcoordonnees(0)

Dim suppr

suppr = 0

For i = 0 To UBound(tableau)

If xd = tableau(i) Then

suppr = 1

Exit For

End If

Next

If suppr = 0 Then

entry.Layer = "PL_DOUBLON"

End If

End If

End If

Next

'retour calque 0

ThisDrawing.SendCommand "-calque" & vbCr & "CH" & vbCr & "0" & vbCr & vbCr

 

End Sub