[求助]全部按颜色分层
本帖最后由 作者 于 2007-1-7 1:02:46 编辑 <br /><br /> <p>本人经常要处理大量来自各处的图块</p><p>颜色无法统一,不方便打印</p><p>之前在论坛找到一个LISP,但是无法处理块里面的,</p><p>麻烦那个仁兄有空帮忙加工下,小弟先谢了</p><p>以下是别人做的</p><p></p><p>(defun c:hs (/ cc ss n e lay clist kk)<br/> (setq clist (list 255))<br/> (repeat 254<br/> (setq clist (cons (1- (car clist)) clist))<br/> )<br/> (foreach cc clist<br/> (if (not kk)<br/> (princ (strcat "\n搜索物体中... 颜色 " (itoa cc)))<br/> (progn<br/> (repeat kk (princ "\010"))<br/> (princ (itoa cc))<br/> )<br/> )<br/> (setq kk (strlen (itoa cc)))<br/> (setq ss (ssget "x" (list (cons 62 cc))))<br/> (if ss<br/> (progn<br/> (setq kk nil)<br/> (setq n 0)<br/> (while (setq e (ssname ss n)) ;highlight the objects<br/> (redraw e 3)<br/> (setq n (1+ n))<br/> ) ;while<br/> (setq<br/> lay (getstring<br/> (strcat "\n请为颜色为 " (itoa cc) " 的物体指定层名: ")<br/> )<br/> )<br/> (if (tblsearch "LAYER" lay)<br/> (command "chprop" ss "" "c" "bylayer" "layer" lay "")<br/> (progn<br/> (setq<br/> yn (getint<br/> "\n指定的层不存在. \n键入任意数字创建此层<跳过>: "<br/> )<br/> )<br/> (if yn<br/> (command "layer" "m" lay "c" cc ""<br/> "" "chprop" ss "" "c"<br/> "bylayer" "layer" lay ""<br/> )<br/> )<br/> ) ;progn<br/> ) ;if<br/> )<br/> ) ;if<br/> ) ;foreach<br/>) ;end </p> 能不能用框选的方法选择分层，有的不要全部 出运吧,遇个好心人 本帖最后由 作者 于 2007-1-7 19:43:06 编辑 <br /><br /> <p>这个问题的关键在于如果物体的颜色是随块的话（颜色号为"0"),不太好办，其他的都可以解决。</p><p>明天贴上一个lisp程序供讨论.</p>(defun C:ddd (/ Obj blocklist block n)
(vl-load-com)
(setq *OBJ (vlax-get-acad-object))
(setq *DOC (vla-get-activedocument *OBJ))
(setq *MSP (vla-get-modelspace *DOC))
(setq laysel (vla-get-layers *DOC))
(vlax-for obj *MSP ;取得模型空间对象集合
(ccb obj) ;遍历模型空间对象
)
(setq blocklist (vla-get-blocks *DOC));取得块集合
(vlax-for block blocklist;遍历块集合
(vlax-for n block ;遍历单个块
(ccb n)
)
)
)
(defun ccb (obj / col laynam laytab laycol layobj)
(if (and (vlax-property-available-p obj 'color)
(vlax-property-available-p obj 'layer)
)
(progn
(setq col (itoa (vla-get-color obj)))
(cond
( (= col "256")
(progn
(setq laynam (vla-get-layer obj))
(setq laytab (tblsearch "layer" laynam))
(setq laycol (itoa (cdr (assoc 62 laytab))))
(if (= (tblsearch "layer" laycol) nil)
(progn
(setq layobj (vla-add laysel laycol))
(vla-put-color layobj laycol)
)
)
(vla-put-layer obj laycol)
)
)
( (/= col "256")
(progn
(if (= (tblsearch "layer" col) nil)
(progn
(setq layobj (vla-add laysel col))
(vla-put-color layobj col)
)
)
(vla-put-layer obj col)
(vla-put-color obj 256)
)
)
)
)
)
)
上面这个程序基本能满足要求，然而：
说实在话，对于块内的情况要复杂的多，因为如果物体的颜色是随层的话，得首先确定块在哪个图层，而对于同名块可以在不同的图层；如果物体的颜色是随块的话，得确定块的颜色。最好的办法就是把图中所有插入的图块全都炸到不能再炸为止，--注仅仅针对图块而言。
<p>非常感谢版主,这个程序确实非常好用,如果各位觉得好请麻烦顶下</p><p> </p> 4樓的程序,做了很多無用的步驟! 8-( <p><font face="Verdana" color="#da2549"><font color="#000000">多谢</font><strong>龙龙仔</strong><font color="#000000">指点：</font></font></p><p><font face="Verdana">我就很纳闷为什么上面那个程序效率较低呢？也不知道哪个步骤可以去掉，望能指点！</font></p> 本帖最后由 作者 于 2007-1-10 17:18:44 编辑 <br /><br /> <p>(defun C:ddd (/ *DOC *OBJ BLOCKLIST)<br/> (vl-load-com)<br/> (setq *OBJ (vlax-get-acad-object))<br/> (setq *DOC (vla-get-activedocument *OBJ))<br/> ;;(setq *MSP (vla-get-modelspace *DOC))<br/> (setq laysel (vla-get-layers *DOC))<br/> ;;modelspace & paperspace屬圖塊的一種,所以下列程序多出來了!<br/> ;;(vlax-for obj *MSP ;取得模型空間對像集合<br/> ;; (ccb obj) ;遍歷模型空間對像<br/> ;;)<br/> (setq blocklist (vla-get-blocks *DOC)) ;取得塊集合<br/> (vlax-for block blocklist ;遍歷塊集合<br/> (vlax-for n block ;遍歷單個塊<br/> (ccb n)<br/> )<br/> )<br/> (PRINC)<br/>)<br/>(defun ccb (obj / COL LAYCOL LAYNAM LAYOBJ LAYTAB)<br/> ;;所有圖塊中物件一定有color & layer 屬性,不必check<br/> ;;(if (and (vlax-property-available-p obj 'color)<br/> ;; (vlax-property-available-p obj 'layer)<br/> ;; )<br/> ;;(progn<br/> (setq col (itoa (vla-get-color obj)))<br/> (cond<br/> ((= col "256")<br/> ;;(progn<br/> (setq laynam (vla-get-layer obj))<br/> (setq laytab (tblsearch "layer" laynam))<br/> ;;tblsearch好像比較花時間,改用別的方法吧!<br/> (setq laycol (itoa (cdr (assoc 62 laytab))))<br/> (if (= (tblsearch "layer" laycol) nil)<br/> ;;<br/> (progn<br/> (setq layobj (vla-add laysel laycol))<br/> (vla-put-color layobj laycol)<br/> )<br/> )<br/> (vla-put-layer obj laycol)<br/> ;;)<br/> )<br/> ((/= col "256")<br/> ;;(progn<br/> (if (= (tblsearch "layer" col) nil)<br/> ;;<br/> (progn<br/> (setq layobj (vla-add laysel col))<br/> (vla-put-color layobj col)<br/> )<br/> )<br/> (vla-put-layer obj col)<br/> (vla-put-color obj 256)<br/> ;;)<br/> )<br/> )<br/> ;;)<br/> ;;)<br/>)</p><p><br/></p> <p>谢谢<font face="Verdana" color="#da2549"><strong>龙龙仔</strong><font color="#000000">斑竹的指点。</font></font></p><p><font face="Verdana">其中改进我的一个陋习（受了书本的影响形成的），使我明白了一些VBA概念和方法，纠正了一些错误，</font><font face="Verdana">虽然是小小指点，但收益不小。 </font></p><p><font face="Verdana">在此致谢！</font></p> 本帖最后由 作者 于 2007-1-11 12:25:08 编辑
;;程序我改寫了一下,會快一點
(defun TABLE (S / D R)
(while (setq D (tblnext S (null D)))
(setq R (cons (cons (cdr (assoc 2 D)) (cdr (assoc 62 D)))
R
)
)
)
)
(defun C:DDDD (/ OBJ BLOCKLIST BLOCK N LST)
(vl-load-com)
(setq *OBJ (vlax-get-acad-object))
(setq *DOC (vla-get-activedocument *OBJ))
(setq LAYSEL (vla-get-layers *DOC))
(setq LST (TABLE "Layer"))
(setq BLOCKLIST (vla-get-blocks *DOC)) ;取得塊集合
(vlax-for BLOCK BLOCKLIST;遍歷塊集合
(vlax-for N BLOCK ;遍歷單個塊
(CCBB N)
)
)
(princ)
)
(defun ML ()
(if (not (assoc LAYCOL LST))
(progn
(setq LST (cons (cons LAYCOL LAYCOL) LST))
(setq LAYOBJ (vla-add LAYSEL LAYCOL))
(vla-put-color LAYOBJ LAYCOL)
)
)
)
(defun CCBB (OBJ / LAYCOL LAYNAM)
(setq LAYCOL (itoa (vla-get-color OBJ)))
(if (= LAYCOL "256")
(progn
(setq LAYNAM (vla-get-layer OBJ))
(setq LAYCOL (cdr (assoc LAYNAM LST)))
(ML)
)
(progn
(ML)
(vla-put-color OBJ 256)
)
)
(vla-put-layer OBJ LAYCOL)
)
页:
[1]
2