zxj168 发表于 2012-10-17 21:37:54

求一个可以直接块里图元的图层程序

要求 就是直接块里图元的图层
( 选中块 程序让我选择我想要放到的图层 颜色 线型保持不变)
希望各位大师出手!

chpmould 发表于 2012-10-17 22:44:22

我猜LZ是想将选择块的所有图元层修改到指定层吧...

zxj168 发表于 2012-10-17 23:34:50

是呀 字打少了

xyp1964 发表于 2012-10-18 07:40:37

本帖最后由 xyp1964 于 2014-3-4 18:01 编辑




haitun518 发表于 2012-10-19 23:53:06

改换图层，含对块的处理

zxj168 发表于 2012-10-20 13:16:12

是不是这个程序很难 怎么没人出手呢？

zxj168 发表于 2012-10-20 13:17:27

还是3币少了？

USER2128 发表于 2012-10-22 09:24:11

haitun518 发表于 2012-10-19 23:53 static/image/common/back.gif
改换图层，含对块的处理

程序调试了一下，稍作了修改。
应用时请将俩文件放置于CAD可搜索的路径中。;;; changelayer.lsp
(defun getdata_ly()
(setq n1 (get_tile "oldly_list"))
(setq n2 (get_tile "newly_list"))
(setq oldlayer (nth (atoi n1) layername))
(setq newlayer (nth (atoi n2) layername))
)

(defun getdata_set()
(setq flag_cl (get_tile "change_cl"))
(setq flag_lt (get_tile "change_lt"))
(setq flag_lw (get_tile "change_lw"))
(setq flag_ly (get_tile "clean_ly"))
)

(defun setdata_set()
(set_tile "change_cl" flag_cl)
(set_tile "change_lt" flag_lt)
(set_tile "change_lw" flag_lw)
(set_tile "clean_ly"flag_ly)
)

