[编程交流] Entmake 0。插入属性

(Defun tee(/ sset cntr Ratt attlist  blk  blklist blkdef c)
 (vl-load-com)
 (setq bname "Attblock")
 (setq cntr -1)
 (setq sset (ssget "X" (list(cons 2 bname))))
 (while (< (setq cntr (+ cntr 1)) (sslength sset))
   (setq blk (vlax-ename->vla-object   (ssname sset cntr)))
   (setq attlist  (list(cdr (assoc 10 (entget (vlax-vla-object->ename blk))))))
   (if (= (vla-get-hasattributes blk) :vlax-true)
     (progn
       (foreach c (vlax-safearray->list (variant-value (vla-getattributes blk)))
         (setq attlist (append attlist (list(list (vla-get-tagstring c)
                          (vla-get-textstring c)
                               (vla-get-height c)
                          (vla-get-invisible c)
                          (vla-get-layer c)
                          (getpmt bname (vla-get-tagstring c))))))
       )
       (setq blklist (append blklist (list  attlist)))
       (setq attlist nil)
     )
   ) 
 )
 (command"erase" sset"")
 (setq Blkdef (cdar blklist))
 (CreateBlock blkdef bname)
 (foreach c blklist
  (InsertBlock c bname)
 )
 (command"qsave")
)
(defun CreateBlock (attlist name / ent p1 )
 (setq sset (ssadd))
(foreach c attlist
  (setq tag (car c) text (nth 5 c) height (caddr c) visible (cadddr c) layer (nth 4 c ) )
  (if (= p1 nil)
    (setq p1 (list 0.0 0.0 0.0))
    (setq p1 (list (car p1 )(- (cadr p1) (+ height (/ height 2)))(caddr p1)))
  )
  (entmake   (list
       (cons 0 "ATTDEF")
       (cons 10 p1)
       (cons 40 height)
       (cons 8 layer)
       (cons 1 "")
       (cons 3 text)
       (cons 7 (getvar "TEXTSTYLE"))
       (cons 2 tag)
       (cons 70 1)
         )
  )
  (setq ent (entget (entlast)))
  (setq ent(subst (cons 8 layer)(assoc 8 ent)ent))
  (setq ent(subst (cons 40 height)(assoc 40 ent)ent))
  (if (eq visible :vlax-true)
    (
      (setq ent(subst (cons 70 0)(assoc 70 ent)ent))
    )
  )
  (entmod ent)
  (ssadd (entlast) sset)
)
 (setq p1 (list (car p1 )(- (cadr p1) (+ height (/ height 2)))(caddr p1)))
 (entmake   (list
       (cons 0 "ATTDEF")
       (cons 10 p1)
       (cons 40 300)
       (cons 8 layer)
       (cons 1 "")
       (cons 3 "F2")
       (cons 7 (getvar "TEXTSTYLE"))
       (cons 2 "FLOOR")
       (cons 70 1)
         )
  )
 (setq ent (entget (entlast)))
 (setq ent(subst (cons 8 layer)(assoc 8 ent)ent))
 (entmod ent)
 (ssadd (entlast) sset)
 (command"block" name "y" (list 0.0 -450.0 0.0) sset "")
)
(defun getpmt (blk aname)
 (if (tblsearch "BLOCK" blk)
   (vlax-for Obj (vla-item
                   (vla-get-Blocks
                     (vla-get-Activedocument
                       (vlax-get-acad-object))) blk)
     (if (eq "AcDbAttributeDefinition"
             (vla-get-ObjectName Obj))
   (if (= (vla-get-tagstring obj) aname) 
         (setq pmt (vla-get-PromptString Obj)))))
       )
       
 pmt)
   
       
(defun InsertBlock  (attlst bname / c ent tag)
 (vl-load-com)
 (if (vl-catch-all-error-p
       (vl-catch-all-apply
         (function
           (lambda ( )
             (setq blk
               (vla-insertblock
                 (vla-get-ModelSpace
                   (vla-get-ActiveDocument
                     (vlax-get-acad-object)))
                 (vlax-3D-point (car attlst)) bName 1. 1. 1. 0.)))))) nil
   (if (eq :vlax-true (vla-get-HasAttributes blk))
     (foreach att (vlax-safearray->list
                    (vlax-variant-value
                      (vla-getAttributes blk)))
   (setq tag (vla-get-tagString att))
       (foreach x (cdr attlst)
         (if (eq tag (car x))
           (vla-put-TextString att (cadr x)))
   )
   (if(eq tag "HEAD")
     (progn
      (setq lvl (substr (vla-get-textstring att )9 2))
      (vla-put-TextString att (substr (vla-get-textstring att) 1 7))
     )
   )
   (if (eq tag "FLOOR")
     (vla-put-textstring att lvl)
   )
   ))))

8