[求助]全部按颜色分层

鬼魔 · 发表于 2007-1-7 01:00

本帖最后由作者于 2007-1-7 1:02:46 编辑

本人经常要处理大量来自各处的图块

颜色无法统一,不方便打印

之前在论坛找到一个LISP,但是无法处理块里面的,

麻烦那个仁兄有空帮忙加工下,小弟先谢了

以下是别人做的

(defun c:hs (/ cc ss n e lay clist kk)
(setq clist (list 255))
(repeat 254
    (setq clist (cons (1- (car clist)) clist))
)
(foreach cc clist
    (if (not kk)
      (princ (strcat "\n搜索物体中... 颜色 " (itoa cc)))
      (progn
(repeat kk (princ "\010"))
(princ (itoa cc))
      )
    )
    (setq kk (strlen (itoa cc)))
    (setq ss (ssget "x" (list (cons 62 cc))))
    (if ss
      (progn
(setq kk nil)
(setq n 0)
(while (setq e (ssname ss n)) ;highlight the objects
   (redraw e 3)
   (setq n (1+ n))
)    ;while
(setq
   lay (getstring
  (strcat "\n请为颜色为 " (itoa cc) " 的物体指定层名: ")
       )
)
(if (tblsearch "LAYER" lay)
   (command "chprop" ss "" "c" "bylayer" "layer" lay "")
   (progn
     (setq
       yn (getint
     "\n指定的层不存在. \n键入任意数字创建此层<跳过>: "
   )
     )
     (if yn
       (command "layer" "m"     lay     "c"     cc      ""
         ""      "chprop"        ss      ""      "c"
         "bylayer"       "layer" lay     ""
        )
     )
   )    ;progn
)    ;if
      )
    )     ;if
)     ;foreach
)     ;end

q274592467 · 发表于 2016-10-21 14:04

能不能用框选的方法选择分层，有的不要全部

鬼魔 · 发表于 2007-1-7 17:42

出运吧,遇个好心人

highflybir · 发表于 2007-1-7 19:42

本帖最后由作者于 2007-1-7 19:43:06 编辑

这个问题的关键在于如果物体的颜色是随块的话（颜色号为"0"),不太好办，其他的都可以解决。

明天贴上一个lisp程序供讨论.

highflybir · 发表于 2007-1-8 17:30

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

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

上面这个程序基本能满足要求，然而：
说实在话，对于块内的情况要复杂的多，因为如果物体的颜色是随层的话，得首先确定块在哪个图层，而对于同名块可以在不同的图层；如果物体的颜色是随块的话，得确定块的颜色。最好的办法就是把图中所有插入的图块全都炸到不能再炸为止，--注仅仅针对图块而言。

鬼魔 · 发表于 2007-1-8 21:36

非常感谢版主,这个程序确实非常好用,如果各位觉得好请麻烦顶下

龙龙仔 · 发表于 2007-1-10 12:48

4樓的程序,做了很多無用的步驟! 8-(

highflybir · 发表于 2007-1-10 14:10

多谢龙龙仔指点：

我就很纳闷为什么上面那个程序效率较低呢？也不知道哪个步骤可以去掉，望能指点！

龙龙仔 · 发表于 2007-1-10 16:55

本帖最后由作者于 2007-1-10 17:18:44 编辑

(defun C:ddd (/ *DOC *OBJ BLOCKLIST)
(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))
;;modelspace & paperspace屬圖塊的一種,所以下列程序多出來了!
;;(vlax-for obj *MSP  ;取得模型空間對像集合
;; (ccb obj)    ;遍歷模型空間對像
;;)
(setq blocklist (vla-get-blocks *DOC)) ;取得塊集合
(vlax-for block blocklist  ;遍歷塊集合
    (vlax-for n block   ;遍歷單個塊
      (ccb n)
    )
)
(PRINC)
)
(defun ccb (obj / COL LAYCOL LAYNAM LAYOBJ LAYTAB)
;;所有圖塊中物件一定有color & layer 屬性,不必check
;;(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))
     ;;tblsearch好像比較花時間,改用別的方法吧!
     (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)
     ;;)
    )
)
;;)
;;)
)

highflybir · 发表于 2007-1-10 17:41

谢谢龙龙仔斑竹的指点。

其中改进我的一个陋习（受了书本的影响形成的），使我明白了一些VBA概念和方法，纠正了一些错误，虽然是小小指点，但收益不小。　

在此致谢！

龙龙仔 · 发表于 2007-1-11 07:53

本帖最后由作者于 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)
)

;;程序我改寫了一下,會快一點 
(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)
)

账号		自动登录	找回密码
密码			注册

[求助]全部按颜色分层

浏览过的版块