指定属性刷（求改）

xudongchu

http://bbs.mjtd.com/forum.php?mo ... D4%CB%A2&page=1

论坛的程序！作者：77077
希望大神帮忙改一下;;;
要求:输入命令后选择参考属性块，不需要启动对话框去再勾选要刷的属性。默认下只刷 “客户名称” “模具编号” “产品编号” “产品名称”这四个属性。。
谢谢
;------------------------------------------------------------------------------------------------------------------------------
;功能：属性刷子
(vl-load-com)
(defun C:tt (/ SS ID ID2  ENTBLOCK ENTDATA I LST2 LST1 )
(if  (and (setq SS (entsel "\n点取源对象: "))
       (setq ENT (GetAttributes (car SS)))

       (SSS-MAKE-DCL ENT "d:\\test.dcl")

       (>= (setq ID (load_dialog "d:\\test.dcl")) 0)
     )
  (progn
     (setq LST1 '())
     (new_dialog "sxk_sss" ID)
     (action_tile  "Command1" "(TT1)")
     (action_tile  "Command2" "(TT2)")
     (setq ID2 (start_dialog))
    (print LST1)
     (princ "\n>>>>>>>>>>id2=")
     (princ ID2)
     (setq lst2  (mapcar '(lambda (x) (nth x ENT)) LST1))
     (setq lst2  (mapcar '(lambda (x) (cadr x)) LST2))
     (princ "\n要刷同的是:")(princ lst2)
  (if (and (= ID2 1) (> (length LST2) 0))
  (if (setq SS1 (ssget '((0 . "INSERT"))));选择目标块
    (foreach tagname LST2
      (setq value (getattvalue (car SS) tagname));取得源块tag的属性值
      (repeat
        (setq i (sslength SS1));目标块数量
        (setattvalue (ssname SS1 (setq i (1- i))) tagname value);修改目标块tag的属性值
      )
    )
  )
  )
      ;;卸载对话框文件
      (unload_dialog ID)
      (vl-file-delete  "d:\\test.dcl")
  )
    )
    (princ)
)

;;;[功能]根据ENT表，生成DCL文件
(defun SSS-MAKE-DCL  (ENT FILENAME / F1 I)
  (if  (setq F1 (open FILENAME "w"))
    (progn
      (write-line "sxk_sss: dialog\n{\n key = \"DLG_NAME\"; \nlabel = \"DM_Tools块属性刷\";" F1 )
      (write-line " :row{"                                  F1)
      (write-line ":boxed_column\n{\nlabel=\"对象特性:\";"  F1)
      (setq I 0)

      (foreach N ENT
       (progn

          (write-line (strcat  ":toggle\n{ label=\""
                               (vl-princ-to-string( Cadr N))
                               "\"" ";key = \"" (itoa I) "\";\nwidth=20;\nvalue=\"0\";"
                               "action=\"(TT" " " (itoa I) ")\";}")
                                F1 )








         (setq I (1+ I))
       )
      );;;结束foreach

      (write-line "\n}" F1);;;结束boxed_column
      (write-line " :column{"                                  F1)
      (write-line " :button{key = \"Command1\" ; label = \"全选\" ; width = 10 ;  height = 1.5 ; }" F1)
      (write-line " :button{key = \"Command2\" ; label = \"全部取消\" ; width = 10 ;  height = 1.5 ; }" F1)





      (write-line "\nok_only;" F1)
      (write-line "\n}" F1);;;column
      (write-line "\n}" F1);;;row

      (write-line "\n}" F1);;;结束dialog
      (close F1)
      t
    );;;结束progn
  );;;结束if

)


;;;action 函数
(defun TT (INT)
    (if (= $VALUE "1")

      (setq LST1 (cons INT LST1));将INT添加到表LST1
      (setq LST1 (vl-remove INT LST1))  
    )
)
;;;全选 action 函数
(defun TT1 ( / j)
(setq j 0)
(while  (<  j (length ENT ))
  (set_tile (itoa j) "1")
  (setq LST1 (cons j LST1))
  (setq j (1+ j))
)  
  )
;;;全部取消 action 函数
(defun TT2 (/ j)
(setq j 0)
(while  (<  j (length ENT ))
  (set_tile (itoa j) "0")
  (setq LST1 '())
  (setq j (1+ j))
)  
  )




;;;取得图元属性
(defun getattributes (ent / lst r)

  (while (=  (cdr (assoc 0 (setq lst (entget (setq ent (entnext ent))))))
             "ATTRIB" )

    (setq  r  (cons
                (mapcar 'cdr (mapcar 'assoc '(-1 2 1) (list lst lst lst)))
                r)
  )
  (reverse r)
)
  )

;;;取得块属性值
(defun getattvalue (entblock attname / entdata entname test value)
  (setq entname entblock test t  )
  (while (and  test   (setq entname (entnext entname))  )
    (setq entdata (entget entname))
    (cond
    ((not (= (cdr (assoc 0 entdata)) "ATTRIB"))   (setq test nil)  )
    ((= "SEQEND" (cdr (assoc 0 entdata)))         (setq test nil)  )
    ((= (cdr (assoc 2 entdata)) attname)          (setq value (cdr (assoc 1 entdata)))  )
     )
  )
  value
)

;;;getattnamelst 替换getattributes
;;;给块属性赋值
(defun setattvalue (EN ATTNAME vALUE /  szb1 E TEST ENT)
        (setq E EN          RETURN NIL          TEST t    )
    (while (and        TEST                (setq E (entnext E))           )
        (setq ENT (entget E))
        (cond
            ;;
            ((not (= (cdr (assoc 0 ENT)) "ATTRIB"))
             (setq TEST NIL)
            )
            ;;
            ((= "SEQEND" (cdr (assoc 0 ENT)))
             (setq TEST NIL)
            )
            ;;
            ((= (cdr (assoc 2 ENT)) ATTNAME )
             (setq ENT (subst        (cons 1 VALUE)  (assoc 1 ENT) ENT) )
             (entmod ENT)
             (entupd EN)
             (setq RETURN t)
            )
           ) ;_结束cond
    )
    ;;返回
    RETURN
)

start4444

(defun c:tt5 (/ entname1 entname2 lst-at value)
(setq lst-at '("客户名称"  "模具编号" "产品编号" "产品名称"));;属性块项表--随意改成需求内容
(setq ENTname1  (car (entsel "\n点取源对象: ")) ENTname2  (car (entsel "\n点取刷对象: ")))
(foreach x lst-at (setattvalue ENTname2 x (getattvalue ENTname1 x)))
(princ)       
)

;;;取得块属性值
(defun getattvalue (entblock attname / entdata entname test value)
  (setq entname entblock test t  )
  (while (and  test   (setq entname (entnext entname))  )
    (setq entdata (entget entname))
    (cond
    ((not (= (cdr (assoc 0 entdata)) "ATTRIB"))   (setq test nil)  )
    ((= "SEQEND" (cdr (assoc 0 entdata)))         (setq test nil)  )
    ((= (cdr (assoc 2 entdata)) attname)          (setq value (cdr (assoc 1 entdata)))  )
     )
  )
  value
)

;;;getattnamelst 替换getattributes
;;;给块属性赋值
(defun setattvalue (EN ATTNAME vALUE /  szb1 E TEST ENT)
        (setq E EN          RETURN NIL          TEST t    )
    (while (and        TEST                (setq E (entnext E))           )
        (setq ENT (entget E))
        (cond
            ;;
            ((not (= (cdr (assoc 0 ENT)) "ATTRIB"))
             (setq TEST NIL)
            )
            ;;
            ((= "SEQEND" (cdr (assoc 0 ENT)))
             (setq TEST NIL)
            )
            ;;
            ((= (cdr (assoc 2 ENT)) ATTNAME )
             (setq ENT (subst        (cons 1 VALUE)  (assoc 1 ENT) ENT) )
             (entmod ENT)
             (entupd EN)
             (setq RETURN t)
            )
           ) ;_结束cond
    )
    ;;返回
    RETURN
)

bai2000

加个循环更好使用一点，点选也可以改为框选的

xudongchu

start4444 发表于 2021-8-27 20:56
(defun c:tt5 (/ entname1 entname2 lst-at value)
(setq lst-at '("客户名称"  "模具编号" "产品编号" " ...

谢谢您的 答案 ，基本完全符合  如果刷取的对象可以框选就完美了

陈伟

   可以框选，一次刷多个图框

书院扫地僧

陈伟 发表于 2023-5-25 11:53
框选

error: no function definition: GETATTNAMELST  这是怎么回事?