[编程交流] 特定块/属性lisp

([color=BLUE]defun[/color] c:setattval ( [color=BLUE]/[/color] idx sel tag val )
   ([color=BLUE]if[/color] ([color=BLUE]and[/color] ([color=BLUE]setq[/color] sel ([color=BLUE]ssget[/color] [color=MAROON]"_:L"[/color] '((0 . [color=MAROON]"INSERT"[/color]) (66 . 1))))
            ([color=BLUE]/=[/color] [color=MAROON]""[/color] ([color=BLUE]setq[/color] tag ([color=BLUE]getstring[/color] [color=MAROON]"\nSpecify tag: "[/color])))
            ([color=BLUE]setq[/color] val ([color=BLUE]getstring[/color] [color=BLUE]t[/color] [color=MAROON]"\nSpecify new value: "[/color]))
       )
       ([color=BLUE]repeat[/color] ([color=BLUE]setq[/color] idx ([color=BLUE]sslength[/color] sel))
           (LM:setattributevalue ([color=BLUE]ssname[/color] sel ([color=BLUE]setq[/color] idx ([color=BLUE]1-[/color] idx))) tag val)
       )
   )
   ([color=BLUE]princ[/color])
)
[color=GREEN];; Set Attribute Value  -  Lee Mac[/color]
[color=GREEN];; Sets the value of the first attribute with the given tag found within the block, if present.[/color]
[color=GREEN];; blk - [ent] Block (Insert) Entity Name[/color]
[color=GREEN];; tag - [str] Attribute TagString[/color]
[color=GREEN];; val - [str] Attribute Value[/color]
[color=GREEN];; Returns: [str] Attribute value if successful, else nil.[/color]
([color=BLUE]defun[/color] LM:setattributevalue ( blk tag val [color=BLUE]/[/color] enx )
   ([color=BLUE]if[/color] ([color=BLUE]=[/color] [color=MAROON]"ATTRIB"[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 0 ([color=BLUE]setq[/color] enx ([color=BLUE]entget[/color] ([color=BLUE]setq[/color] blk ([color=BLUE]entnext[/color] blk)))))))
       ([color=BLUE]if[/color] ([color=BLUE]=[/color] ([color=BLUE]strcase[/color] tag) ([color=BLUE]strcase[/color] ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 2 enx))))
           ([color=BLUE]if[/color] ([color=BLUE]entmod[/color] ([color=BLUE]subst[/color] ([color=BLUE]cons[/color] 1 val) ([color=BLUE]assoc[/color] 1 enx) enx))
               ([color=BLUE]progn[/color]
                   ([color=BLUE]entupd[/color] blk)
                   val
               )
           )
           (LM:setattributevalue blk tag val)
       )
   )
)
([color=BLUE]princ[/color])

(defun c:caval ( / i p1 p2 ss blk attlst attname newval)
  (princ "\nSelect blocks :")
  (if (and (setq p1 (getpoint "\nFirst corner : ")) (setq p2 (getcorner p1 "\nSecond corner : "))
           (setq ss (ssget "c" p1 p2 (list (cons 0 "insert"))))(setq i -1))
    (while (setq blk (ssname ss (setq i (1+ i))))
      (setq attlst (append attlst (mapcar 'vla-get-tagstring (vlax-invoke (vlax-ename->vla-object blk) 'getattributes)))))
  )
  (if (and (setq attname (cfl (rdup attlst))) (setq i -1)
           (setq newval (getstring (strcat "\nNew value for attribute " attname " : "))))
    (while (setq blk (ssname ss (setq i (1+ i))))
      (vl-some '(lambda (x)(if (= attname (vla-get-tagstring x))(vla-put-textstring x newval)))
                   (vlax-invoke (vlax-ename->vla-object blk) 'getattributes)))
  ) 
)
; chose from list
(defun cfl (l / f p d r)
  (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w"))
       (princ "cfl:dialog{label="Choose";:list_box{key="lb";}ok_cancel;}" p)
       (not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)
       (progn
         (start_list "lb")(mapcar 'add_list l)(end_list)
         (action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)")
         (action_tile "accept" "(setq r (get_tile "lb"))(done_dialog 1)")
         (action_tile "cancel" "(setq r nil)(done_dialog 0)")
         (start_dialog)(unload_dialog d)(vl-file-delete f)
       )
  )
  (cond ((= r "") nil)(r r)(t nil))
)
;remove duplicates
(defun rdup ( i / o ) (vl-remove-if '(lambda (x) (cond ((vl-position x o) t) ((setq o (cons x o)) nil))) i))
; auto run when loaded
(c:caval)

(setq attlst (append attlst (mapcar 'vla-get-tagstring (vlax-invoke (vlax-ename->vla-object blk) 'getattributes))))

(defun c:setattval ( / att ent enx idx lst sel tag val )
   (if (setq sel (ssget "_:L" '((0 . "INSERT") (66 . 1))))
       (progn
           (repeat (setq idx (sslength sel))
               (setq ent (entnext (ssname sel (setq idx (1- idx))))
                     enx (entget ent)
               )
               (while (= "ATTRIB" (cdr (assoc 0 enx)))
                   (setq lst (cons (cons (strcase (cdr (assoc 2 enx))) enx) lst)
                         ent (entnext ent)
                         enx (entget  ent)
                   )
               )
           )
           (while
               (and (/= "" (setq tag (strcase (getstring "\nSpecify tag: "))))
                    (not (assoc tag lst))
               )
               (princ (strcat "\nAttribute tag "" tag "" not found in selection."))
           )
           (if (/= "" tag)
               (progn
                   (setq val (cons 1 (getstring t "\nSpecify new value: ")))
                   (while (setq att (assoc tag lst))
                       (if (entmod (subst val (assoc 1 (cdr att)) (cdr att)))
                           (entupd (cdr (assoc -1 (cdr att))))
                       )
                       (setq lst (cdr (member att lst)))
                   )
               )
           )
       )
   )
   (princ)
)