求一個將圖塊變色程序

ljs026

请问大大，可以编个程序将要变色的图块像[1 改顏色/2 改层]<1>: "这样调用吗？该怎么写呢？而当选择改顏色时会调用顏色功能表，选择改层时则调用图层管理员功能表呢？

龙龙仔

1. 变色的图块-----到底是改甚么物件的顏色??? / 改甚么物件的层???

2. 图层管理员功能表能改物件图层吗?????

ljs026

小弟的意思是要将图块变色！以下这个是我在网上下载的程序，它可以选择要改层或改色！但却必须使用接口，大大能帮我解决不用接口也可使用吗？另外当它选择改色时会跳出选择顏色的功能表，但选择改层时却得自已输入 ，可以在选择改层时也跳出功能表吗？(假设图层管理员里已有需要的图层了) ;;命令:dwgblack
;;将图中所有实体（包括块，嵌套块，尺寸中的无名块）变色
(defun #chg_color (e cnum0 cnum / tf e blkna)
(xdrx_setenttodb e)
(setq tf (xdrx_getentdxf 0))
(cond
((or
(= tf "INSERT")
(= tf "DIMENSION")
)
(setq blkna (xdrx_getentdxf 2))
(setq blkna (tblsearch "block" blkna))
(setq e (cdr (assoc -2 blkna)))
(while e
(xdrx_setenttodb e)
(setq tf (xdrx_getentdxf 0))
(if (or
(= tf "INSERT")
(= tf "DIMENSION")
)
(progn
(#chg_color e cnum0 cnum)
)
(progn
(xdrx_setenttodb e)
(xdrx_modent cnum0 cnum)
)
)
(setq e (entnext e))
)
)
(t
(xdrx_modent cnum0 cnum)
)
)
)
;;地形图处理步骤二
(defun c:dwgblack (/ ss key num num0 n e)
(xdrx_begin)
(prompt "\n请选取要变色的实体<全选>:")
(if (not (setq ss (ssget)))
(setq ss (ssget "x"))
)
(initget "1 2")
(setq key (getstring "\n[1 改顏色/2 改层]<1>: "))
(if (or (= key "1")
(= key "")
)
(progn
(setq num (acad_colordlg 7))
(setq num0 62)
)
(progn
(setq num (getstring "\n图层名称: "))
(setq num0 8)
)
)
(setq n 0)
(xdrx_setsstodb ss 0)
(xdrx_pbarbegin "已经完成:" (sslength ss))
(while (setq e (xdrx_getentdata 0))
(xdrx_pbarsetpos n)
(setq n (1+ n))
(#chg_color e num0 num)
(entupd e)
)
(xdrx_pbarend)
(setvar "osmode" 4261)
(xdrx_end)
(princ)
)

龙龙仔

你要改图块内物件or 改图块本身???

ljs026

基本上 这个程序几乎对任何物件都能修改耶，至少小弟目前试用是如此！

龙龙仔

;;不知你会多少编程???
;;dwgblack程序还不能改属性&几何公差&引线的顏色(看谁有空补上)
;;By 龙龙仔(LUCAS)
;;命令:dwgblack
;;将图中所有实体（包括块，嵌套块，尺寸中的无名块）变色
(defun #CHG_COLOR (E CNUM0 CNUM / TF E1 BLKNA)
(setq TF (DXF 0 E))
(cond
((or (= TF "INSERT")
(= TF "DIMENSION")
)
(MODENT E CNUM0 CNUM)
(setq BLKNA (DXF 2 E))
(setq BLKNA (tblsearch "block" BLKNA))
(setq E (cdr (assoc -2 BLKNA)))
(while E
(setq TF (DXF 0 E))
(if (or (= TF "INSERT")
(= TF "DIMENSION")
)
(#CHG_COLOR E CNUM0 CNUM)
(MODENT E CNUM0 CNUM)
)
(setq E (entnext E))
)
)
(t (MODENT E CNUM0 CNUM))
)
) (defun TABLE (S / D R)
(while (setq D (tblnext S (null D)))
(setq R (cons (cdr (assoc 2 D)) R))
)
) (defun SEL_LAY (/ LAY LAY1 ID)
(setq LAY (acad_strlsort (TABLE "Layer")))
(setq ID (load_dialog "lay.dcl"))
(new_dialog "lay" ID)
(start_list "lay")
(mapcar 'add_list LAY)
(end_list)
(action_tile
"lay"
"(setq lay1 (nth (atoi $value) lay))"
)
(start_dialog)
(unload_dialog ID)
LAY1
) (defun MODENT (E EE COL)
(setq E (entget E))
(if (= (assoc EE E) NIL)
(setq E (append E (list (cons EE COL))))
(setq E (subst (cons EE COL) (assoc EE E) E))
)
(entmod E)
) (defun DXF (CODE ENT) (cdr (assoc CODE (entget ENT)))) (defun C:DWGBLACK (/ SS KEY NUM NUM0 N E LEN)
(arxload "acetutil.arx" NIL)
(prompt "\n请选取要变色的实体<全选>:")
(if (not (setq SS (ssget)))
(setq SS (ssget "x"))
)
(initget "1 2")
(setq KEY (getstring "\n[1 改顏色/2 改层]<1>: "))
(if (or (= KEY "1")
(= KEY "")
)
(setq NUM (acad_colordlg 7) ; (acad_truecolordlg 7)
NUM0 62 ;真色彩很少用,程序留给你写吧!
)
(setq NUM (SEL_LAY)
NUM0 8
)
)
(setq N 0)
(acet-ui-progress "已经完成:" (setq LEN (sslength SS)))
(setq N 0)
(repeat LEN
(#CHG_COLOR (setq E (ssname SS N)) NUM0 NUM)
(entupd E)
(acet-ui-progress -1)
(setq N (1+ N))
)
(acet-ui-progress)
(princ)
) ;|
;;----lay.dcl档
lay : dialog {label="选取图层";
: list_box {
key = "lay";
height = 20;
width = 40;
fixed_width_font = true;
fixed_width = true;
}
ok_cancel;
}
|;

ljs026

为何会出现错误: no function definition: ACET-UI-PROGRESS？


不好意思！小弟一点都不会耶，因为小弟只能从网下下载一些教学文件，可遇到问题又无人解答，所以不时麻烦大大您，再从大大解答的程序中和原程序对照，以求解答，真是麻烦大大您了

龙龙仔

要配合expresstool (大部份的人都会安装----autocad 内含的工具软体) (arxload "acetutil.arx" NIL) ;;没有就不要用,修改如下 (setq N 0)
;; (acet-ui-progress "已经完成:" (setq LEN (sslength SS))) (setq LEN (sslength SS))
(setq N 0)
(repeat LEN
(#CHG_COLOR (setq E (ssname SS N)) NUM0 NUM)
(entupd E)
;; (acet-ui-progress -1)
(setq N (1+ N))
)
;;(acet-ui-progress)
(princ)
)

ljs026

请教龙大大，小弟在网上找到了个程序，但还差了一点，就符合了小弟的需求，不知大大能不能帮帮小弟改成之前小弟所希望的程序，但这个程序得先选择顏色再选择物件，不知道能否先选择物件再选择顏色或图层 (defun C:FIXBLOCK (/ COL SS CNT IDX BLKNAME DONELIST)
(defun GRP (GCC EL) (cdr (assoc GCC EL)))
(defun UPDATE (BNAME COL / ENAME ELIST)
(setq ENAME (tblobjname "BLOCK" BNAME))
(if
(and ENAME
(zerop (logand 52 (GRP 70 (entget ENAME '("*")))))
)
(progn
(while ENAME
(if (or (= "INSERT" (GRP 0 (entget ENAME)))
(= "DIMENSION" (GRP 0 (entget ENAME)))
)
(UPDATE (GRP 2 (entget ENAME)) COL)
)
(setq ELIST (entget ENAME '("*"))
ELIST (subst '(8 . "0") (assoc 8 ELIST) ELIST)
ELIST (if (assoc 62 ELIST)
(subst (cons 62 COL) (assoc 62 ELIST) ELIST)
(append ELIST (list (cons 62 COL)))
)
)
(entmod ELIST)
(setq ENAME (entnext ENAME))
)
't
)
)
)
(if (> (logand (GRP 70 (tblsearch "layer" "0")) 1) 0)
(princ "\nLayer 0 must be thawed before running FIXBLOCK!\n"
)
(progn
(if
(progn
(setq COL (acad_colordlg 7))
(princ "\nPress to fix all Blocks New Color\n")
(setq CNT 0
SS (ssget '((0 . "INSERT,DIMENSION")))
)
)
(progn
(setq IDX (sslength SS))
(while (>= (setq IDX (1- IDX)) 0)
(if
(not
(member (setq BLKNAME (GRP 2 (entget (ssname SS IDX))))
DONELIST
)
)
(progn
(if (UPDATE BLKNAME COL)
(setq CNT (1+ CNT))
)
(setq DONELIST (cons BLKNAME DONELIST))
)
)
)
)
(while (setq BLKNAME (GRP 2 (tblnext "BLOCK" (not BLKNAME))))
(if (UPDATE BLKNAME COL)
(setq CNT (1+ CNT))
)
)
)
(princ (strcat "\n"
(itoa CNT)
" block"
(if (= CNT 1)
""
"s"
)
" redefined New Color\n"
)
)
)
)
(command "_.REGEN")
(princ)
)