;;; Special_Selections -Gilles Chanteau- (gile) ;;; Quelques routines pour créer des jeux de sélection particuliers. ;;;===============================================================;;; ;; Sélection par calque (defun c:ssl (/ ss ent) (and (or (and (setq ss (cadr (ssgetfirst))) (= 1 (sslength ss)) (setq ent (ssname ss 0)) ) (and (sssetfirst nil nil) (setq ent (car (entsel))) ) ) (sssetfirst nil (ssget "_X" (list (assoc 8 (entget ent))))) ) (princ) ) ;;;===============================================================;;; ;; Sélection par type d'entité (defun c:sse (/ ss) (and (or (and (setq ss (cadr (ssgetfirst))) (= 1 (sslength ss)) (setq ent (ssname ss 0)) ) (and (sssetfirst nil nil) (setq ent (car (entsel))) ) ) (sssetfirst nil (ssget "_X" (list (assoc 0 (entget ent))))) ) (princ) ) ;;;===============================================================;;; ;; Sélection par couleur (defun c:ssc (/ ent elst col) (and (or (and (setq ss (cadr (ssgetfirst))) (= 1 (sslength ss)) (setq ent (ssname ss 0)) ) (and (sssetfirst nil nil) (setq ent (car (entsel))) ) ) (setq elst (entget ent) col (cond ((assoc 430 elst)) ((assoc 420 elst)) ((assoc 62 elst)) (T (cons 62 256)) ) ) (sssetfirst nil (ssget "_X" (list col))) ) (princ) ) ;;;===============================================================;;; ;; Sélection par type de ligne (defun c:sstl (/ ent tl) (and (or (and (setq ss (cadr (ssgetfirst))) (= 1 (sslength ss)) (setq ent (ssname ss 0)) ) (and (sssetfirst nil nil) (setq ent (car (entsel))) ) ) (or (setq tl (assoc 6 (entget ent))) (setq tl (cons 6 "BYLAYER")) ) (sssetfirst nil (ssget "_X" (list tl))) ) (princ) ) ;;;===============================================================;;; ;; Sélection par valeur d'attribut (defun c:ssatt (/ doc att elst tag val name ss1 ss2) (vl-load-com) (and (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (setq att (car (nentsel "\nSélectionnez l'attribut source: "))) (setq att (vlax-ename->vla-object att)) (= (vla-get-ObjectName att) "AcDbAttribute") (setq tag (vla-get-TagString att) val (vla-get-TextString att) blk (vla-ObjectIDToObject doc (vla-get-OwnerId att)) name (if (vlax-property-available-p blk 'EffectiveName) (vla-get-EffectiveName blk) (vla-get-Name blk) ) ss2 (ssadd) ) (princ "\nSélectionnez les blocs ou : ") (or (ssget (list '(0 . "INSERT") '(66 . 1) (cons 2 (strcat name ",`*U*")) ) ) (ssget "_X" (list '(0 . "INSERT") '(66 . 1) (cons 2 (strcat name ",`*U*")) ) ) ) (vlax-for blk (setq ss1 (vla-get-ActiveSelectionSet doc)) (if (= name (if (vlax-property-available-p blk 'EffectiveName) (vla-get-EffectiveName blk) (vla-get-Name blk) ) ) (foreach a (vlax-invoke blk 'GetAttributes) (if (and (= (vla-get-TagString a) tag) (= (vla-get-TextString a) val) ) (ssadd (vlax-vla-object->ename blk) ss2) T ) ) T ) ) (not (vla-delete ss1)) (sssetfirst nil ss2) ) (princ) ) ;;;===============================================================;;; ;; SSCU (gile) 31/03/07 ;; Sélection mutiple par cible, fenêtre ou capture ;; Le cadre de la fenêtre est parallèle au plan du SCU courant ;; La sélection est terminée en faisant Entrée, Espace ou clic droit (defun c:sscu (/ sel sst loop p1 gr p2 p3 p4 po ss n ent) (defun ssd_err (msg) (if (= msg "Fonction annulée") (princ) (princ (strcat "\nErreur: " msg)) ) (sssetfirst nil nil) (redraw) (setq *error* m:err m:err nil ) (princ) ) ;; Retourne un jeu de sélection, un point ou nil (defun sel (/ loop gr pt) (setq loop T) (while (and (setq gr (grread T 12 2)) (/= (car gr) 3) loop) (cond ((= (car gr) 5) (setq pt (cadr gr)) ) ((or (member gr '((2 13) (2 32))) (or (= (car gr) 11) (= (car gr) 25)) ) (setq loop nil pt nil ) ) ) ) (if pt (cond ((ssget pt)) (pt) ) ) ) (setq m:err *error* *error* ssu_err ) (sssetfirst nil nil) (setq sst (ssadd)) (while (and (princ "\nChoix des objets: ") (setq p1 (sel)) ) (if (listp p1) (progn (princ "\nSpécifiez le coin opposé: ") (setq p1 (list (car p1) (cadr p1))) (while (and (setq gr (grread T 12 0)) (/= (car gr) 3)) (if (= 5 (car gr)) (progn (redraw) (setq p2 (list (caadr gr) (cadr p1)) p3 (list (caadr gr) (cadadr gr)) p4 (list (car p1) (cadadr gr)) ) (if (< (car p1) (car p2)) (progn (setq po "_WP") (grvecs (list 255 p1 p2 255 p2 p3 255 p3 p4 255 p4 p1) ) ) (progn (setq po "_CP") (grvecs (list -255 p1 p2 -255 p2 p3 -255 p3 p4 -255 p4 p1) ) ) ) ) ) ) (redraw) (if (setq ss (ssget po (list p1 p2 p3 p4))) (repeat (setq n (sslength ss)) (setq ent (ssname ss (setq n (1- n)))) (if (not (ssmemb ent sst)) (ssadd ent sst) ) (sssetfirst nil sst) ) ) ) (progn (ssadd (ssname p1 0) sst) (sssetfirst nil sst) ) ) ) (sssetfirst nil sst) (setq *error* m:err m:err nil ) (princ) ) ;;;===============================================================;;; ;;; SelByObj -Gilles Chanteau- 06/10/06 ;;; Crée un jeu de sélection avec tous les objets contenus ou ;;; capturés, dans la vue courante, par l'objet sélectionné ;;; (cercle, ellipse, polyligne fermée). ;;; Arguments : ;;; - un nom d'entité (ename) ;;; - un mode de sélection (Cp ou Wp) ;;; - un filtre de sélection ou nil ;;; ;;; modifié le 19/07/07 : fonctionne avec les objets hors fenêtre (defun SelByObj (ent opt fltr / obj dist n lst prec dist p_lst ss) (vl-load-com) (if (= (type ent) 'ENAME) (setq obj (vlax-ename->vla-object ent)) (setq obj ent ent (vlax-vla-object->ename obj) ) ) (cond ((member (vla-get-ObjectName obj) '("AcDbCircle" "AcDbEllipse")) (setq dist (/ (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj) ) 128 ) n 0 ) (repeat 128 (setq lst (cons (trans (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n)))) 0 1 ) lst ) ) ) ) ((and (= (vla-get-ObjectName obj) "AcDbPolyline") (= (vla-get-Closed obj) :vlax-true) ) (setq p_lst (vl-remove-if-not '(lambda (x) (or (= (car x) 10) (= (car x) 42) ) ) (entget ent) ) ) (while p_lst (setq lst (cons (trans (append (cdr (assoc 10 p_lst)) (list (cdr (assoc 38 (entget ent)))) ) ent 1 ) lst ) ) (if (/= 0 (cdadr p_lst)) (progn (setq prec (1+ (fix (* 64 (sqrt (abs (cdadr p_lst)))))) dist (/ (- (if (cdaddr p_lst) (vlax-curve-getDistAtPoint obj (trans (cdaddr p_lst) ent 0) ) (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj) ) ) (vlax-curve-getDistAtPoint obj (trans (cdar p_lst) ent 0) ) ) prec ) n 0 ) (repeat (1- prec) (setq lst (cons (trans (vlax-curve-getPointAtDist obj (+ (vlax-curve-getDistAtPoint obj (trans (cdar p_lst) ent 0) ) (* dist (setq n (1+ n))) ) ) 0 1 ) lst ) ) ) ) ) (setq p_lst (cddr p_lst)) ) ) ) (cond (lst (vla-ZoomExtents (vlax-get-acad-object)) (setq ss (ssget (strcat "_" opt) lst fltr)) (vla-ZoomPrevious (vlax-get-acad-object)) ss ) ) ) ;;;===============================================================;;; ;;; SSOC pour sélectionner tous les objets capturés, suivant ;;; la vue, par le cercle, l'ellipse ou la polyligne. (defun c:ssoc (/ ss) (and (or (and (setq ss (cadr (ssgetfirst))) (= 1 (sslength ss)) ) (and (sssetfirst nil nil) (setq ss (ssget "_:S:E" (list '(-4 . "") '(-4 . "") '(-4 . "OR>") ) ) ) ) ) (sssetfirst nil (ssdel (ssname ss 0) (SelByObj (ssname ss 0) "Cp" nil)) ) ) (princ) ) ;;;===============================================================;;; ;;; SSOF pour sélectionner tous les objets contenus, suivant ;;; la vue, dans le cercle, l'ellipse ou la polyligne. (defun c:ssof (/ ss) (and (or (and (setq ss (cadr (ssgetfirst))) (= 1 (sslength ss)) ) (and (sssetfirst nil nil) (setq ss (ssget "_:S:E" (list '(-4 . "") '(-4 . "") '(-4 . "OR>") ) ) ) ) ) (sssetfirst nil (SelByObj (ssname ss 0) "Wp" nil) ) ) (princ) ) ;;;===============================================================;;; ;;; SSOCM pour sélectionner tous les objets capturés, suivant ;;; la vue, par les cercles, les ellipses ou les polylignes. (defun c:ssocm (/ ss ss1 ss2 i j) (if (setq ss1 (ssget (list '(-4 . "") '(-4 . "") '(-4 . "OR>") ) ) ) (progn (setq ss (ssadd)) (repeat (setq i (sslength ss1)) (setq ss2 (ssdel (ssname ss1 (setq i (1- i))) (SelByObj (ssname ss1 i) "Cp" nil))) (repeat (setq j (sslength ss2)) (ssadd (ssname ss2 (setq j (1- j))) ss) ) ) (sssetfirst nil ss) ) ) (princ) ) ;;;===============================================================;;; ;;; SSOFM pour sélectionner tous les objets contenus, suivant ;;; la vue, dans les cercles, les ellipses ou les polylignes. (defun c:ssofm (/ ss ss1 ss2 i j) (if (setq ss1 (ssget (list '(-4 . "") '(-4 . "") '(-4 . "OR>") ) ) ) (progn (setq ss (ssadd)) (repeat (setq i (sslength ss1)) (setq ss2 (SelByObj (ssname ss1 (setq i (1- i))) "Wp" nil)) (repeat (setq j (sslength ss2)) (ssadd (ssname ss2 (setq j (1- j))) ss) ) ) (sssetfirst nil ss) ) ) (princ) ) ;;;===============================================================;;; ;;; Inv_sel Inverse le jeu de sélection courant (defun c:inv_sel (/ ssa ssf n) (setq ssa (ssget "_A" (list '(0 . "~VIEWPORT") (cons 410 (getvar "ctab"))) ) ) (if (setq ssf (cadr (ssgetfirst))) (repeat (setq n (sslength ssf)) (ssdel (ssname ssf (setq n (1- n))) ssa) ) ) (sssetfirst) (sssetfirst nil ssa) ) ;;;===============================================================;;; ;;; SSD version 2.6 (gile) 14/07/08 (dernière révision 17/11/2011) ;;; Sélection de blocs dynamiques par des valeurs de paramètres dynamiques ;;; ;;; Utilisations : ;;; - Pour créer un jeu de sélection, entrer SSD, sélectionner un bloc source ;;; puis choisir les valeurs à filtrer dans la boite de dialogue. ;;; - A l'intérieur d'un commande de modification, à l'invite "Choix des objets: " ;;; entrer (SSD). ;;; Le filtre peut se faire sur tout le dessin ou à l'intérieur d'une sélection (defun ssd (/ *error* ToString DynBlkPropValue dz ss ent blk name pop fuzz ret sel res) (vl-load-com) (or *acad* (setq *acad* (vlax-get-acad-object))) (or *acdoc* (setq *acdoc* (vla-get-ActiveDocument *acad*))) (defun *error* (msg) (if (/= msg "Fonction annulée") (princ (strcat "Erreur: " msg)) ) (and blk (not (redraw (vlax-vla-object->ename blk) 4))) (setvar 'dimzin dz) (princ) ) (defun ToString (v u) (cond ((= 0 u) (vl-princ-to-string v)) ((= 1 u) (angtos v (getvar 'aunits) 16)) ((if (< (abs v) 1e-6) (rtos v 1 6) (rtos v (getvar 'lunits) 12) ) ) ) ) ;; DynBlkPropValue ;; Boite de dialogue pour choisir des valeurs de paramètres dynamiques ;; ;; Argument : la liste des paramètres dynamiques (defun DynBlkPropValue (lst / tmp file pn unt av dcl_id val) (setq tmp (vl-filename-mktemp "Tmp.dcl") file (open tmp "w") ) (write-line (strcat "DynBlkProps:dialog{label=\"Filtre de blocs dynamiques\";" ":text{label=\"Nom du bloc : \"" (vl-prin1-to-string name) ";}spacer;:boxed_column{label=\"Propriétés dynamiques\";" ) file ) (foreach p lst (setq pn (vla-get-PropertyName p) unt (vla-get-UnitsType p) ) (cond ((setq av (vlax-get p 'AllowedValues)) (setq av (mapcar '(lambda (x) (ToString x unt)) av) pop (cons (vl-list* pn "*" av) pop) ) (write-line (strcat ":popup_list{label=" (vl-prin1-to-string pn) ";key=" (vl-prin1-to-string pn) ";value=" (itoa (1+ (vl-position (ToString (vlax-get p 'Value) unt) av))) ";edit_width=25;allow_accept=true;}" ) file ) ) ((/= pn "Origin") (setq fuzz (cons pn fuzz)) (write-line (strcat ":row{:edit_box{label=" (vl-prin1-to-string pn) ";key=" (vl-prin1-to-string pn) ";value=" (vl-prin1-to-string (ToString (vlax-get p 'Value) unt)) ";edit_width=18;allow_accept=true;}" ":edit_box{label=\"Tolérance\";key=" (vl-prin1-to-string (strcat pn "_fuzz")) ";value=\"1e-12\";edit_width=6;allow_accept=true;}}" ) file ) ) ) ) (write-line (strcat "}spacer;:radio_row{key=\"selset\";" ":radio_button{label=\"Tout le dessin\";key=\"all\";value=\"1\";}" ":radio_button{label=\"Sélection\";key=\"sel\";}}" "spacer;ok_cancel;}" ) file ) (close file) (setq dcl_id (load_dialog tmp)) (if (not (new_dialog "DynBlkProps" dcl_id)) (exit) ) (foreach p pop (start_list (car p)) (mapcar 'add_list (cdr p)) (end_list) ) (action_tile "accept" "(foreach p (mapcar 'vla-get-PropertyName lst) (if (assoc p pop) (setq val (nth (atoi (get_tile p)) (cdr (assoc p pop)))) (setq val (get_tile p))) (if (and val (/= val \"\") (/= val \"*\")) (setq ret (cons (cons p val) ret)))) (setq fuzz (mapcar (function (lambda (x) (cons x (get_tile (strcat x \"_fuzz\"))))) fuzz)) (and (not ret) (setq ret T)) (setq sel (get_tile \"selset\")) (done_dialog)" ) (action_tile "cancel" "(setq ret nil)") (start_dialog) (unload_dialog dcl_id) (vl-file-delete tmp) ret ) ;;----------------------------------------------------;; (setq dz (getvar 'dimzin)) (setvar 'dimzin 8) (and (or (and (setq ss (cadr (ssgetfirst))) (= 1 (sslength ss)) (setq ent (ssname ss 0)) (sssetfirst nil nil) ) (and (sssetfirst nil nil) (setq ent (car (entsel))) ) ) (setq blk (vlax-ename->vla-object ent)) (= (vla-get-ObjectName blk) "AcDbBlockReference") (= (vla-get-IsDynamicBlock blk) :vlax-true) (not (redraw ent 3)) (setq name (vla-get-EffectiveName blk)) (or (DynBlkPropValue (vlax-invoke blk 'getDynamicBlockProperties)) (redraw ent 4) ) (not (redraw ent 4)) (if (= sel "all") (ssget "_X" (list '(0 . "INSERT") (cons 2 (strcat name ",`*U*"))) ) (ssget (list '(0 . "INSERT") (cons 2 (strcat name ",`*U*"))) ) ) (setq res (ssadd)) (vlax-for b (setq ss (vla-get-ActiveSelectionSet *acdoc*)) (if (and (= (vla-get-EffectiveName b) name) (or (= ret T) ((lambda (lst) (apply '= (cons T (mapcar (function (lambda (p / n v l u f) (setq n (car p) l (assoc n lst) u (vla-get-UnitsType (caddr l)) ) (equal (cond ((= 0 u) (cdr p)) ((= 1 u) (angtof (cdr p))) (T (distof (cdr p))) ) (if (= u 0) (vl-princ-to-string (cadr l)) (cadr l) ) (if (and (setq f (cdr (assoc n fuzz))) (numberp (read f)) ) (atof f) 1e-12 ) ) ) ) ret ) ) ) ) (mapcar (function (lambda (p / n v) (list (setq n (vla-get-PropertyName p)) (vlax-get p 'Value) p ) ) ) (vlax-invoke b 'getDynamicBlockProperties) ) ) ) ) (ssadd (vlax-vla-object->ename b) res) ) ) (vla-delete ss) ) (setvar 'dimzin dz) res ) (defun c:ssd () (sssetfirst nil (ssd)) (princ) )