[编程交流] 将SS移动到Bpoly的质心

;Credits: Tharwat, Lee Mac
(defun c:test (/ s1 l1 cen1 doc e o u spc reg obj cen2)
  (princ "\nSelect objects to move from their center")
  (setq s1 (ssget "_:L"))
  (setq l1 (LM:ssboundingbox s1 ))
  (setq cen1 (apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.0)) l1)) )
 (setq e (entlast))
 (if (and (vl-cmdf "_.-boundary" "\" "\")
          (setq o (entlast))
          (not (eq e o))
          (eq (cdr (assoc 0 (entget o))) "LWPOLYLINE")
     )
   (progn
     (setq doc (vla-get-activedocument (vlax-get-acad-object)) )
     (setq spc (vla-get-block (vla-item (vla-get-layouts doc) (getvar 'ctab))) )
     (setq reg (vlax-invoke spc 'addregion (list (setq obj (vlax-ename->vla-object o)))) )
     (if
       (setq cen2 (vlax-3d-point (append (vlax-get (car reg) 'centroid) (list 0.))) )
       (progn
       (command "_move" s1 "" "_non" cen1 "_non" cen2 )
       (mapcar 'vla-delete o)
       (vla-delete (car reg))
       );progn
     );if
   );progn
  );if
;vlax-safearray->list (vlax-variant-value VAR))
(princ)
)
;; Selection Set Bounding Box  -  Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; s - [sel] Selection set for which to return bounding box
(defun LM:ssboundingbox ( s / a b i m n o )
   (repeat (setq i (sslength s))
       (if
           (and
               (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
               (vlax-method-applicable-p o 'getboundingbox)
               (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
           )
           (setq m (cons (vlax-safearray->list a) m)
                 n (cons (vlax-safearray->list b) n)
           )
       )
   )
   (if (and m n)
       (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
   )
)
(vl-load-com) (princ)

(defun c:test ( / box ent ply pnt reg sel )
   (cond
       (   (not (setq sel (ssget "_:L"))))
       (   (not (setq box (LM:ssboundingbox sel)))
           (princ "\nUnable to calculate bounding box for selection.")
       )
       (   (not (setq pnt (getpoint "\nSpecify point within bounded area: "))))
       (   (progn
               (setq ent (entlast))
               (vl-cmdf "_.-boundary" "_A" "_I" "_N" "" "_O" "_P" "" "_non" pnt "")
               (eq ent (setq ply (entlast)))
           )
           (princ "\nUnable to determine boundary from given point.")
       )
       (   (vl-catch-all-error-p
               (setq reg
                   (vl-catch-all-apply 'vlax-invoke
                       (list
                           (vlax-get-property (vla-get-activedocument (vlax-get-acad-object))
                               (if (= 1 (getvar 'cvport))
                                   'paperspace
                                   'modelspace
                               )
                           )
                           'addregion (list (vlax-ename->vla-object ply))
                       )
                   )
               )
           )
           (princ "\nUnable to create region from boundary.")
       )
       (   (vl-cmdf "_.move" sel ""
               "_non" (trans (apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.0)) box)) 0 1)
               "_non" (vlax-get (car reg) 'centroid)
           )
       )
   )
   (if (and (= 'ename (type ply)) (entget ply))
       (entdel ply)
   )
   (if (and (= 'vla-object (type (car reg))) (vlax-write-enabled-p (car reg)))
       (vla-delete (car reg))
   )
   (princ)
)
;; Selection Set Bounding Box  -  Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; s - [sel] Selection set for which to return bounding box
(defun LM:ssboundingbox ( s / a b i m n o )
   (repeat (setq i (sslength s))
       (if
           (and
               (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
               (vlax-method-applicable-p o 'getboundingbox)
               (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
           )
           (setq m (cons (vlax-safearray->list a) m)
                 n (cons (vlax-safearray->list b) n)
           )
       )
   )
   (if (and m n)
       (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
   )
)
(vl-load-com) (princ)