;;; (c) 2012 Ediciones ARTUAL, S.L. Barcelona, España.
;;; Copyright © 2012-2020 by Reinaldo N. Togores. All rights reserved.
;;; Use of this code is allowed mentioning the book and its author.
;;;Chapter 11. Selecting Entities
(defun similar (ent-list / )
(ssget "_X"
(list (assoc 0 ent-list)
(assoc 8 ent-list)
(if (assoc 67 ent-list)
(assoc 67 ent-list)
'(67 . 0))
(if (assoc 62 ent-list)
(assoc 62 ent-list)
'(62 . 256))
(if (assoc 6 ent-list)
(assoc 6 ent-list)
'(6 . "BYLAYER"))
(assoc 410 ent-list))))
;;;Listing 11.1. Select objects with similar properties.
(defun C:ERASE-SIMILAR ()
(vl-cmdf
"._erase"
(similar
(entget
(car (entsel "\nSelect an object to erase similar ones: "))))
"")
(princ))
;;;Listing 11.2. Command to delete all similar objects.
(defun sel-area (obj key llc urc)
(ssget "X"
(list (cons 0 obj)
(cons 410 (getvar "ctab"))
'(-4 . ">,>,*")
(cons key llc)
'(-4 . "<,<,*")
(cons key urc))))
;;;Listing 11.3. Rectangular area selection.
(defun sel-area-multikey (obj lyr key-list llc urc)
(ssget
"X"
(append
(list (cons 0 obj) (cons 8 lyr) (cons 410 (getvar "ctab")))
(append '((-4 . "))
(apply 'append
(mapcar '(lambda (x)
'(-4 . ">,>,*")
(cons x llc)
'(-4 . "<,<,*")
(cons x urc)
'(-4 . "AND>")))
key-list))
'((-4 . "OR>"))))))
;;;Listing 11.4. Area selection using multiple keys.
(defun sel-outside (obj key llc urc)
(ssget "X"
(list (cons 0 obj)
(cons 410 (getvar "ctab"))
'(-4 . ")
'(-4 . ") ;_ condition for x coordinate
'(-4 . ">,*,*")
(cons key llc)
'(-4 . "<,*,*")
(cons key urc)
'(-4 . "XOR>")
'(-4 . ") ;_ condition for y coordinate
'(-4 . "*,>,*")
(cons key llc)
'(-4 . "*,<,*")
(cons key urc)
'(-4 . "XOR>")
'(-4 . "OR>"))))
;;;Listing 11.5. Selection of all objects outside a rectangular area.
(defun C:DEMO-SEL-AREA (/ old-col inside sel llc urc)
(vl-cmdf "._UNDO" "_Begin")
(cmd-in)
(setq old-col (getvar "CECOLOR"))
(initget 1 "Inside Outside")
(if (= (getkword "\nSelect [Inside/Outside]: ") "Inside")
(setq inside t))
(setvar "cecolor" "5")
(vl-cmdf "._zoom" "_w" '(0.0 0.0) '(297.0 210.0))
(vl-cmdf "._circle" '(10.0 10.0) 2.5)
(vl-cmdf "._array" (entlast) "" "_r" 20 25 10.0 10.0)
(prompt "\nSpecify area for selection: ")
(setq llc (getpoint "\nLower left corner: ")
urc (getcorner llc "\nUpper right corner: "))
(if (apply 'and (mapcar '<= llc urc))
(progn
(getstring
"\nPress any key to leave only one circle visible: ")
(vl-cmdf "._zoom" "_w" '(5.0 5.0) '(15.0 15.0))
(alert "Selecting unseen circles and changing color...")
(setq sel (if inside
(sel-area "CIRCLE" 10 llc urc)
(sel-outside "CIRCLE" 10 llc urc)))
(vl-cmdf "._change" sel "" "_p" "_c" 1 "")
(getstring
"\nPress any key to return to previous view: ")
(vl-cmdf "._zoom" "_p")
(alert (strcat (itoa (sslength sel))
" selected circles changed to red"))
(cmd-out)
(setvar "CECOLOR" old-col)
(vl-cmdf "._UNDO" "_End"))
(progn (vl-cmdf "._UNDO" "_Back")
(prompt "\nRuntime error!")))
(princ))
;;;Listing 11.6. Demonstration of area selection functions.
(defun ss+ (/ sel-set tmp)
(setvar "grips" 2) ; for 2010 or lower (setvar "grips" 1)
(setq sel-set (ssadd))
(while (setq tmp (entsel "\nSelect entity to add: "))
(ssadd (car tmp) sel-set)
(sssetfirst nil sel-set))
sel-set)
;;;Listing 11.7. SSADD demonstration.
(defun ss++ (/ sel-set tmp add)
(cmd-in)
(setvar "grips" 2)
(setq sel-set (ssadd)
add t)
(initget "Remove")
(while (setq tmp (getpoint (strcat "\nSelect entity to "
(if add
"add[Remove]: "
"remove[Add]: "))))
(cond ((listp tmp)
(if (setq tmp (ssget tmp))
(progn (apply (if add
'ssadd
'ssdel)
(list (ssname tmp 0) sel-set))
(sssetfirst nil sel-set))))
((= tmp "Remove") (setq add nil))
(t (setq add t)))
(initget (if add
"Remove"
"Add")))
(cmd-out)
(cdr (sssetfirst nil sel-set)))
;;;Listing 11.8. Construction of a selection set by adding and removing entities.
(defun ss->ax-ss (sel-set sel-name sel-coll / sel)
(if (vl-catch-all-error-p
(setq sel
(vl-catch-all-apply 'vla-add (list sel-coll sel-name))))
(vla-clear (setq sel (vla-item sel-coll sel-name))))
(vla-additems sel (ss->array sel-set))
(vla-item sel-coll sel-name))
;;;Listing 11.9. Transformation of a PICKSET in SelectionSet.
(defun ss->array (sel-set / index array)
(setq index 0
array (vlax-make-safearray
vlax-vbObject
(cons 0 (1- (sslength sel-set)))))
(repeat (sslength sel-set)
(vlax-safearray-put-element
array
index
(vlax-ename->vla-object (ssname sel-set index)))
(setq index (1+ index)))
(vlax-make-variant array))
;;;Listing 11.10. Adding PICKSET objects to an array.
(defun VxSsetFilter (Flt)
(mapcar '(lambda (Typ Dat) (VxListToArray Typ Dat))
(list vlax-vbInteger vlax-vbVariant)
(list (mapcar 'car Flt) (mapcar 'cdr Flt))))
;;;Listing 11.11. Automatic creation of ActiveX selection filters.
;;; ©2002 MENZI ENGINEERING GmbH, Switzerland.
(defun VxListToArray (Typ Lst)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray Typ (cons 0 (1- (length Lst))))
Lst)))
;;;Listing 11.12. VxListToArray function.
;;; ©2002 MENZI ENGINEERING GmbH, Switzerland.
(defun ax-sel-fence (sel-set point-list filter-list)
(apply 'vla-SelectByPolygon
(append (list sel-set
acSelectionSetFence
(ax-list->array (apply 'append point-list)))
(VxSsetFilter filter-list))))
;;;Listing 11.13. Fence selection with ActiveX.
(defun ax-list->variant (lst)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbObject
(cons 0 (1- (length lst))))
lst)))
;;;Listing 11.14. Conversion of the list into an array.
(defun ax-no-group (obj-list group-obj / tmp)
(vlax-for obj group-obj
(setq tmp (cons (vla-get-handle obj) tmp)))
(foreach obj obj-list
(if (member (vla-get-handle obj) tmp)
(setq obj-list (vl-remove obj obj-list))))
obj-list)
;;;Listing 11.15. Function to detect and remove objects that belong to a Group.
(defun ax-add-group (name obj-list / groups-coll group)
(setq groups-coll (vla-get-Groups *aevl:drawing*)
group (vl-catch-all-apply 'vla-Item (list groups-coll name)))
(cond ((vl-catch-all-error-p group)
(setq group (vla-Add groups-coll name))
(vla-AppendItems group (ax-list->variant obj-list))
group)
(t
(if (setq objects (ax-no-group obj-list group))
(vla-AppendItems group (ax-list->variant objects)))
group)))
;;;Listing 11.16. Function for adding objects to a Group.
(defun ax-if-group (obj-list group-obj / tmp)
(vlax-for obj group-obj
(setq tmp (cons (vla-get-handle obj) tmp)))
(foreach obj obj-list
(if (not (member (vla-get-handle obj) tmp))
(setq obj-list (vl-remove obj obj-list))))
obj-list)
;;;Listing 11.17. Function that removes from the list those objects that are not in the Group.
(defun ax-group-remove (name obj-list / groups-coll group)
(setq groups-coll (vla-get-Groups *aevl:drawing*)
group (vl-catch-all-apply 'vla-Item (list groups-coll name)))
(cond ((vl-catch-all-error-p group) nil)
(t
(if (setq objects (ax-if-group obj-list group))
(vla-RemoveItems group (ax-list->variant objects)))
(if (= (vla-get-Count group) 0)
(vla-Delete group)
group))))
;;;Listing 11.18. Function that removes entities from a Group.
No comments:
Post a Comment