[转帖][求助]急，急，急，哪位高手帮忙改一下，改图块颜色和层的。
<p>我只想要改图块层的功能，不想改其颜色。</p><p>(defun C:ch (/ COL SS CNT IDX BLKNAME DONELIST)<br/> (defun GRP (GCC EL) (cdr (assoc GCC EL)))<br/> (defun UPDATE (BNAME COL / ENAME ELIST)<br/> (setq ENAME (tblobjname "BLOCK" BNAME))<br/> (if<br/> (and ENAME<br/> (zerop (logand 52 (GRP 70 (entget ENAME '("*")))))<br/> )<br/> (progn<br/> (while ENAME<br/> (if (or (= "INSERT" (GRP 0 (entget ENAME)))<br/> (= "DIMENSION" (GRP 0 (entget ENAME)))<br/> )<br/> (UPDATE (GRP 2 (entget ENAME)) COL)<br/> )<br/> (setq ELIST (entget ENAME '("*"))<br/> ELIST (subst '(8 . "0") (assoc 8 ELIST) ELIST)<br/> ELIST (if (assoc 62 ELIST)<br/> (subst (cons 62 COL) (assoc 62 ELIST) ELIST)<br/> (append ELIST (list (cons 62 COL)))<br/> )<br/> )<br/> (entmod ELIST)<br/> (setq ENAME (entnext ENAME))<br/> )<br/> 't<br/> )<br/> )<br/> )<br/> (if (> (logand (GRP 70 (tblsearch "layer" "0")) 1) 0)<br/> (princ "\nLayer 0 must be thawed before running FIXBLOCK!\n"<br/> )<br/> (progn<br/> (if<br/> (progn<br/> (setq COL (acad_colordlg 7))<br/> (princ "\nPress to fix all Blocks New Color\n")<br/> (setq CNT 0<br/> SS (ssget '((0 . "INSERT,DIMENSION")))<br/> )<br/> )<br/> (progn<br/> (setq IDX (sslength SS))<br/> (while (>= (setq IDX (1- IDX)) 0)<br/> (if<br/> (not<br/> (member (setq BLKNAME (GRP 2 (entget (ssname SS IDX))))<br/> DONELIST<br/> )<br/> )<br/> (progn<br/> (if (UPDATE BLKNAME COL)<br/> (setq CNT (1+ CNT))<br/> )<br/> (setq DONELIST (cons BLKNAME DONELIST))<br/> )<br/> )<br/> )<br/> )<br/> (while (setq BLKNAME (GRP 2 (tblnext "BLOCK" (not BLKNAME))))<br/> (if (UPDATE BLKNAME COL)<br/> (setq CNT (1+ CNT))<br/> )<br/> )<br/> )<br/> (princ (strcat "\n"<br/> (itoa CNT)<br/> " block"<br/> (if (= CNT 1)<br/> ""<br/> "s"<br/> )<br/> " redefined New Color\n"<br/> )<br/> )<br/> )<br/> )<br/> (command "_.REGEN")<br/> (princ)<br/>)</p>回复：（userzhl）[转帖][求助]急，急，急，哪位高手帮...
高手都到哪去了呢？ 版主都到哪去了？ 本帖最后由 作者 于 2007-2-10 17:43:51 编辑(defun C:cc (/ *DOC blocks ss)
(vl-load-com)
(setq *DOC (vla-get-activeDocument (vlax-get-acad-object)))
(setq blocks (vla-get-blocks *Doc)) ;得到文件的块集合
(prompt "\n请选择块: ")
(if (setq ss (ssget '((0 . "INSERT"))));得到块的选择集
(change-block-layer ss) ;全部改层
)
;;(vla-regen *DOC acActiveViewPort)
(princ)
)
;;;改层函数
(defun change-block-layer (ss / i l ename elist bname blist Layer)
(setq i 0 l (sslength ss)) ;计数器清零
(while (< i l)
(setq EName (ssname ss i)) ;得到插入块图元名
(setq EList (entget EName)) ;得到插入块图元表
(setq Layer (cdr (assoc 8 Elist)));得到插入块图层
(setq BName (cdr (assoc 2 EList)));得到插入块块名
(setq BList (vla-item blocks BName));得到块内实体集合
(vlax-for n Blist
(vla-put-layer n Layer) ;对块内每个实体改变图层
)
(entupd EName) ;更新插入块图元数据
(setq i (1+ i)) ;计数器加一
)
)
不知道是不是你想要的？
;我只想要改图块层的功能，不想改其颜色。
(defun C:ch (/ 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 256); (setq COL (acad_colordlg 7))
(princ "\nPressto 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)
)
<p>好程序，我也写了两个，改天传上来</p> <p>感谢各位高手提供</p> 学习了，谢谢! 学习了 应该不错
页:
[1]