[编程交流] 将数据附着到块创建

(defun c:MakeSpace ( / *error* BLOCK CEN DOC FLG ID NME OBJS SPC SS )
 (vl-load-com)
 ;; Lee Mac  ~  18.05.10
 (setq id "SPACE-")
 (defun *error* ( msg )
   (and flg (vla-EndUndoMark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )
 (setq spc
   (if
     (or
       (eq AcModelSpace
         (vla-get-ActiveSpace
           (setq doc
             (vla-get-ActiveDocument
               (vlax-get-acad-object)
             )
           )
         )
       )
       (eq :vlax-true (vla-get-MSpace doc))
     )
     (vla-get-ModelSpace doc)
     (vla-get-PaperSpace doc)
   )
 )
 (initget 1)
 (setq nme (getstring "\nPlease Enter Space ID: "))
 (cond
   (
     (tblsearch "BLOCK" (strcat id nme))
     (princ "\n** Block Already Exists **")
   )
   (
     (not (setq ss (ssget "_:L")))
   )
   (
     (setq flg (not (vla-StartUndoMark doc)))
     (setq block
       (vla-Add (vla-get-Blocks doc)
         (vlax-3D-point
           (setq cen
             (apply (function mapcar)
               (cons
                 (function
                   (lambda ( x y )
                     (/ (+ x y) 2.)
                   )
                 )
                 (SSBoundingBox ss)
               )
             )
           )
         )
         (strcat id nme)
       )
     )
     (vla-copyObjects doc
       (ObjectVariant (setq objs (ss->vla ss))) block
     )
     (mapcar
       (function
         (lambda ( prmpt pt tag )
           (vla-AddAttribute block (getvar 'TEXTSIZE) 0 prmpt
             (vlax-3D-point pt) tag ""
           )
         )
       )
       (list "Tag 1: " "Tag 2: " "Tag 3: ")
       (list cen
         (polar cen (/ (* 3 pi) 2.) (* 1.5 (getvar 'TEXTSIZE)))
         (polar cen (/ (* 3 pi) 2.) (* 3.0 (getvar 'TEXTSIZE)))
       )
       (list "TAG1" "TAG2" "TAG3")
     )
     (if
       (vl-catch-all-error-p
         (setq bObj
           (vl-catch-all-apply (function vla-InsertBlock)
             (list spc (vlax-3D-point cen) (strcat id nme) 1. 1. 1. 0.)
           )
         )
       )
       (princ "\n** Error Inserting Block **")
       (foreach att (vlax-invoke bObj 'GetAttributes)
         (vla-put-TextString att (vla-get-Handle bObj))
       )
     )
     (mapcar (function vla-erase) objs)
     (setq flg (vla-EndUndoMark doc))
   )
 )
 (princ)
)
(defun ObjectVariant ( lst )
 (vlax-make-variant
   (vlax-safearray-fill
     (vlax-make-safearray vlax-vbObject
       (cons 0 (1- (length lst)))
     )
     lst
   )
 )
)
(defun SSBoundingBox ( ss / ent ll ur bBoxs )
 ;; Lee Mac  ~  18.03.10
 (  (lambda ( i )
      
      (while (setq ent (ssname ss (setq i (1+ i))))
        (vla-getBoundingBox (vlax-ename->vla-object ent) 'll 'ur)
        (setq bBoxs (cons (vlax-safearray->list ur)
                          (cons (vlax-safearray->list ll) bBoxs)))
      )
    )    
 -1
 )
 (mapcar
   (function
     (lambda (operation)
       (apply (function mapcar)
         (cons operation bBoxs)
       )
     )
   )
   '(min max)
 )
)
(defun ss->vla ( ss )
 (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
   )
 )
)