[可选择]块属性刷刷刷.
本帖最后由 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:KN (/ SS ID ID2ENTBLOCK 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" )
(setqr(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 (andtest (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天，终于能用了 fl202 发表于 2014-7-11 10:20
以下是补缺少的两个子函数：附件是经测试的完整程序，对程序稍作修改，收币一个。大家自主选择，补函数后还 ...
加一个全选功能，更方便啊 补个函数
(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)
) 看起来很牛 本帖最后由 masterlong 于 2014-3-5 13:10 编辑
不错
几点建议
1.
目标块名开关：同名块/异名块
2.
开关：全选/清空
3.
开关：默认全选/清空
4.
属性值的显示 建议楼主给全源码，谢谢了！ 很不错哦，支持 不能直接用，不知道如何调试，麻烦版主贴个完整的，谢谢！ xieyanghui 发表于 2014-3-10 06:03 static/image/common/back.gif
不能直接用，不知道如何调试，麻烦版主贴个完整的，谢谢！
好好找,论坛有人贴出过函数集,其中就包括我这里缺少的三个函数!
本来嘛也可以直接贴出来的,只是为了避免拿着程序就走人的现象,所以^^^^
见谅!
masterlong 发表于 2014-3-5 13:07 static/image/common/back.gif
不错
几点建议
1.
不错,几点建议都不错.
1.目标块名开关：同名块/异名块==>这个建议不错,我会改进的.
2.开关：全选/清空==>2.3这建议也不错,我也觉得麻烦,多谢提醒,下次改进!
3.开关：默认全选/清空
4.属性值的显示==>属性值的显示方式,只需要修改调用的GetAttributes函数即可,不需要在这些代码里面修改. 好东西，收藏了