[编程交流] 实体内的复制块（

(defun c:bcopy ()(c:blkssc)) ;; 
(defun c:blkssc (/ *ERROR* *MYERR BLKN E EEE NPT OLDERR PAUSE SS SS2 SSB SSN SSR SSS SSS2 X ssx)
 (princ "\n bcopy=Copy block within the entity  by lxx.2008.2")
 (defun *myerr (msg)(if sss2 (progn(command ".undo" "e")(command ".u")))(setq *error* olderr)(princ))
 (setq olderr *error*
*error* *myerr)
 (princ "\n Choose the block：")
 (if (setq ss (ssget '((0 . "INSERT"))))
   (progn
     (setq e  (ssname ss 0)
    blkn (cdr (assoc 2 (entget e)))
     )
     (command ".undo" "be")
     (setvar "qaflags" 1)
     (command ".explode" ss "")
     (setq ss2 (ssget "p"))
     (setq sss2 (xss2lst ss2))
     (mapcar '(lambda (x) (redraw x 3)) sss2)
     (princ "\n Choose the entity from block:")
     (while (setq ssa (ssget ":S"))
(mapcar '(lambda (x)
    (if (and (ssmemb x ss2) (member x ssr))
      (progn (redraw x 3)
      (setq ssr (vl-remove x ssr))
      )
      (if (ssmemb x ss2)
        (progn (redraw x 4)
        (setq ssr (cons x ssr))
        )
      )
    )
  )
 (xss2lst ssa)
)
     )
     (setq ssx (mapcar 'entget ssr))
     (command ".u")
;;;      (setq ;npt (getpoint "\n Basic point：")
;;;     ;npt2 (getpoint "\n Copy to：")
;;;     )
     (setq eee (entlast)
    ssn (ssadd))
     (mapcar 'entmake ssx)
;;;      (setq eee(entnext eee))
     (while (setq eee(entnext eee))
(ssadd eee ssn)
     )
;;;      (command ".move" ssn "" npt pause)
;;;      (setq rlst (mapcar '(lambda (x) (vl-position x sss2)) ssr))
;;;      (setq i -1)
;;;      (vlax-for x (vla-item
;;;      (vla-get-blocks
;;;        (vla-get-activedocument (vlax-get-acad-object))
;;;      )
;;;      blkn
;;;    )
;;; (setq i (1+ i))
;;; (if (member i rlst)
;;;   (vla-delete x)
;;; )
;;;      )
;;;      (setq ssb (ssget "x" (list (cons 0 "INSERT") (cons 2 blkn)))
;;;     sssb (xss2lst ssb)
;;;      )
;;;      (mapcar 'entupd sssb)
     (command ".undo" "e")
;;;      ssb
     
   )
 )
 (if ssn
   ;(sssetfirst ssn ssn)
   (command ".move" ssn "")
   )
)
;; v1.1
(defun xss2lst (ss / i lst)
 (setq i (sslength ss))
 (repeat i
   (setq lst (cons (ssname ss (setq i (1- i))) lst))
 )
)