求一個將圖塊變色程序

ljs026 发表于 2004-8-29 01:11:00

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

龙龙仔 发表于 2004-8-30 16:35:00

1. 变色的图块-----到底是改甚么物件的顏色??? / 改甚么物件的层???<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>

2. 图层管理员功能表能改物件图层吗?????<o:p></o:p>

ljs026 发表于 2004-8-31 17:34:00

小弟的意思是要将图块变色！以下这个是我在网上下载的程序，它可以选择要改层或改色！但却必须使用接口，大大能帮我解决不用接口也可使用吗？另外当它选择改色时会跳出选择顏色的功能表，但选择改层时却得自已输入，可以在选择改层时也跳出功能表吗？(假设图层管理员里已有需要的图层了)

;;命令: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>: ")) (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) )

龙龙仔 发表于 2004-9-1 17:19:00

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

ljs026 发表于 2004-9-1 21:39:00

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

龙龙仔 发表于 2004-9-2 08:14:00

;;不知你会多少编程??? ;;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>: ")) (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 发表于 2004-9-2 16:16:00

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

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

龙龙仔 发表于 2004-9-2 17:18:00

要配合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 发表于 2004-9-3 19:49:00

请教龙大大，小弟在网上找到了个程序，但还差了一点，就符合了小弟的需求，不知大大能不能帮帮小弟改成之前小弟所希望的程序，但这个程序得先选择顏色再选择物件，不知道能否先选择物件再选择顏色或图层

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

页: [1]

明经CAD社区's Archiver

求一個將圖塊變色程序