[编程交流] 插入具有属性a的块

(defun c:test ( / *error* rb:insertblock rb:put_attributes ss->lst ss blckname )
(defun *error* ( msg )
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )
(defun rb:insertblock ( activespace blockname layer insertionpoint scale rotation vla-object / block )
 (if 
   (setq block
     (vla-insertblock activespace
       (vlax-3d-point insertionpoint)
       blockname scale scale scale rotation
     )
   )
   (progn
     (and (tblsearch "layer" layer)
       (vla-put-layer block layer)
     )
     (if vla-object
       block
       (handent (vla-get-handle block))
     )
   )
 )
)
(defun ss->lst ( ss flag / id lst )
 (if (eq 'PICKSET (type ss))
   (repeat (setq id (sslength ss))
     (
       (lambda ( name )
         (setq lst
           (cons
             (if flag (vlax-ename->vla-object name)
               name
             )lst
           )
         )
       )(ssname ss (setq id (1- id)))
     )
   )
 )
)
(defun rb:put_attributes ( block lst )
 (and (vlax-method-applicable-p block 'getattributes)
   (foreach x (vlax-invoke block 'getattributes)
     (foreach a lst
       (if 
         (eq (strcase (car a))
           (strcase (vla-get-tagstring x))
         ) (vlax-put x 'textstring (cdr a))
       )
     )
   )
 )
)
 (if 
   (and
     (or
       (and (tblsearch "block" "instrbub") (setq blckname "instrbub")) 
       (findfile "instrbub.DWG")
       (alert "Block "instrbub" is missing!")
     )
     (setq ss (ss->lst (ssget '((0 . "circle"))) t))
   )
   (progn
     (foreach x ss
       (rb:put_attributes 
         (rb:insertblock 
           (vla-get-modelspace 
             (vla-get-activedocument (vlax-get-acad-object))
           ) 
           (setq blckname 
             (cond ( blckname "wallball2" )
               ( (findfile "wallball2") )
             )
           )
           (getvar 'clayer)     ;layer
           (vlax-get x 'Center) ;location
            1.                  ;scale
            0.                  ;rotation
            t                   ;return vla-object
         )
         (list 
           (cons "tagname1"                               ;attribute tag
                 "text to add to "tagname1" attribute"  ;text for attribute
           )
           (cons 
             "tagname2"                               ;attribute tag
             "text to add to "tagname2" attribute"  ;text for attribute
           )
         )
       ) (vla-delete x)
     )
   )
 ) (princ)
)

; converts an arc to a series of straights
; next version circles
(vl-load-com)
(setq oldsnap (getvar "osmode"))
(setvar "osmode" 0)
(setq oldecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(while (setq ent (entsel "\nPick arc: "))
(setq obj (vlax-ename->vla-object (car ent)))
(if (= div nil) (setq div (getint "\nEnter number of chords: ")))
     
(setq  endpt (vlax-curve-getEndPoint obj)
    totlen (vlax-curve-getDistAtPoint obj endpt)
    arclen (/ totlen div)
    chrdpt (vlax-curve-getStartPoint obj)
    num 1     
)
(repeat div
 (setq newpt (vlax-curve-getPointatDist obj (* arclen num)))
 (command "line" chrdpt newpt "")
 (setq num (+ num 1))   
 (setq chrdpt newpt)
) ;repeat
(setq objlst (cons obj objlst))
) ; end while
;(vlax-for objdel objlst (vlax-delete  objdel))
(setvar "cmdecho" oldecho)
(setvar "osmode" oldsnap)
(princ)