Création d'une boîte englobante pour plusieurs blocs avec attributs

[nen]

Bonjour le forum🙂,

Je sollicite votre aide pour un problème que nous rencontrons.
Depuis plusieurs mois, mon collègue et moi, qui sommes de véritables novices en Lisp, travaillons sur un code ci-dessous pour créer une boîte englobante (rectangle) autour d'une sélection de blocs contenant plusieurs attributs. Nous souhaitons que cette boîte (rectangle) soit placée sur le calque "Rectangle" en couleur verte, et nous aimerions inclure une option pour demander un décalage.

Nous avons essayé d'intégrer différents morceaux de code sans succès. Si quelqu'un pouvait jeter un coup d'œil à notre code, ce serait vraiment sympa😉.

Merci d'avance pour votre aide !

(defun c:BoxBlocAttrib ( / ss i Ent ObjType AttribList Bbox MinPt MaxPt Pt1 Pt2 Pt3 Pt4 Decal)
  (setq oldcmd00 (getvar "cmdecho"))
  (setvar "cmdecho" 0)

  ;; Fonction pour décaler un point
  (defun DeltaXY (Pt1 DeltaX DeltaY)
    (list (+ (car Pt1) DeltaX)
          (+ (cadr Pt1) DeltaY)
    )
  )

  ;; Fonction pour calculer la boîte englobante entre deux points
  (defun AddToBoundingBox (bbox point)
    (setq MinPt (mapcar 'min (car bbox) point))
    (setq MaxPt (mapcar 'max (cadr bbox) point))
    (list MinPt MaxPt)
  )

  ;; Demander la sélection des blocs
  (setq ss (ssget '((0 . "INSERT")))) ; Sélection des blocs
  (setq Decal (getdist "\nDécalage ? <10> : "))
  (if (= Decal nil)(setq Decal 10))

  ;; Créer ou définir le calque "Rectangle" avec une couleur verte
  (if (not (tblsearch "layer" "Rectangle"))
    (progn
      (command "_.-layer" "_Make" "Rectangle" "_Color" "Vert" "" "")
    )
    (command "_.-layer" "_Set" "Rectangle" "")
  )

  ;; Boucler sur chaque bloc sélectionné
  (setq i 0)
  (while (< i (sslength ss))
    (setq Ent (ssname ss i))
    (setq ObjType (cdr (assoc 0 (entget Ent)))) ; Récupérer le type d'objet

    ;; Initialiser la boîte englobante
    (setq Bbox nil)

    ;; Si c'est un bloc avec attributs, on récupère les attributs et leur boîte englobante
    (if (eq ObjType "INSERT")
      (progn
        (setq AttribList (entnext Ent))
        (while (and AttribList (eq (cdr (assoc 0 (entget AttribList))) "ATTRIB"))
          (command "_ucs" "_Entity" AttribList)
          (setq Tb_list (textbox (list (cons -1 AttribList))))
          (setq Pt1 (car Tb_list))
          (setq Pt2 (cadr Tb_list))
          (if Bbox
            (setq Bbox (AddToBoundingBox Bbox Pt1))
            (setq Bbox (list Pt1 Pt2))
          )
          (setq Bbox (AddToBoundingBox Bbox Pt2))
          (setq AttribList (entnext AttribList))
        )

        ;; Décaler les points de la boîte englobante
        (setq Pt1 (car Bbox))
        (setq Pt1 (DeltaXY Pt1 (* Decal -1) (* Decal -1)))
        (setq Pt2 (cadr Bbox))
        (setq Pt2 (DeltaXY Pt2 Decal Decal))
        (setq Pt3 (list (car Pt1) (cadr Pt2)))
        (setq Pt4 (list (car Pt2) (cadr Pt1)))

        ;; Dessiner le rectangle sur le calque "Rectangle"
        (command "_layer" "_set" "Rectangle" "")
        (command "_rectang" Pt1 Pt2)

        ;; Restaurer le SCU (système de coordonnées utilisateur)
        (command "_ucs" "_p")
      )
    )

    ;; Passer à l'objet suivant
    (setq i (1+ i))
  )

  (setvar "cmdecho" oldcmd00)
  (princ)
)

 

[(gile)]

Salut,

Regarde cette réponse.

[Luna]

Coucou @nen,
En complément de la réponse de @(gile), qui fait alors référence à une commande, je te propose la fonction de LeeMac à cet effet : https://www.lee-mac.com/boundingbox.html
Cependant, cela ne permet d'obtenir que le plus petit rectangle englobant une unique entité selon le SCG. Je me souviens avoir développé une fonction en m'appuyant sur le travail de LeeMac, (gile) et Douglas C. Broad.

La fonction (UCSssBoundingBox) permet, comme son nom l'indique de renvoyer les coordonnées bas/gauche et haut/droit du plus petit rectangle englobant un jeu de sélection passé en argument en considérant le SCU courant pour chaque objet. Pour cela elle s'appuie sur les fonctions (WCS2UCSMatrix) et (UCS2WCSMatrix) de Douglas, et le reste de la fonction n'est qu'une piètre adaptation des codes de LeeMac et (gile). Tu trouveras également en PJ la fonction (LM:ssBoundingBox) développée par LeeMac qui fait le même travail mais sans la conversion vers le SCU des coordonnées d'objets. Dans les deux cas, les coordonnées du rectangles sont calculées selon les axes SCG.

Je m'autorise également une petite remarque concernant ton filtre de sélection

(setq ss (ssget '((0 . "INSERT")))) ; Sélection des blocs

En effet tu marques dans ton message que tu ne traites que les blocs avec attributs :

Citation

créer une boîte englobante (rectangle) autour d'une sélection de blocs contenant plusieurs attributs.

Pour cela, au lieu de sélectionner uniquement l'ensemble des blocs (0 . "INSERT"), tu ajoutes un filtre supplémentaire pour justement ne conserver que les blocs avec attributs (code DXF 66) :

(setq ss (ssget '((0 . "INSERT") (66 . 1)))) ; Sélection des blocs

Et si jamais tu souhaites traiter des blocs ayant une dénomination particulière, alors il suffit de rajouter un code DXF 2 (ATTENTION aux blocs dynamiques cependant !).

Je vous laisse y réfléchir pour intégrer tout chat comme vous le souhaitez et si vous avez encore besoin d'aide/conseils surtout n'hésitez pas :3

Bisous,
Luna

DtSel . UCSssBoundingBox.lsp DtSel . LM.ssBoundingBox.lsp VlMet . UCS2WCSMatrix.lsp VlMet . WCS2UCSMatrix.lsp

[nen]

Bonjour Gile,
Merci beaucoup pour ton lien🙂.
J'ai effectivement testé le LISP "mbbox", et bien qu'il fonctionne, il ne répond pas exactement à mes attentes. Je souhaiterais que, lorsque je sélectionne 4 blocs, une boîte englobante soit créée pour chacun d'entre eux.

Bonjour Luna,
Merci beaucoup pour ton aide.
J'ai corrigé le problème avec (code DXF 66)😉, et maintenant mon code fonctionne... enfin presque🤔. Pour les blocs contenant plusieurs attributs, il ne crée une boîte englobante que pour le dernier attribut. Après de nombreux essais, je me suis tourné vers le code de base de Lee Mac, " LM :boundingbox", et cela fonctionne, mais les boîtes englobantes (cadres) ne sont pas placées correctement(image ci-joint).
Aurais-tu une idée pour résoudre ce problème ?
 

(defun c:BoxBlocAttrib23 ( / ss i Ent ObjType bbox Decal)
  (setq oldcmd00 (getvar "cmdecho"))
  (setvar "cmdecho" 0)

  ;; Demander la sélection des blocs avec attributs (code DXF 66)
  (setq ss (ssget '((0 . "INSERT") (66 . 1))))
  (setq Decal (getdist "\nDécalage ? <10> : "))
  (if (= Decal nil)(setq Decal 10)) ; Par défaut, décalage de 10 si aucune entrée

  ;; Créer ou définir le calque "Rectangle" avec une couleur verte
  (if (not (tblsearch "layer" "Rectangle"))
    (progn
      (command "_.-layer" "_Make" "Rectangle" "_Color" "Vert" "" "")
    )
    (command "_.-layer" "_Set" "Rectangle" "")
  )

  ;; Boucler sur chaque bloc sélectionné
  (setq i 0)
  (while (< i (sslength ss))
    (setq Ent (ssname ss i))
    (setq ObjType (cdr (assoc 0 (entget Ent)))) ; Récupérer le type d'objet

    ;; Si c'est un bloc avec attributs
    (if (eq ObjType "INSERT")
      (progn
        ;; Récupérer la boîte englobante du bloc
        (setq bbox (LM:boundingbox (vlax-ename->vla-object Ent)))

        ;; Si une boîte englobante est trouvée
        (if bbox
          (progn
            ;; Décaler les points de la boîte englobante
            (setq Pt1 (list (- (car (car bbox)) Decal) (- (cadr (car bbox)) Decal)))
            (setq Pt2 (list (+ (car (cadr bbox)) Decal) (+ (cadr (cadr bbox)) Decal)))

            ;; Dessiner le rectangle sur le calque "Rectangle"
            (command "_rectang" Pt1 Pt2)
          )
        )
      )
    )

    ;; Passer à l'objet suivant
    (setq i (1+ i))
  )

  ;; Restaurer les paramètres initiaux
  (setvar "cmdecho" oldcmd00)
  (princ)
)

;; Fonction pour obtenir la boîte englobante d'un objet donné
(defun LM:boundingbox ( obj / llp urp )
  (if (and
        (vlax-method-applicable-p obj 'getboundingbox)
        (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
      )
    (list (vlax-safearray->list llp) (vlax-safearray->list urp))
  )
)

 

BoxBlocAttrib23.lsp

[(gile)]

L'utilisation de entmake à la place de command pour créer des objets (calques, polylignes) permet d'avoir un meilleur contrôle et de s'affranchir des problèmes de SCU ou d'accrochages aux objets.

Essaye comme ça :

(defun BboxRectangle (entity offset / pts)
  (vl-load-com)
  (vl-catch-all-apply
    (function
      (lambda (/ ll ur pt1 pt2)
	(if (= (type entity) 'ENAME)
	  (setq entity (vlax-ename->vla-object entity))
	)
	(vla-GetBoundingBox entity 'll 'ur)
	(setq pt1 (vlax-safearray->list ll)
	      pt1 (list (- (car pt1) offset) (- (cadr pt1) offset))
	      pt2 (vlax-safearray->list ur)
	      pt2 (list (+ (car pt2) offset) (+ (cadr pt2) offset))
	      pts (list pt1 (list (car pt2) (cadr pt1)) pt2 (list (car pt1) (cadr pt2)))
	)
      )
    )
  )
  pts
)

(defun c:BoxBlocAttrib (/ ss i decal pts)
  (if (setq ss (ssget '((0 . "INSERT") (66 . 1))))
    (progn
      (if (null (tblsearch "LAYER" "Rectangle"))
	(entmake
	  '(
	    (0 . "LAYER")
	    (100 . "AcDbSymbolTableRecord")
	    (100 . "AcDbLayerTableRecord")
	    (2 . "Rectangle")
	    (70 . 0)
	    (62 . 3)
	    (6 . "Continuous")
	   )
	)
      )
      (or (setq decal (getdist "\nDécalage ? <10> : "))
	  (setq decal 10.)
      )
      (repeat (setq i (sslength ss))
	(if (setq pts (BboxRectangle (ssname ss (setq i (1- i))) decal))
	  (entmake
	    (append
	      '(
		(0 . "LWPOLYLINE")
		(100 . "AcDbEntity")
		(8 . "Rectangle")
		(100 . "AcDbPolyline")
		(90 . 4)
		(70 . 1)
	       )
	      (mapcar '(lambda (x) (cons 10 x)) pts)
	    )
	  )
	)
      )
    )
  )
  (princ)
)

 

[nen]

Bonjour ✋,
 Je te remercie Gile pour ces précisions supplémentaires🙂.
J'ai testé ta version ces derniers jours et elle fonctionne parfaitement👍.
Merci à toi aussi, Luna, pour ton aide😉.

Meilleures salutations