Dessiner une polyligne fermée autour d'une selection

Valentin-J · le 28 août 2019

Bonjour,

Je cherche à dessiner automatiquement une polyligne fermée autour d'éléments divers (blocs, polylignes...).

Voila l'idée:

Avant:

Après:

Merci à vous!

oran · le 10 octobre 2019

Avec bcp de retard !!!

BoundingBoxReactorV1-0.lsp

Commande BBRN --> crée un contour (polyligne)

Cde BBRA --> Ajoute un élément dans le contour

Cde BBRN --> Supprime un (des) éléments du contour

;;--------------=={ BoundingBox Reactor NEW }==---------------;;
;; ;;
;; Allows the user to create a new reactor owner group for ;;
;; which a bounding polyline will be updated following ;;
;; modification of an owner within the group ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;

(defun c:bbrn ( / *error* owners lst )
(vl-load-com)
;; © Lee Mac 2010

(defun *error* ( msg )
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)

(setq owners (_GetAllOwners :vlr-object-reactor))

(if (setq lst
(vl-remove-if
(function
(lambda ( object )
(vl-position object owners)
)
)
(LM:SS->VLA (ssget))
)
)
(vlr-object-reactor lst
(cdr
(assoc 5
(entget
(LWPoly
(LM:BBox->List
(LM:ListBoundingBox lst)
)
1
)
)
)
)
(list (cons :vlr-modified 'BB:WasModified))
)
)

(princ)
)

;;------------=={ BoundingBox Reactor REMOVE }==--------------;;
;; ;;
;; Allows the user to remove objects from an existing ;;
;; reactor owner group, or remove all groups ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;

(defun c:bbrr ( / *error* owners gr code data hLst msg e o nm )
(vl-load-com)
;; © Lee Mac 2010

(defun *error* ( msg )
(and nm (setvar 'NOMUTT nm))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)

(setq owners (_GetAllOwners :vlr-object-reactor))

(mapcar 'vlr-remove (mapcar 'car owners))

(princ (setq msg "\nSelect Group to Remove Objects from <All> : "))

(while
(progn
(setq gr (grread 't 15 2) code (car gr) data (cadr gr))

(cond
(
(= 5 code)

(if (and
(setq e (car (nentselp data)))
(setq o (vlax-ename->vla-object e))
(setq group
(cdar
(vl-member-if
(function
(lambda ( x )
(vl-position o (cdr x))
)
)
owners
)
)
)
)

(HighlightObjects (setq hLst group) T)

(if hLst (progn (HighlightObjects hLst nil) (setq hLst nil)))
)
t
)
(
(= 3 code)

(if (and
(setq e (car (nentselp data)))
(setq o (vlax-ename->vla-object e))
(setq group
(car
(vl-member-if
(function
(lambda ( x )
(vl-position o (cdr x))
)
)
owners
)
)
)
)
(if (progn
(if hLst (progn (HighlightObjects hLst nil) (setq hLst nil)))
(setq nm (getvar 'NOMUTT))
(setvar 'NOMUTT 1)
(princ "\nSelect Objects to Remove <All> : ")
(setq lst (LM:SS->VLA (ssget)))
(setvar 'NOMUTT nm)
lst
)
(progn
(mapcar
(function
(lambda ( owner )
(if (vl-position owner (cdr group))
(vlr-owner-remove (car group) owner)
)
)
)
lst
)

(BB:WasModified (car lst) (car group) nil)

(princ "\n<< Objects Removed from Group >>")
nil
)
(progn
(setq owners (vl-remove group owners))
(vlr-remove (car group))

(if hLst (progn (HighlightObjects hLst nil) (setq hLst nil)))
(princ "\n<< Group BoundingBox Associativity Removed >>")
nil
)
)
(princ (strcat "\n** No Group Found **" msg))
)
)
(
(or (and (= 2 code) (member data '(13 32))) (= 25 code))

(setq owners nil)
(princ "\n<< BoundingBox Associativity Removed from All Objects >>")

(if hLst (progn (HighlightObjects hLst nil) (setq hLst nil)))
)
( (princ (strcat "\n** Invalid KeyPress **" msg)) )
)
)
)

(mapcar 'vlr-add (mapcar 'car owners))
(princ)
)

;;-------------=={ BoundingBox Reactor ADD }==----------------;;
;; ;;
;; Allows the user to add objects to an existing reactor ;;
;; owner group ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;

(defun c:bbra ( / *error* owners msg gr code data e o group hLst lst nm )
(vl-load-com)
;; © Lee Mac 2010

(defun *error* ( msg )
(and nm (setvar 'NOMUTT nm))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)

(setq owners (_GetAllOwners :vlr-object-reactor))

(mapcar 'vlr-remove (mapcar 'car owners))

(princ (setq msg "\nSelect Group to Add Objects to: "))

(while
(progn
(setq gr (grread 't 15 2) code (car gr) data (cadr gr))

(cond
(
(= 5 code)

(if (and
(setq e (car (nentselp data)))
(setq o (vlax-ename->vla-object e))
(setq group
(cdar
(vl-member-if
(function
(lambda ( x )
(vl-position o (cdr x))
)
)
owners
)
)
)
)

(HighlightObjects (setq hLst group) T)

(if hLst (progn (HighlightObjects hLst nil) (setq hLst nil)))
)
t
)
(
(= 3 code)

(if (and
(setq e (car (nentselp data)))
(setq o (vlax-ename->vla-object e))
(setq group
(caar
(vl-member-if
(function
(lambda ( x )
(vl-position o (cdr x))
)
)
owners
)
)
)
)

(if (progn
(setq nm (getvar 'NOMUTT))
(setvar 'NOMUTT 1)
(princ "\nSelect Objects to Add: ")
(setq lst (LM:SS->VLA (ssget)))
(setvar 'NOMUTT nm)
lst
)
(progn
(mapcar
(function
(lambda ( owner ) (vlr-owner-add group owner))
)
lst
)

(BB:WasModified (car lst) group nil)

(if hLst (progn (HighlightObjects hLst nil) (setq hLst nil)))
(princ "\n<< Objects added to group >>")
nil
)
)
(princ (strcat "\n** No Group Found **" msg))
)
)
)
)
)

(mapcar 'vlr-add (mapcar 'car owners))
(princ)
)

;;--------------------=={ Was Modified }==--------------------;;
;; ;;
;; Callback function for the BoundingBox Reactor to update ;;
;; the bounding polyline of the calling owner group ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; owner - object to which the modification event applies ;;
;; reactor - reactor object to which the owner belongs ;;
;; args - reactor data associated with the event ;;
;;------------------------------------------------------------;;

(defun BB:WasModified ( owner reactor args / h )
(vl-load-com)

(if (and (setq h (vlr-data reactor))
(setq h (handent h))
(entget h)
)
(entdel h)
)

(
(lambda ( owners )
(if owners
(vlr-data-set reactor
(cdr
(assoc 5
(entget
(LWPoly
(LM:BBox->List
(LM:ListBoundingBox owners)
)
1
)
)
)
)
)
(vlr-remove reactor)
)
)
(vl-remove-if
(function
(lambda ( owner )
(if (vlax-erased-p owner)
(vlr-owner-remove reactor owner)
)
)
)
(vlr-owners reactor)
)
)

(princ)
)

;;-----------------=={ Highlight Objects }==------------------;;
;; ;;
;; Highlights or Unhighlights a list of supplied VLA Objects ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; lst - list of VLA Objects ;;
;; h - Boolean Flag: (T=Highlight, nil=Unhighlight) ;;
;;------------------------------------------------------------;;

(defun HighLightObjects ( lst h )
(
(lambda ( x )
(mapcar
(function
(lambda ( object ) (vla-highlight object x))
)
lst
)
)
(if h :vlax-true :vlax-false)
)
)

;;----------------=={ Get Reactor Object }==------------------;;
;; ;;
;; Returns the reactor object of the specified type ;;
;; associated with the application data supplied ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; data - reactor application data ;;
;; typ - Type of reactor to query, eg :vlr-object-reactor ;;
;;------------------------------------------------------------;;
;; Returns: VLA Reactor Object, else nil ;;
;;------------------------------------------------------------;;

(defun _GetReactorObject ( data typ )
(vl-some
(function
(lambda ( reactor )
(if (eq data (vlr-data reactor)) reactor)
)
)
(cdar (vlr-reactors typ))
)
)

;;------------------=={ Get All Owners }==--------------------;;
;; ;;
;; Returns a list of reactors of the specified type and ;;
;; owners for each reactor ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; typ - Type of reactor to query, eg :vlr-object-reactor ;;
;;------------------------------------------------------------;;
;; Returns: ((<reactor> <owner> ... <owner>) (<reactor> ..)) ;;
;;------------------------------------------------------------;;

(defun _GetAllOwners ( typ )
(mapcar
(function
(lambda ( reactor )
(cons reactor (vlr-owners reactor))
)
)
(cdar (vlr-reactors typ))
)
)

;;---------------------=={ LWPolyline }==---------------------;;
;; ;;
;; Creates an LWPolyline with vertices at each point in the ;;
;; supplied list ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; lst - list of vertices for polyline ;;
;; cls - Closed Bit Flag: 1=Closed, 0=Open ;;
;;------------------------------------------------------------;;
;; Returns: entity name of created LWPolyline, else nil ;;
;;------------------------------------------------------------;;

(defun LWPoly ( lst cls )
(entmakex
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length lst))
(cons 70 cls)
)
(mapcar '(lambda ( p ) (cons 10 p)) lst)
)
)
)

;;-----------------=={ SelectionSet -> VLA }==----------------;;
;; ;;
;; Converts a SelectionSet to a list of VLA Objects ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; ss - Valid SelectionSet (Pickset) ;;
;;------------------------------------------------------------;;
;; Returns: List of VLA Objects ;;
;;------------------------------------------------------------;;

(defun LM:ss->vla ( ss )
;; © Lee Mac 2010
(if ss
(
(lambda ( i / e l )
(while (setq e (ssname ss (setq i (1+ i))))
(setq l (cons (vlax-ename->vla-object e) l))
)
l
)
-1
)
)
)

;;------------------=={ List BoundingBox }==------------------;;
;; ;;
;; Returns the coordinates of a rectangle framing all ;;
;; objects in a supplied list ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; lst - list of VLA-Objects to process ;;
;;------------------------------------------------------------;;
;; Returns: coordinates of rectangle framing objects ;;
;;------------------------------------------------------------;;

(defun LM:ListBoundingBox ( lst / ll ur bb )
;; © Lee Mac 2010

(foreach obj lst (vla-getBoundingBox obj 'll 'ur)
(setq bb (cons (vlax-safearray->list ur)
(cons (vlax-safearray->list ll) bb))
)
)

(mapcar
(function
(lambda ( operation )
(apply (function mapcar) (cons operation bb))
)
)
'(min max)
)
)

;;----------------=={ BoundingBox -> List }==-----------------;;
;; ;;
;; Returns the coordinates of a rectangle from the ;;
;; coordinates of the lower-left and upper-right corners ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; bbox - list of lower-left and upper-right coordinates ;;
;;------------------------------------------------------------;;
;; Returns: coordinates of rectangle ;;
;;------------------------------------------------------------;;

(defun LM:BBox->List ( bbox )
(mapcar
(function
(lambda ( funcs )
(mapcar
(function
(lambda ( func ) ((eval func) bbox))
)
funcs
)
)
)
'((caar cadar) (caadr cadar) (caadr cadadr) (caar cadadr))
)
)

Cordialement

didier · le 10 octobre 2019

Coucou

Évite de copier des codes sur des dizaines et des dizaines de lignes s'il te plaît

Un lien vers le site de l'auteur sera plus léger,

Plus simple à lire

Et tu permettras à celui qui suivra le lien de découvrir d'autres programmes qui pourraient aussi l’intéresser.

Amicalement

Olivier Eckmann · le 10 octobre 2019

Bonjour,

Toujours chez Lee Mac, je pense que cet algorithme est plus proche du souhait initial : Convex Hull

Olivier

oran · le 10 octobre 2019

Oops !! mea culpa !! :(

BoundingBoxReactorV1-0.lsp

Fraid · le 10 octobre 2019

Bonjour,

Merci Olivier, pour l'Algorithme de Ronald Graham, simple et efficace.

J'avais mis ce sujet de coté, intéressé par les problèmes soulevés.

En fait, cela n'est pas si simple.

autour d'éléments divers (blocs, polylignes...)

La première étape, est d'établir la liste des points de l'emprise de chaque objet.

Si c'est facile avec les points, cela l'est déjà moins avec les polylignes avec des arcs par exemple.

Avec les blocs, c'est une usine à gaz qu'il faut mettre en place pour envisagé tout les cas (attributs, dynamique ...)

Une liste exhaustive d'objets aurait été préférable, car une solution pour tous, n'est pas envisageable.

Une fois que l'on a la liste des points, on relie chaque point à tout les points,

et on récupère avec contour, le contour. (ne connaissant pas Ronald)

Donc, Valentin, dit nous quels sont exactement les objets Autocad à prendre en compte, de quoi sont composé tes blocs, et on pourras plus t'aider.

Olivier Eckmann · le 10 octobre 2019

Fraid,

Voilà un article de Kean peut-être intéressant : ICI même s'il ne travaille que sur les boundingbox et pas sur l'extraction des points par type d'objet.

Olivier

Fraid · le 10 octobre 2019

En effet, très intéressant.

Il explose beaucoup de chose, c'est la solution que j'ai choisi aussi.

Avec les blocs, si on les BURST, on élimine beaucoup de soucis.

Pour les arcs, pour être au plus juste, il faut utiliser les tangentes passant par chaque point ...

C'est plus sportif

Connexion

Dessiner une polyligne fermée autour d'une selection

Messages recommandés

Valentin-J

oran

didier

Olivier Eckmann

oran

Fraid

Olivier Eckmann

Fraid

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Forums

Naviguer

Activité

Information importante