[可选择]块属性刷刷刷.

77077 · 发表于 2014-3-4 17:44:12

本帖最后由 77077 于 2014-3-4 21:48 编辑

此程序功能还不够完善,希望大神们来添砖加瓦,程序代码太乱,欢迎修改~~~~~
缺少的函数可以去论坛找来用.

功能演示:

源码:

;;;功能：属性刷刷刷
(vl-load-com)
(defun C:TT (/ SS ID ID2 ENT ENTBLOCK ENTDATA I 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 "BLK_SSS" ID)
(set_tile "DLG_NAME" (strcat "块属性刷刷刷-测试"))
(setq ID2 (start_dialog))
(princ "\n===id2=")
(princ ID2)
(setq lst2 (mapcar '(lambda (x) (nth x ENT)) LST1))
(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 "BLK_SSS: dialog{ key = "DLG_NAME"; label = "刷刷刷";" F1 )
(write-line ":boxed_column{label="对象特性:";" F1)
(setq I 0)
(foreach N ENT
(progn
(write-line (strcat ":toggle{ label="" (vl-princ-to-string N) ""; key = "KEY匹配" (itoa I) ""; width=20; action="(tt-01 " (itoa I) ")";value="0"; }" ) F1 )
(setq I (1+ I))
)
)
(write-line "}" F1)
(write-line "ok_only;" F1)
(write-line "}" F1)
(close F1)
t
)
)
)
;;;匹配被修改
(defun TT-01 (INT)
(if (= $VALUE "1")
(setq LST1 (cons INT LST1));将INT添加到表LST1
(setq LST1 (vl-remove INT LST1))
)
)

;;;功能：属性刷刷刷 
 (vl-load-com) 
(defun C:TT (/ SS ID ID2 ENT ENTBLOCK ENTDATA I 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 "BLK_SSS" ID) 
      (set_tile "DLG_NAME" (strcat "块属性刷刷刷-测试")) 
      (setq ID2 (start_dialog)) 
      (princ "\n===id2=") 
      (princ ID2) 
      (setq lst2 (mapcar '(lambda (x) (nth x ENT)) LST1)) 
      (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 "BLK_SSS: dialog{ key = "DLG_NAME"; label = "刷刷刷";" F1 ) 
      (write-line ":boxed_column{label="对象特性:";"  F1) 
      (setq I 0) 
      (foreach N ENT 
       (progn 
          (write-line (strcat  ":toggle{ label="" (vl-princ-to-string N) "";   key = "KEY匹配" (itoa I) ""; width=20;  action="(tt-01 " (itoa I) ")";value="0";  }" ) F1 ) 
          (setq I (1+ I)) 
       ) 
      ) 
      (write-line "}" F1) 
      (write-line "ok_only;" F1) 
      (write-line "}" F1) 
      (close F1) 
      t 
    ) 
  ) 
) 
;;;匹配  被修改 
(defun TT-01 (INT) 
    (if (= $VALUE "1") 
      (setq LST1 (cons INT LST1));将INT添加到表LST1 
      (setq LST1 (vl-remove INT LST1)) 
    ) 
)

longwaylong · 发表于 2020-11-4 00:59:04

;;;功能：属性刷子
(vl-load-com)
(defun C:KN (/ 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 = \"属性块刷子\";" 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
)

;;;功能：属性刷子 
(vl-load-com) 
(defun C:KN (/ 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 = \"属性块刷子\";" 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 
)

半懂不懂调试了3天，终于能用了

ajunseo · 发表于 2022-5-7 15:12:16

fl202 发表于 2014-7-11 10:20
以下是补缺少的两个子函数：附件是经测试的完整程序，对程序稍作修改，收币一个。大家自主选择，补函数后还 ...

加一个全选功能，更方便啊

flyfox1047 · 发表于 2014-3-4 23:54:30

补个函数

(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)
)

tianyi1230 · 发表于 2014-3-5 08:14:20

看起来很牛

masterlong · 发表于 2014-3-5 13:07:05

本帖最后由 masterlong 于 2014-3-5 13:10 编辑

不错
几点建议
1.
目标块名开关：同名块/异名块
2.
开关：全选/清空
3.
开关：默认全选/清空
4.
属性值的显示

tianyi1230 · 发表于 2014-3-5 21:16:51

建议楼主给全源码，谢谢了！

langjs · 发表于 2014-3-6 08:35:50

很不错哦，支持

xieyanghui · 发表于 2014-3-10 06:03:38

不能直接用，不知道如何调试，麻烦版主贴个完整的，谢谢！

77077 · 发表于 2014-3-10 09:32:55

xieyanghui 发表于 2014-3-10 06:03
不能直接用，不知道如何调试，麻烦版主贴个完整的，谢谢！

好好找,论坛有人贴出过函数集,其中就包括我这里缺少的三个函数!
本来嘛也可以直接贴出来的,只是为了避免拿着程序就走人的现象,所以^^^^

见谅!

77077 · 发表于 2014-3-10 09:38:14

masterlong 发表于 2014-3-5 13:07
不错
几点建议
1.

不错,几点建议都不错.
1.目标块名开关：同名块/异名块==>这个建议不错,我会改进的.
2.开关：全选/清空==>2.3这建议也不错,我也觉得麻烦,多谢提醒,下次改进!
3.开关：默认全选/清空
4.属性值的显示==>属性值的显示方式,只需要修改调用的GetAttributes函数即可,不需要在这些代码里面修改.

mj0000 · 发表于 2014-3-11 09:36:11

好东西，收藏了

账号		自动登录	找回密码
密码			注册

[源码] [可选择]块属性刷刷刷.

本帖子中包含更多资源

评分

本帖被以下淘专辑推荐: