选对象，按颜色分层

刘炎华 · 发表于 2023-3-4 11:18:22

请大家帮忙改成可自行选择对象，谢谢！

xyp1964 · 发表于 2023-3-4 11:18:23

刘炎华发表于 2023-3-5 20:23
还是会将所有的对象都改了，附上图档您帮忙看下

(defun c:tt ()
(princ "按对象颜色换层")
(defun Entmake-Layer(la)
(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0)
(cons 2 la)
)
)
)
(defun xyp-get-Color (s1 / co)
(if (setq co (xyp-DXF 62 s1))
co
(cdr (assoc 62 (tblsearch "layer" (xyp-DXF 8 s1))))
)
)
(defun xyp-dxf (code e) (cdr (assoc code (entget e))))
(setq i -1)
(if (setq ss (ssget))
(while (setq s1 (ssname ss (setq i (1+ i))))
(setq co(xyp-get-color s1))
(setq la (itoa co))
(Entmake-Layer la)
(vla-put-layer (vlax-ename->vla-object s1) la)
(vla-put-color (vlax-ename->vla-object s1) co)
)
)
(princ)
)

刘炎华 · 发表于 2023-3-5 07:51:37

原贴：http://bbs.mjtd.com/forum.php?mo ... hlight=%B0%B4%D1%D5
现在可以电脑上网了，贴上源码
(defun C:CN (/ *DOC *OBJ *LAY blocks layers)
(princ "按对象颜色换层")
  (vl-load-com)
  (setq *OBJ (vlax-get-acad-object))
  (setq *DOC (vla-get-activedocument *OBJ))
  (setq *LAY (vla-get-layers *DOC))             ;取得层集合
  (table)
  (setq blocks (vla-get-blocks *DOC))          ;取得塊集合
  (vlax-for block blocks          ;遍歷塊集合
(vlax-for n block          ;遍歷單個塊
   (ccb n)
)
  )
  (princ)
)
(defun ccb (object / colour laynam laycol)
  (setq colour (itoa (vla-get-color object))) ;取得物体颜色号
  (cond
( (or (= colour "256") (= colour "0"))    ;如果物体颜色随层或随块
   (setq laynam (vla-get-layer object))    ;取得物体所在层名
   (setq laycol (cdr (assoc laynam layers)))  ;取得层颜色
   (setq colour (itoa laycol))
   (ML)
)
( (ML)
   (vla-put-color object 256)                ;否则改变物体颜色为随层
)
  )
  (vla-put-layer object colour)                ;对物体改层到颜色号层
)
(defun ML (/ layobj)
  (if (not (assoc colour layers))             ;如果颜色号不在图层表中
(progn
   (setq layers (cons (cons colour laycol) layers))
                                                            ;重新构造图层表
   (setq layobj (vla-add *LAY colour)) ;创建颜色号图层
   (vla-put-color layobj colour)             ;对颜色号层赋色
)
  )
)
(defun table (/ name color Nname)
  (vlax-for n *LAY                            ;遍历层集合
(setq name (vla-get-name n))                ;取得层名
(setq color (vla-get-color n))             ;取得层颜色
(setq layers (cons (cons name color) layers));获得层名和颜色号表
(setq Nname (read name))
(if (= (type Nname) (type 1))             ;如果层名是整数
   (if (= (strlen (itoa Nname)) (strlen name))
      (if (and (> Nname 0) (< Nname 256))    ;并且>0,<256
      (if (/= color Nname)                ;如果层颜色不等于层名
         (vla-put-color n Nname)             ;则改层颜色为层名
      )
      )
   )
)
  )
)

yaojing38 · 发表于 2023-3-5 13:51:40

你试下看行不行！

xyp1964 · 发表于 2023-3-5 14:26:03

(defun c:tt ()
(defun Entmakex-Layer (lname)
(entmakex (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
(cons 2 lname)
)
)
(setvar 'clayer lname)
)
(defun xyp-get-Color (s1 / co)
(if (setq co (xyp-DXF 62 s1))
co
(cdr (assoc 62 (tblsearch "layer" (xyp-DXF 8 s1))))
)
)
(defun xyp-dxf (code e) (cdr (assoc code (entget e))))
(setq i -1)
(if (setq ss (ssget))
(while (setq s1 (ssname ss (setq i (1+ i))))
(setq la (itoa (xyp-get-color s1)))
(Entmakex-Layer la)
(vla-put-layer (vlax-ename->vla-object s1) la)
)
)
(princ)
)

刘炎华 · 发表于 2023-3-5 20:18:06

xyp1964 发表于 2023-3-5 14:26

版主，您帮我看下是哪里的问题呢？

提示：错误: AutoCAD 变量设置被拒绝: CLAYER "251"

刘炎华 · 发表于 2023-3-5 20:23:53

yaojing38 发表于 2023-3-5 13:51
你试下看行不行！

还是会将所有的对象都改了，附上图档您帮忙看下

刘炎华 · 发表于 2023-3-5 21:50:28

xyp1964 发表于 2023-3-5 20:58

谢谢版主！可以了

jcmtxgt · 发表于 2023-6-14 12:10:34

刘炎华发表于 2023-3-5 21:50
谢谢版主！可以了

请问是怎么解决的？

月下闲人 · 发表于 2023-10-27 10:56:20

xyp1964 发表于 2023-3-5 14:26

如果是块、嵌套块、外部参照该怎么办

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

[源码] 选对象，按颜色分层

最佳答案

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源