(defun dialog_ly()
(setq flag_cl "1"
        flag_lt "1"
        flag_lw "1"
        flag_ly "1")
;(setq path (findfile "acad.exe"))
;(setq path (substr path 1 (- (strlen path) 8)))
;(setq path (strcat path "LISP\\changelayer"))
(setq path (findfile "changelayer.dcl"))
(setq id (load_dialog path))                               ;装入对话框文件
(if (< id 0) (exit))
(if (not (new_dialog "changelayer" id))(exit))             ;初始化对话框
(start_list "oldly_list")                                  ;开始处理图层列表
(mapcar 'add_list layername)
(end_list)                                                 ;图层列表处理完毕
(start_list "newly_list")                                  ;开始处理图层列表
(mapcar 'add_list layername)
(end_list)                                                 ;图层列表处理完毕
(action_tile "oldly_list" "(set_tile \"linetype1\" (viewlt $value))(set_tile \"linewidth1\" (viewlw $value))")
(action_tile "newly_list" "(set_tile \"linetype2\" (viewlt $value))(set_tile \"linewidth2\" (viewlw $value))")
(action_tile "set_ly" "(dialog_set)")
(action_tile "accept" "(getdata_ly)(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(setq std (start_dialog))
(unload_dialog id)
)

(defun viewlt(num / lst lt ltn)
(setq lst (entget (tblobjname "LAYER" (nth (atoi num) layername))))
(setq lt (cdr (assoc 6 lst)))
(setq ltn (strcat "线型:" lt))
)

(defun viewlw(num / lst lw lwn)
(setq lst (entget (tblobjname "LAYER" (nth (atoi num) layername))))
(setq lw (cdr (assoc 370 lst)))
(if (= lw -3)
    (setq lw "默认")
    (setq lw (strcat (rtos (/ lw 100.0) 2 2) "mm"))
    )
(setq lwn (strcat "线宽:" lw))
)

(defun dialog_set()
(if (not (new_dialog "setfunction" id))(exit))
(setdata_set)
(action_tile "accept" "(getdata_set)(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(start_dialog)
)

(defun change_clltlw(obj_lst)
(if (and (= flag_cl "1") (setq old_cl (assoc 62 obj_lst)));强制对象颜色ByLayer
    (progn
      (setq new_cl (cons '62 256))
      (setq obj_lst (subst new_cl old_cl obj_lst))
      (entmod obj_lst)
      )
    )
(if (and (= flag_lt "1") (setq old_lt (assoc 6 obj_lst)))   ;强制对象线型ByLayer
    (progn
      (setq new_lt (cons '6 "ByLayer"))
      (setq obj_lst (subst new_lt old_lt obj_lst))
      (entmod obj_lst)
      )
    )
(if (and (= flag_lw "1") (setq old_lw (assoc 370 obj_lst))) ;强制对象线宽ByLayer
    (progn
      (setq new_lw (cons '370 -1))
      (setq obj_lst (subst new_lw old_lw obj_lst))
      (entmod obj_lst)
      )
    )
)
;;;===============================================
;;;院长的程序（已去除其中的伪代码），留作之后的程序扩展用。
;; xyp-SS2LayerList 选择集图层表 (xyp-SS2LayerList (ssget))
(defun xyp-SS2LayerList (ss / i lst s1 la)
(setq i   -1
        lst '())
(while (setq s1 (ssname ss (setq i (1+ i))))
    (setq la (cdr (assoc 8 (entget s1))))
    (if (not (member la lst))
      (setq lst (cons la lst))
      )
    )
(vl-sort lst '<)
)
;;;===============================================
(defun change_ly()
(setq num 0)
(setq new_ly (cons '8 newlayer))                             ;构造新图层子表
(setq old_ly (cons '8 oldlayer))                             ;构造旧图层子表

;;; 选择要改变图层的图元(包括图块，但不包括块中块)
(setq old_ent (ssget "X" (list old_ly)))
(if old_ent (setq len (sslength old_ent)) (setq len 0))
(setq i 0)
(while (< i len)
    (setq ent (ssname old_ent i))                           ;得到第一个图元名
    (setq elt (entget ent))                                     ;得到一个图元表
    (setq elt (subst new_ly old_ly elt))                     ;图层替换
    (entmod elt)                                             ;回送图元表
    (change_clltlw elt)
    (setq num (1+ num))
    (setq i (1+ i))
    )

;;; 改变一般图块中的图元(包括块中块)
(setq blk_lst (tblnext "block" t))
(while blk_lst
    (setq nam_blk (cdr (assoc 2 blk_lst)))
    (if (= (substr nam_blk 1 1) "*")
      (progn
        (setq unb_ent (ssget "X" '((0 . "insert"))))
        (if unb_ent (setq len (sslength unb_ent)) (setq len 0))
        (setq i 0)
        (while (< i len)
          (setq unb_et (ssname unb_ent i))
          (setq unb_lt (entget unb_et))
          (if (= nam_blk (cdr (assoc 2 unb_lt)))
          (progn
              (command "explode" unb_et)
              (command "purge" "b" nam_blk "y" "y")
              )
          )
          (setq i (1+ i))
          )
        )
      )
    (setq blk_ent (cdr (assoc -2 blk_lst)))                  ;得到块表所含图元入口
    (while blk_ent
      (setq lst (entget blk_ent))                            ;得到图块中子图元的图元表
      (if (= oldlayer (cdr (assoc 8 lst)))                   ;判断该图元是否为要改变的图层
        (progn
          (setq lst (subst new_ly old_ly lst))               ;图层替换
          (entmod lst)                                       ;回送图元表
          )
        )
      (change_clltlw lst)
      (setq blk_ent (entnext blk_ent))
      )
    (setq blk_lst (tblnext "block"))
    )
;;; 改变属性图块中的图元
(setq int_ent (ssget "X" (list (cons '0 "INSERT"))))
(if int_ent (setq len (sslength int_ent)) (setq len 0))
(setq i 0)
(while (< i len)
    (setq int_et (ssname int_ent i))
    (setq int_et (entnext int_et))
    (if int_et
      (progn
        (setq int_lt (entget int_et))
        (if (= (cdr (assoc 0 int_lt)) "ATTRIB")
          (while (/= (cdr (assoc 0 int_lt)) "SEQEND")
          (if (= oldlayer (cdr (assoc 8 int_lt)))
              (progn
                (setq int_lt (subst new_ly old_ly int_lt))
                (entmod int_lt)
                )
              )
          (change_clltlw int_lt)
          (setq int_et (entnext int_et))
          (setq int_lt (entget int_et))
          )
          )
        )
      )
    (setq i (+ i 1))
    )

(princ "\n完成转换 ")
(princ num)
(princ " 个对象\n")
(if (= flag_ly "1") (command "purge" "la" oldlayer "n"))
(command "regenall")                                       ;重新生成
)

(defun C:changelayer()
(setvar "cmdecho" 0)                                        ;关闭命令函数运行时回显提示和输入
(setq layername '())
(setq lay_lst (tblnext "layer" t))
(while lay_lst
    (setq layername (cons (cdr (assoc 2 lay_lst)) layername))
    (setq lay_lst (tblnext "layer"))
    )
(setq layername (acad_strlsort layername))                  ;对图层名排序
(dialog_ly)
(if (and (/= newlayer oldlayer) (= std 1))
    (progn
      (princ (strcat "\n图层自: " oldlayer "\t转换到: " newlayer))
      (change_ly)
      )
    )
(princ)
)
存为文件名: changelayer.dcl//定义转换图层的对话框
changelayer:dialog{
label= "图层转换";
:row{
      :list_box
         {label="转换自";
         key="oldly_list";
         width=20;
         height=12;
         }
      :list_box
         {label="转换到";
         key="newly_list";
         width=20;
         height=12;
         }
      }
:row{
      :text{key="linetype1";width=20;value="线型:";}
      :text{key="linetype2";width=20;value="线型:";}
      }
:row{
      :text{key="linewidth1";width=20;value="线宽:";}
      :text{key="linewidth2";width=20;value="线宽:";}
      }
:row{
      :button{alignment=centered;fixed_width=true;width=10;label="设置...";key="set_ly";}
      ok_cancel;
      }
}

//定义设置的对话框
setfunction:dialog{
label= "设置";
:column{
         :toggle{label="强制对象颜色为ByLayer";key="change_cl";}
         :toggle{label="强制对象线型为ByLayer";key="change_lt";}
         :toggle{label="强制对象线宽为ByLayer";key="change_lw";}
         :toggle{label="清理多余的图层";key="clean_ly";}
         :text{label="";}
         }
ok_cancel;
}

alin 发表于 2012-10-23 10:17:37

用到dosLib，请先加载 http://download.rhino3d.com/download.asp?id=doslib


zhangzl 发表于 2012-12-31 09:49:49

好思路啊，不过具体怎么用，还要仔细考虑下，会改变好多习惯的，是恶习改掉还是成为变态
页: [1] 2
查看完整版本: 求一个可以直接块里图元的图层程序