图层合并

tianyi1230 · 发表于 2013-7-17 21:10:45

我也有此情况，同楼上，

st788796 · 发表于 2013-7-17 21:30:21

既然有源码了，大家一起捉捉虫，能耐心看完的一定了不起！

qqqincccken · 发表于 2013-7-17 21:59:52

看看是咋用的,谢谢前辈了

bagu · 发表于 2013-8-4 18:31:21

求知若渴呀

张和平 · 发表于 2013-8-9 12:41:18

一直在用这个程序，之前对比过很多个，这个是最彻底的。。

张和平 · 发表于 2013-8-15 09:15:49

终于可以来看这个帖子了，，，

flowerson · 发表于 2013-8-15 19:26:06

本帖最后由 flowerson 于 2013-8-15 19:45 编辑

;by eachy ;flowerson 修改
(vl-load-com)
(if (>= (atof (getvar "acadver")) 16.0)
(vl-arx-import "acapp.arx")
(vl-arx-import "acadapp.arx")
)
;|
全局变量
nlyr 新图层
llyr 转换列表
name 图层列表
fillc 新图层颜色
tf 保留颜色 "1" 保留 "0" 不保留
tf1 保留线形 "1" 保留 "0" 不保留
ltf 忽略块内0层 "1" 忽略 "0" 修改
|;
(defun c:Lyrt (/ ea:string_parse ea:string_unparse
ea:pross ea:get-utime RGBtoOLE_color
OLEtoRGB_color RGBtoACI
ea:getcecolor ea:chglyrcolor
ea:translyr ea:chgcolor ea:fillcolor
ea:pre ea:table getsslyr
myerr mknewlyr ea:clearcset
thisdrawing blocks layers
name nullss olderr
ltf nlyr llyr
fillc tf tf1
_$ver _ealyrtr_id what_next
oAcad x tmp bn
)
;|(if (or (> (atoi (rtos (getvar "cdate") 2 0)) 20041231)
(< (atoi (rtos (getvar "cdate") 2 0)) 20040906)
)
(vla-eval
(vlax-get-acad-object)
(strcat
"MsgBox "\nAuthor: Eachy\n\nhttp:\\\\www.xdcad.net""
", "
"vbExclamation+vbSystemModal"
", "
""Layer Merge V2.3 ""
)
) ;_ end eval
) ;_ end if|;
(defun ea:table (s / d r)
(while (setq d (tblnext s (null d)))
(setq r (cons (cdr (assoc 2 d)) r))
)
(acad_strlsort (reverse r))
)
(defun ea:string_parse (str delimiter / post strlst)
(if str
(progn
(setq strlst '())
(while (vl-string-search delimiter str)
(setq post (vl-string-search delimiter str))
(setq strlst (append strlst (list (substr str 1 post))))
(setq str (substr str (+ post 2)))
)
(vl-remove "" (append strlst (list str)))
)
) ;_ end if
) ;_ end defun ea:string_pase
(defun ea:string_unparse (lst delimiter / return)
(setq return "")
(foreach str lst
(setq return (strcat return delimiter str))
)
(substr return 2)
)
;;一个在状态条显示处理进度的函数
;; k 数 l 长度
(defun Ea:pross (k l)
(grtext -2
(strcat "已完成"
(rtos (/ (* 100.0 k) l)
2
0
)
"%...."
)
)
)
(defun ea:get-utime ()
(* 86400 (getvar "tdusrtimer"))
)
;; Convert a list of RGB to TrueColor
;; (RGBtoOLE_color '(118 118 118))
(defun RGBtoOLE_color (RGB-codes / r g b)
(setq r (lsh (car RGB-codes) 16))
(setq g (lsh (cadr RGB-codes) 8))
(setq b (caddr RGB-codes))
(+ (+ r g) b)
)
;;Truecolor -> rgb
(defun OLEtoRGB_color (OLE_color / r g b)
(setq r (lsh OLE_color -16))
(setq g (lsh (lsh OLE_color 16) -24))
(setq b (lsh (lsh OLE_color 24) -24))
(strcat "RGB:"
(vl-princ-to-string r)
","
(vl-princ-to-string g)
","
(vl-princ-to-string b) ;(list r g b))
)
)
;;
(defun RGBtoACI (RGB-codes / colorobj)
(setq
ColorObj (vla-GetInterfaceObject oAcad "AutoCAD.AcCmColor.16")
)
(vlax-invoke
ColorObj
'setRGB
(car RGB-codes)
(cadr RGB-codes)
(caddr RGB-codes)
)
(vlax-get-property ColorObj 'ColorIndex)
)
(defun ea:Clearcset (/ cset)
(if (not (vl-catch-all-error-p
(setq cset
(vl-catch-all-apply
'vla-item
(list
(vla-get-selectionsets thisdrawing)
"CURRENT"
)
)
)
)
)
(vla-delete cset)
)
(princ)
)
;;**************************************************************************
;;转换主程序
(defun ea:translyr (/ ea:chg_layer_color_ltyp_0 ea:chgattblk
ea:chg_ssget_blockdef
ea:chg_not_ssget_blockdef llyrc
lt t0 nl
filter cset l
n s sl
t1 blst ll
lt x nllyr
0colorobj 0_in e0 all_0 nn tmp
)
;;修改实体 mark 0 层实体块内/非块内标志, 如果 0 不在llyr中，块内 0 层仅涉及颜色
(defun ea:chg_layer_color_ltyp_0 (obj mark / alyr cl colobj olt)
;;处理块内 object 及属性
(if (/= (cdr (assoc
0
(entget
(vlax-vla-object->ename
obj
)
)
)
)
"ACAD_PROXY_ENTITY"
) ;_ 排除代理实体
(progn
(setq alyr (vla-get-layer obj))
;;保存实体原始特性
(if _$ver
(progn
(setq colobj (vla-get-truecolor obj)
cl (vla-get-colorindex colobj )
)
(if (= cl 256) ;_ bylayer
(setq colobj (cdr (assoc alyr llyrc)))
)
) ;_ 2004/2005 特性
(if (= (setq cl (vla-get-color obj )) 256)
(setq cl (cdr (assoc alyr llyrc)))
)
)
;;修改图层
(if (and (/= alyr nlyr)
(not (and mark (= alyr "0") (= ltf "1")))
) ;_ 只有忽略块内 0 时不改图层
(vla-put-layer obj nlyr)
) ;_ end if
;;恢复颜色
(if (= tf "1") ;_ 保留
(cond
((and mark
(= alyr "0") ;_ 0 层实体
(= cl 256) ;_ bylayer
)
(if _$ver
(progn
(vla-put-colorindex colobj acByblock) ;_ 只有块内实体才需要改
(vla-put-truecolor obj ' colobj)
)
(vla-put-color obj 0)
) ;_ byblock
)
((and (/= alyr nlyr) (= cl 256)) ;_ bylayer 非0层实体
(if _$ver
;;取图层颜色
(vla-put-truecolor obj colobj)
(vla-put-color obj cl)
) ;_ end if
)
(t)
) ;_ end cond
;;不保留颜色
(if (and _$ver
(/= cl 256)
)
(progn
(vla-put-colorindex colobj 256);_ bylayer
(vla-put-truecolor obj colobj)
)
(vla-put-color obj 256)
)
) ;_end if
;;不保留线形
(if (= tf1 "1")
(if (and (= (setq olt (vla-get-linetype obj ))
"BYLAYER"
)
(/= olt "BYBLOCK")
(vlax-property-available-p obj 'linetype t)
)
(vlax-put-property obj 'linetype (cdr (assoc alyr lt)))
)
(if (and (/= (vla-get-linetype obj ) "BYLAYER")
(vlax-property-available-p obj 'linetype t)
)
(vla-put-linetype obj ' "BYLAYER")
)
) ;_ end if
) ;_ end progn
) ;_ end progn (if)
) ;_ end defun ea:chg_color_ltyp_0
;;修改属性块的属性实体及SEQEND, 属性只能是最外层, mark 块内/非块内标志
(defun ea:ChgAttBlk (blk mark / seqent attlst)
(setq attlst (vlax-safearray->list
(vlax-variant-value (vla-getattributes blk))
)
)
(mapcar '(lambda (x)
(if (vl-position (vla-get-layer x ) llyr)
(ea:chg_layer_color_ltyp_0 x mark)
)
)
attlst
)
(if (vl-position
(vlax-get-property
(setq
seqent (vlax-ename->vla-object
(entnext
(vlax-vla-object->ename (last attlst))
)
)
)
'layer
)
llyr
)
(vlax-put-property seqent 'layer nlyr)
) ;_ 修改 SEQEND 实体
(if (and (= tf1 "0")
(/= (vla-get-linetype seqent ) "BYLAYER")
)
(vla-put-linetype seqent "BYLAYER")
)
) ;_end defun ea:chgattblk
;;**************************************************************************************
;;主程序
(if (and (/= llyr "") (/= nlyr ""))
(progn
(if (not blocks)
(setq blocks (vla-get-blocks thisdrawing ))
)
(if (not layers)
(setq layers (vla-get-layers thisdrawing ))
)
(setq t0 (ea:get-utime))
(if (not (tblsearch "layer" nlyr))
(vla-add layers nlyr)
)
;;(vla-startundomark thisdrawing)
(vlax-map-collection
layers
'(lambda (x) (vla-put-lock x :vlax-false))
)
;;有一种颜色无法保留
(setq nl (mapcar 'atoi (ea:string_parse llyr " "))
filter (ea:string_unparse
(setq llyr (mapcar '(lambda (x) (nth x name)) nl))
","
)
) ;_end setq
(if (not (vl-position "0" llyr))
(setq nllyr (append llyr '("0")))
(setq nllyr llyr)
)
(setq l (vla-get-count blocks ))
(if (= tf "1") ;_ 保留颜色时提取对应的颜色列表
(setq llyrc
(mapcar
'(lambda (x / col mod bkname)
(if _$ver
(cons x (vla-get-truecolor (vla-item layers x) ))
(cons x (cdr (assoc 62 (tblsearch "layer" x))))
) ;_ end if
) ;_ end lambda
(if (not (vl-position nlyr nllyr))
(append (list nlyr) nllyr)
nllyr
)
) ;_end mapcar
) ;_ end setq
) ;_ end if
(if (= tf1 "1")
(setq lt
(mapcar '(lambda (x)
(cons x (cdr (assoc 6 (tblsearch "layer" x))))
)
(if (not (vl-position nlyr nllyr))
(append (list nlyr) nllyr)
nllyr
)
)
)
)
;;处理实体
(ea:clearcset)
(if (ssget "x"
(list '(-4 . "<or")
'(66 . 1)
'(-4 . "<and")
(cons 8 filter)
'(-4 . "<not")
'(0 . "ACAD_PROXY_ENTITY")
'(-4 . "not>")
'(-4 . "and>")
'(-4 . "or>")
)
) ;_ end ssget
(progn
(setq l (+ l
(vlax-get-property
(setq cset (vla-get-activeselectionset
thisdrawing
)
)
'count
)
)
n 1
)
(vlax-map-collection
cset
'(lambda (x / bbn)
(Ea:pross n l)
(cond
((= (vla-get-objectname x ) "AcDbBlockReference")
(if (vl-position (vla-get-layer x) llyr)
(progn
(ea:chg_layer_color_ltyp_0 x nil)
(if (not blst)
(setq blst
(list (setq
bbn (vla-get-name x )
)
)
)
(if (not (vl-position
(setq
bbn (vla-get-name x)
)
blst
)
)
(setq blst (append blst (list bbn)))
)
) ;_ 只记录了最外层块
)
)
(if (= (vla-get-hasattributes x) :vlax-true)
(ea:chgattblk x nil)
)
)
(t (ea:chg_layer_color_ltyp_0 x nil))
)
(setq n (1+ n))
)
)
) ;_ while
) ;_ end progn
;;修改图块定义, 保留颜色仅涉及块内 Bylayer 0 层是否改为 acByblock
(vlax-map-collection
(vlax-get-property thisdrawing 'blocks)
'(lambda (i / bn e tmp)
(if
(and
(setq bn (strcase (vlax-get-property i 'name)))
(not (wcmatch bn "`**_SPAC*"))
(/= (vla-get-count i) 0)
)
;;(vlax-map-collection
(if (vl-position bn blst);_ in ssget block
(vlax-map-collection
i
'(lambda (e / etyp lay bbn)
(setq etyp (vla-get-objectname e)
lay (vla-get-layer e)
)
(cond
((and (wcmatch etyp "*Block*")
(not (vl-position
(strcase (vla-get-name e))
blst
)
)
(vl-position lay llyr)
)
(if (not 0_in)
(setq 0_in (list (vla-get-name e)))
(if (not (vl-position
(setq bbn (vla-get-name e))
0_in
)
)
(setq 0_in (append (list bbn) 0_in))
)
)
(ea:chg_layer_color_ltyp_0 e t)
(if (= (vlax-get-property e 'hasattributes)
:vlax-true
)
(ea:chgattblk e t)
)
)
((vl-position lay llyr)
(ea:chg_layer_color_ltyp_0 e t)
)
(t)
)
)
) ;_ end vlax-map-collection
(vlax-map-collection ;_ not in ssget 但可能在 blst 引用内(0_in)
i
'(lambda (e / etyp lay)
(setq etyp (vla-get-objectname e)
lay (vla-get-layer e)
)
(cond
((vl-position lay llyr)
(cond
((wcmatch etyp "*Block*")
(ea:chg_layer_color_ltyp_0 e t)
(if (not (vl-position
(strcase (vla-get-name e))
blst
)
)
(if (not 0_in)
(setq 0_in (list (vla-get-name e)))
(if
(not (vl-position
(setq bbn (vla-get-name e))
0_in
)
)
(setq
0_in (append (list bbn) 0_in)
)
)
)
)
(if
(= (vlax-get-property e 'hasattributes)
:vlax-true
)
(ea:chgattblk e t)
)
)
((/= lay "0")
(ea:chg_layer_color_ltyp_0 e t)
)
(t)
)
)
((and (= lay "0") ;_ 仅保留 0 层实体
(not (vl-position lay llyr))
)
(if (not 0_in)
(setq 0_in (list bn))
(if (not (vl-position bn 0_in))
(setq
0_in (append (list bn) 0_in)
)
)
)
(setq nn (read bn)
tmp (eval nn)
)
(if (not tmp)
(set nn (list e))
(set nn (cons e tmp))
)
) ;_ end if
(t)
);_ end if
);_ end lambda
) ;_ end vlax-map-collection
) ;_ end if
) ;_ end if
) ;_ end lambda
) ;_ 结束处理块定义
;;处理被非选择图块且被引用并在 llyr 图层之块定义内的 0 实体
(if 0_in
(progn
(setq 0colorobj (vla-get-truecolor (vla-item layers"0")))
(vla-put-colorindex 0colorobj acByblock)
(mapcar
'(lambda (x / 0lst)
(if (not (setq 0lst (eval (read x))))
(mapcar '(lambda (e0)
(if _$ver
(vla-put-truecolor e0 0colorobj)
(vla-put-color e0 0)
)
)
olst
)
)
)
0_in
)
)
)
(setvar "clayer" "0")
(vla-purgeall thisdrawing)
;;更新块引用
(if (setq s (ssget "x" (list (cons 8 nlyr) '(0 . "INSERT"))))
(progn
(setq sl (sslength s))
(while (> sl 0)
(entupd (ssname s (setq sl (1- sl))))
)
) ;_ end progn
) ;_ end if
;;(vla-endundomark thisdrawing)
(setq llyr nil
name (ea:table "layer")
blocks (vlax-get-property thisdrawing 'blocks)
layers (vlax-get-property thisdrawing 'layers)
)
(if fillc
(progn
(setq ll (entget (tblobjname "layer" nlyr))
ll (vl-remove-if
'(lambda (x)
(vl-position (car x) '(62 420 430)))
ll
)
)
(entmod (append ll fillc))
)
)
(if t0
(progn
(setq t1 (ea:get-utime))
(princ
(strcat "\n成功转换至 " nlyr " 图层, 耗时(secs): ")
)
(princ (- t1 t0))
)
)
(if all_0 (mapcar '(lambda (x) (set x nil)) all_0))
) ;_ end progn
) ;_end if
) ;_ end dufun ea:translyr
;;预览
(defun ea:pre (/ nl layers str)
(if (and (/= llyr nil) (/= llyr ""))
(progn
(vla-startundomark thisdrawing)
(setq nl (mapcar 'atoi (ea:string_parse llyr " "))
nl (mapcar '(lambda (x) (nth x name)) nl)
)
(vlax-map-collection
(vlax-get-property thisdrawing 'layers)
'(lambda (l)
(if (vl-position (vlax-get-property l 'name) nl)
(progn
(if (= (vlax-get-property l 'layeron) :vlax-false)
(vlax-put-property l 'layeron :vlax-true)
)
(if (= (vlax-get-property l 'freeze) :vlax-true)
(vlax-put-property l 'freeze :vlax-false)
)
)
(vlax-put-property l 'layeron :vlax-false)
)
)
)
(vla-endundomark thisdrawing)
(setq str (getstring "\n回车退出...."))
(vl-cmdf ".u")
)
) ;_end if
(princ)
) ;_ end defun ea:per
;;选择合并实体, 支持嵌套在块内图层?
(defun getssLyr (/ ss ssl lyr slyr slst)
(princ "\n选择要合并图层实体<退出>...")
(if (setq ss (ssget))
(progn
(setq ssl (sslength ss))
(while (> ssl 0)
(setq
lyr
(cdr (assoc 8 (entget (ssname ss (setq ssl (1- ssl))))))
)
(if slyr
(if (not (vl-position lyr slyr))
(setq slyr (cons lyr slyr))
)
(setq slyr (list lyr))
)
) ;_ end while
(setq slst (mapcar '(lambda (l) (vl-position l name))
slyr
)
)
(if llyr
(setq slst
(append slst (mapcar 'atoi (ea:string_parse llyr " ")))
)
)
(setq llyr (ea:string_unparse
(mapcar 'vl-princ-to-string
(vl-sort slst '<)
)
" "
)
)
) ;_ end progn
) ;_ end if
) ;_ end dufun
;;获取当前颜色 l 层
(defun ea:getcecolor (l / color el inc tc dc le)
(if (not l)
(progn
(setq color (getvar "cecolor"))
(cond
((= (type (read color)) 'INT);_ ACI
(list (cons 62 (read color)))
)
((wcmatch color "RGB:*");_ truecolor
(setq inc
(RGBtoACI
(setq
tc
(mapcar
'atoi
(ea:string_parse (vl-string-trim "RGB:" color) ",")
)
)
)
)
(list (cons 62 inc) (cons 420 (RGBtoOLE_color tc)))
)
((= color "BYLAYER")
(setq el (entget (tblobjname "layer" (getvar "clayer")))
inc (assoc 62 el)
tc (assoc 420 el)
dc (assoc 430 el)
)
(cond
(dc (list inc tc dc))
(tc (list inc tc))
(t (list inc))
)
)
((= color "BYBLOCK")
(setq color '(62 . 7))
)
);_ end cond
);_ end progn
(if (setq le (tblobjname "layer" l))
(progn
(setq el (entget le)
inc (assoc 62 el)
tc (assoc 420 el)
dc (assoc 430 el)
)
(cond
(dc (list inc tc dc))
(tc (list inc tc))
(t (list inc))
)
)
(ea:getcecolor nil)
)
)
) ;_ end defun ea:getcecolor
;;填充默认颜色
(defun ea:fillcolor (/ cc width height cl)
(cond
(fillc ;acad_colordlg
(setq cc (abs (cdar fillc)))
)
(nlyr
(setq cc (abs (cdar (ea:getcecolor nlyr))))
)
(t
(setq cc (abs (cdar (ea:getcecolor nil))))
)
)
(setq width (dimx_tile "col")
height (dimy_tile "col")
)
(start_image "col")
(fill_image 0 0 width height cc) ;1 = AutoCAD red.
(end_image)
) ;_ end defun
;;修改颜色按钮
(defun ea:chgcolor (/ c l)
(setq c (ea:getcecolor nlyr))
(setq fillc (if _$ver
(cond
((= (setq l (length c)) 1);_ aci
(acad_truecolordlg (cdar c))
)
((= l 2);_ truecolor
(acad_truecolordlg (cadr c))
)
(t (acad_truecolordlg (last c)));_ dict
)
(acad_colordlg (car c))
)
) ;_ end setq
) ;_ end defun
(defun myerr (msg /)
(if (or (/= msg "*函数已取消*")
(= msg "*函数已取消*")
)
(princ "\n*取消*")
)
(if 0_in
(mapcar '(lambda (x) (set (read x) nil)) 0_in)
)
(setq 0_in nil)
(vla-endundomark thisdrawing)
(setq *error* olderr)
(princ)
) ;_end deufn
;;***********************************************************
;;主程序
(setq oAcad (vlax-get-acad-object)
thisdrawing (vlax-get-property oAcad 'activedocument)
_$ver (> (atof (getvar "acadver")) 16.)
olderr *error*
*error* myerr
)
(vla-startundomark thisdrawing)
(if (setq nullss (ssget "x" '((0 . "*text") (1 . ""))))
(vl-cmdf ".erase" nullss "")
)
;(vla-purgeall thisdrawing)
(if (not _ealyrtr_id)
(setq _ealyrtr_id (load_dialog "lyrtr.dcl"))
)
(setq what_next 2)
(while (>= what_next 2)
(if (not name)
(setq name (ea:table "layer"))
)
(if (not (new_dialog "ea_lyrtrans" _ealyrtr_id))
(exit)
)
(start_list "what")
(mapcar 'add_list name)
(end_list)
(start_list "Sel")
(mapcar 'add_list name)
(end_list)
(if llyr
(set_tile "what" llyr)
)
(if (and (/= nlyr "") nlyr)
(set_tile "Nlyr" nlyr)
)
(ea:fillcolor)
(if tf
(set_tile "color" tf)
)
(if tf1
(set_tile "ltyp" tf1)
)
(action_tile
"Trans"
(strcat
"(princ "\n请稍候，处理进行中.....")"
"(setq nlyr (get_tile "Nlyr"))"
"(setq llyr (get_tile "what"))"
"(setq tf (get_tile "color"))"
"(setq tf1 (get_tile "ltyp"))"
"(setq ltf (get_tile "lay"))"
"(done_dialog 4)"
)
)
(action_tile "accept" "(done_dialog 1)")
(action_tile "lay" "(setq ltf $value)")
(action_tile "Nlyr" "(setq nlyr $value)")
(action_tile "color" "(setq tf $value)")
(action_tile "ltyp" "(setq tf1 $value)")
(action_tile
"col"
"(setq nlyr (get_tile "Nlyr"))(ea:chgcolor)(ea:fillcolor)(if fillc(set_tile "color" "0"))"
)
(action_tile
"Sel"
"(set_tile "Nlyr" (nth (atoi $value) name))"
)
(action_tile
"pre"
"(setq nlyr (get_tile "Nlyr"))(setq llyr (get_tile "what")) (done_dialog 5)"
)
(action_tile
"list"
"(setq llyr (get_tile "what"))(done_dialog 6)"
)
(action_tile
"what"
(strcat
"(setq nlyr (get_tile "Nlyr"))"
"(setq llyr $value)"
"(if (= $reason 4)(progn (setq nlyr (get_tile "Nlyr"))(setq llyr $value)(done_dialog 5)))" ;_ double click
)
)
(setq what_next (start_dialog))
(cond
((= what_next 4)
(ea:translyr)
)
((= what_next 5)
(ea:pre)
)
((= what_next 6)
(getsslyr)
)
)
) ;_end while
(unload_dialog _ealyrtr_id)
(vla-endundomark thisdrawing)
(vlax-release-object thisdrawing)
(vlax-release-object oAcad)
(if blocks (vlax-release-object blocks))
(if layers (vlax-release-object layers))
(if 0_in (mapcar '(lambda (x) (set (read x) nil)) 0_in))
(setq 0_in nil)
(setq *error* olderr)
(princ)
) ;_end defun
(princ
"\n\t图层合并V2.3, 命令: Lyrt. BY eachy[www.xdcad.net]"
)
(princ)

;by eachy ;flowerson 修改 
(vl-load-com) 
(if (>= (atof (getvar "acadver")) 16.0) 
  (vl-arx-import "acapp.arx") 
  (vl-arx-import "acadapp.arx") 
) 
 ;| 
全局变量 
    nlyr  新图层 
    llyr  转换列表 
    name  图层列表 
    fillc 新图层颜色 
    tf    保留颜色     "1" 保留 "0" 不保留 
    tf1   保留线形     "1" 保留 "0" 不保留 
    ltf   忽略块内0层  "1" 忽略 "0" 修改 
|; 
(defun c:Lyrt (/ ea:string_parse      ea:string_unparse 
   ea:pross      ea:get-utime  RGBtoOLE_color 
   OLEtoRGB_color       RGBtoACI 
   ea:getcecolor ea:chglyrcolor 
   ea:translyr   ea:chgcolor   ea:fillcolor 
   ea:pre        ea:table      getsslyr 
   myerr        mknewlyr      ea:clearcset 
   thisdrawing   blocks      layers 
   name        nullss      olderr 
   ltf        nlyr      llyr 
   fillc        tf      tf1 
   _$ver        _ealyrtr_id   what_next 
   oAcad        x  tmp bn 
  ) 
  ;|(if (or (> (atoi (rtos (getvar "cdate") 2 0)) 20041231) 
   (< (atoi (rtos (getvar "cdate") 2 0)) 20040906) 
      ) 
    (vla-eval 
      (vlax-get-acad-object) 
      (strcat 
 "MsgBox "\nAuthor: Eachy\n\nhttp:\\\\www.xdcad.net"" 
 ", " 
 "vbExclamation+vbSystemModal" 
 ", " 
 ""Layer Merge V2.3 "" 
       ) 
    ) ;_ end eval 
  ) ;_ end if|; 
  (defun ea:table (s / d r) 
    (while (setq d (tblnext s (null d))) 
      (setq r (cons (cdr (assoc 2 d)) r)) 
    ) 
    (acad_strlsort (reverse r)) 
  ) 
  (defun ea:string_parse (str delimiter / post strlst) 
    (if str 
      (progn 
 (setq strlst '()) 
 (while (vl-string-search delimiter str) 
   (setq post (vl-string-search delimiter str)) 
   (setq strlst (append strlst (list (substr str 1 post)))) 
   (setq str (substr str (+ post 2))) 
 ) 
 (vl-remove "" (append strlst (list str))) 
      ) 
    ) ;_ end if 
  ) ;_ end defun ea:string_pase 
  (defun ea:string_unparse (lst delimiter / return) 
    (setq return "") 
    (foreach str lst 
      (setq return (strcat return delimiter str)) 
    ) 
    (substr return 2) 
  ) 
  ;;一个在状态条显示处理进度的函数 
  ;; k 数 l 长度 
  (defun Ea:pross (k l) 
    (grtext -2 
     (strcat "已完成" 
      (rtos (/ (* 100.0 k) l) 
     2 
     0 
      ) 
      "%...." 
     ) 
    ) 
  ) 
  (defun ea:get-utime () 
    (* 86400 (getvar "tdusrtimer")) 
  ) 
  ;; Convert a list of RGB to TrueColor 
  ;; (RGBtoOLE_color '(118 118 118)) 
  (defun RGBtoOLE_color (RGB-codes / r g b) 
    (setq r (lsh (car RGB-codes) 16)) 
    (setq g (lsh (cadr RGB-codes) 8)) 
    (setq b (caddr RGB-codes)) 
    (+ (+ r g) b) 
  ) 
  ;;Truecolor -> rgb 
  (defun OLEtoRGB_color (OLE_color / r g b) 
    (setq r (lsh OLE_color -16)) 
    (setq g (lsh (lsh OLE_color 16) -24)) 
    (setq b (lsh (lsh OLE_color 24) -24)) 
    (strcat "RGB:" 
     (vl-princ-to-string r) 
     "," 
     (vl-princ-to-string g) 
     "," 
     (vl-princ-to-string b) ;(list r g b)) 
    ) 
  ) 
  ;; 
  (defun RGBtoACI (RGB-codes / colorobj) 
    (setq 
      ColorObj (vla-GetInterfaceObject oAcad "AutoCAD.AcCmColor.16") 
    ) 
    (vlax-invoke 
      ColorObj 
      'setRGB 
      (car RGB-codes) 
      (cadr RGB-codes) 
      (caddr RGB-codes) 
    ) 
    (vlax-get-property ColorObj 'ColorIndex) 
  ) 
  (defun ea:Clearcset (/ cset) 
    (if (not (vl-catch-all-error-p 
        (setq cset 
        (vl-catch-all-apply 
   'vla-item 
   (list 
     (vla-get-selectionsets thisdrawing) 
     "CURRENT" 
   ) 
        ) 
        ) 
      ) 
 ) 
      (vla-delete cset) 
    ) 
    (princ) 
  ) 
  ;;************************************************************************** 
  ;;转换主程序 
  (defun ea:translyr (/ ea:chg_layer_color_ltyp_0     ea:chgattblk 
   ea:chg_ssget_blockdef 
   ea:chg_not_ssget_blockdef     llyrc 
   lt        t0       nl 
   filter        cset       l 
   n        s       sl 
   t1        blst       ll 
   lt        x       nllyr 
   0colorobj      0_in       e0 all_0 nn tmp 
         ) 
    ;;修改实体  mark 0 层实体块内/非块内标志, 如果 0 不在llyr中，块内 0 层仅涉及颜色 
    (defun ea:chg_layer_color_ltyp_0 (obj mark / alyr cl colobj olt) 
      ;;处理块内 object 及属性 
      (if (/= (cdr (assoc 
       0 
       (entget 
         (vlax-vla-object->ename 
    obj 
         ) 
       ) 
     ) 
       ) 
       "ACAD_PROXY_ENTITY" 
   ) ;_ 排除代理实体 
 (progn 
   (setq alyr (vla-get-layer obj)) 
   ;;保存实体原始特性 
   (if _$ver 
     (progn 
       (setq colobj (vla-get-truecolor obj) 
      cl    (vla-get-colorindex colobj ) 
       ) 
       (if (= cl 256) ;_ bylayer 
  (setq colobj (cdr (assoc alyr llyrc))) 
       ) 
     ) ;_ 2004/2005 特性 
     (if (= (setq cl (vla-get-color obj )) 256) 
       (setq cl (cdr (assoc alyr llyrc))) 
     ) 
   ) 
   ;;修改图层 
   (if (and (/= alyr nlyr) 
     (not (and mark (= alyr "0") (= ltf "1"))) 
       ) ;_ 只有忽略块内 0 时不改图层 
     (vla-put-layer obj  nlyr) 
   ) ;_ end if 
   ;;恢复颜色 
   (if (= tf "1") ;_ 保留 
     (cond 
       ((and mark 
      (= alyr "0") ;_ 0 层实体 
      (= cl 256) ;_ bylayer 
        ) 
        (if _$ver 
   (progn 
     (vla-put-colorindex colobj  acByblock) ;_ 只有块内实体才需要改 
     (vla-put-truecolor obj ' colobj) 
   ) 
   (vla-put-color obj  0) 
        ) ;_ byblock 
       ) 
       ((and (/= alyr nlyr) (= cl 256)) ;_ bylayer 非0层实体 
        (if _$ver 
   ;;取图层颜色 
   (vla-put-truecolor obj  colobj) 
   (vla-put-color obj cl) 
        ) ;_ end if 
       ) 
       (t) 
     ) ;_ end cond 
     ;;不保留颜色 
     (if (and _$ver 
       (/= cl 256) 
  ) 
       (progn 
  (vla-put-colorindex colobj 256);_ bylayer 
  (vla-put-truecolor obj  colobj) 
       ) 
       (vla-put-color obj  256) 
     ) 
   ) ;_end if 
   ;;不保留线形 
   (if (= tf1 "1") 
     (if (and (= (setq olt (vla-get-linetype obj )) 
   "BYLAYER" 
       ) 
       (/= olt "BYBLOCK") 
       (vlax-property-available-p obj 'linetype t) 
  ) 
       (vlax-put-property obj 'linetype (cdr (assoc alyr lt))) 
     ) 
     (if (and (/= (vla-get-linetype obj ) "BYLAYER") 
       (vlax-property-available-p obj 'linetype t) 
  ) 
       (vla-put-linetype obj ' "BYLAYER") 
     ) 
   ) ;_ end if 
 ) ;_ end progn 
      ) ;_ end progn (if) 
    ) ;_ end defun ea:chg_color_ltyp_0 
    ;;修改属性块的属性实体及SEQEND, 属性只能是最外层, mark 块内/非块内标志 
    (defun ea:ChgAttBlk (blk mark / seqent attlst) 
      (setq attlst (vlax-safearray->list 
       (vlax-variant-value (vla-getattributes blk)) 
     ) 
      ) 
      (mapcar '(lambda (x) 
   (if (vl-position (vla-get-layer x ) llyr) 
     (ea:chg_layer_color_ltyp_0 x mark) 
   ) 
        ) 
       attlst 
      ) 
      (if (vl-position 
     (vlax-get-property 
       (setq 
  seqent (vlax-ename->vla-object 
    (entnext 
      (vlax-vla-object->ename (last attlst)) 
    ) 
         ) 
       ) 
       'layer 
     ) 
     llyr 
   ) 
 (vlax-put-property seqent 'layer nlyr) 
      ) ;_ 修改 SEQEND 实体 
      (if (and (= tf1 "0") 
        (/= (vla-get-linetype seqent ) "BYLAYER") 
   ) 
 (vla-put-linetype seqent  "BYLAYER") 
      ) 
    ) ;_end defun ea:chgattblk 
    ;;************************************************************************************** 
    ;;主程序 
    (if (and (/= llyr "") (/= nlyr "")) 
      (progn 
 (if (not blocks) 
   (setq blocks (vla-get-blocks thisdrawing )) 
 ) 
 (if (not layers) 
   (setq layers (vla-get-layers thisdrawing )) 
 ) 
 (setq t0 (ea:get-utime)) 
 (if (not (tblsearch "layer" nlyr)) 
   (vla-add layers nlyr) 
 ) 
 ;;(vla-startundomark thisdrawing) 
 (vlax-map-collection 
   layers 
   '(lambda (x) (vla-put-lock x  :vlax-false)) 
 ) 
 ;;有一种颜色无法保留 
 (setq nl     (mapcar 'atoi (ea:string_parse llyr " ")) 
       filter (ea:string_unparse 
         (setq llyr (mapcar '(lambda (x) (nth x name)) nl)) 
         "," 
       ) 
 ) ;_end setq 
 (if (not (vl-position "0" llyr)) 
   (setq nllyr (append llyr '("0"))) 
   (setq nllyr llyr) 
 ) 
 (setq l (vla-get-count blocks )) 
 (if (= tf "1") ;_ 保留颜色时提取对应的颜色列表 
   (setq llyrc 
   (mapcar 
     '(lambda (x / col mod bkname) 
        (if _$ver 
   (cons x (vla-get-truecolor (vla-item layers x) ))    
   (cons x (cdr (assoc 62 (tblsearch "layer" x)))) 
        ) ;_ end if 
      ) ;_ end lambda 
     (if (not (vl-position nlyr nllyr)) 
       (append (list nlyr) nllyr) 
       nllyr 
     ) 
   ) ;_end mapcar 
   ) ;_ end setq 
 ) ;_ end if 
 (if (= tf1 "1") 
   (setq lt 
   (mapcar '(lambda (x) 
       (cons x (cdr (assoc 6 (tblsearch "layer" x)))) 
     ) 
    (if (not (vl-position nlyr nllyr)) 
      (append (list nlyr) nllyr) 
      nllyr 
    ) 
   ) 
   ) 
 ) 
 ;;处理实体 
 (ea:clearcset) 
 (if (ssget "x" 
     (list '(-4 . "<or") 
    '(66 . 1) 
    '(-4 . "<and") 
    (cons 8 filter) 
    '(-4 . "<not") 
    '(0 . "ACAD_PROXY_ENTITY") 
    '(-4 . "not>") 
    '(-4 . "and>") 
    '(-4 . "or>") 
     ) 
     ) ;_ end ssget 
   (progn 
     (setq l (+ l 
         (vlax-get-property 
    (setq cset (vla-get-activeselectionset 
          thisdrawing 
        ) 
    ) 
    'count 
         ) 
      ) 
    n 1 
     ) 
     (vlax-map-collection 
       cset 
       '(lambda (x / bbn) 
   (Ea:pross n l) 
   (cond 
     ((= (vla-get-objectname x ) "AcDbBlockReference") 
      (if (vl-position (vla-get-layer x) llyr) 
        (progn 
   (ea:chg_layer_color_ltyp_0 x nil)    
   (if (not blst) 
     (setq blst 
     (list (setq 
      bbn (vla-get-name x ) 
           ) 
     ) 
     ) 
     (if (not (vl-position 
         (setq 
           bbn (vla-get-name x) 
         ) 
         blst 
       ) 
         ) 
       (setq blst (append blst (list bbn))) 
     ) 
   ) ;_ 只记录了最外层块 
        ) 
      ) 
      (if (= (vla-get-hasattributes  x) :vlax-true) 
        (ea:chgattblk x nil) 
      ) 
     ) 
     (t (ea:chg_layer_color_ltyp_0 x nil)) 
   ) 
   (setq n (1+ n)) 
        ) 
     ) 
   ) ;_ while 
 ) ;_ end progn 
 ;;修改图块定义, 保留颜色仅涉及 块内 Bylayer 0 层是否改为 acByblock 
 (vlax-map-collection 
   (vlax-get-property thisdrawing 'blocks) 
   '(lambda (i / bn e tmp) 
      (if 
        (and 
   (setq bn (strcase (vlax-get-property i 'name))) 
   (not (wcmatch bn "`**_SPAC*")) 
   (/= (vla-get-count i) 0) 
        ) 
  ;;(vlax-map-collection 
  (if (vl-position bn blst);_ in ssget block 
    (vlax-map-collection 
      i 
      '(lambda (e / etyp lay bbn) 
         (setq etyp (vla-get-objectname e) 
        lay  (vla-get-layer e) 
         ) 
         (cond 
    ((and (wcmatch etyp "*Block*") 
          (not (vl-position 
          (strcase (vla-get-name e)) 
          blst 
        ) 
          ) 
          (vl-position lay llyr) 
     ) 
     (if (not 0_in) 
       (setq 0_in (list (vla-get-name e))) 
       (if (not (vl-position 
           (setq bbn (vla-get-name e)) 
           0_in 
         ) 
    ) 
         (setq 0_in (append (list bbn) 0_in)) 
       ) 
     ) 
     (ea:chg_layer_color_ltyp_0 e t) 
     (if (= (vlax-get-property e 'hasattributes) 
     :vlax-true 
         ) 
       (ea:chgattblk e t) 
     ) 
    ) 
    ((vl-position lay llyr) 
     (ea:chg_layer_color_ltyp_0 e t) 
    ) 
    (t) 
         ) 
       ) 
    ) ;_ end vlax-map-collection 
    (vlax-map-collection ;_ not in ssget 但可能在 blst 引用内(0_in) 
      i 
      '(lambda (e / etyp lay) 
         (setq etyp (vla-get-objectname e) 
        lay  (vla-get-layer e) 
         ) 
         (cond 
    ((vl-position lay llyr) 
     (cond 
       ((wcmatch etyp "*Block*") 
        (ea:chg_layer_color_ltyp_0 e t) 
        (if (not (vl-position 
     (strcase (vla-get-name e)) 
     blst 
          ) 
     ) 
          (if (not 0_in) 
     (setq 0_in (list (vla-get-name e))) 
     (if 
       (not (vl-position 
       (setq bbn (vla-get-name e)) 
       0_in 
     ) 
       ) 
        (setq 
          0_in (append (list bbn) 0_in) 
        ) 
     ) 
          ) 
        ) 
        (if 
          (= (vlax-get-property e 'hasattributes) 
      :vlax-true 
          ) 
    (ea:chgattblk e t) 
        ) 
       ) 
       ((/= lay "0") 
        (ea:chg_layer_color_ltyp_0 e t) 
       ) 
       (t) 
     ) 
    ) 
    ((and (= lay "0") ;_ 仅保留 0 层实体 
          (not (vl-position lay llyr)) 
     ) 
      (if (not 0_in) 
        (setq 0_in (list bn)) 
        (if (not (vl-position bn 0_in)) 
          (setq 
     0_in (append (list bn) 0_in) 
          ) 
        ) 
      ) 
      (setq nn  (read bn) 
     tmp (eval nn) 
      ) 
      (if (not tmp) 
        (set nn (list e)) 
        (set nn (cons e tmp)) 
      ) 
    ) ;_ end if 
    (t) 
         );_ end if 
       );_ end lambda 
    ) ;_ end vlax-map-collection 
  ) ;_ end if 
      ) ;_ end if 
    ) ;_ end lambda 
 ) ;_ 结束处理块定义 
 ;;处理被非选择图块且被引用并在 llyr 图层之块定义内的 0 实体 
 (if 0_in 
   (progn 
     (setq 0colorobj (vla-get-truecolor (vla-item layers"0"))) 
     (vla-put-colorindex 0colorobj acByblock) 
     (mapcar 
       '(lambda (x / 0lst) 
   (if (not (setq 0lst (eval (read x)))) 
     (mapcar '(lambda (e0) 
         (if _$ver 
    (vla-put-truecolor e0 0colorobj) 
    (vla-put-color e0 0) 
         ) 
       ) 
      olst 
     ) 
   ) 
        ) 
       0_in 
     ) 
   ) 
 ) 
 (setvar "clayer" "0") 
 (vla-purgeall thisdrawing) 
 ;;更新块引用 
 (if (setq s (ssget "x" (list (cons 8 nlyr) '(0 . "INSERT")))) 
   (progn 
     (setq sl (sslength s)) 
     (while (> sl 0) 
       (entupd (ssname s (setq sl (1- sl)))) 
     ) 
   ) ;_ end progn 
 ) ;_ end if 
 ;;(vla-endundomark thisdrawing) 
 (setq llyr   nil 
       name   (ea:table "layer") 
       blocks (vlax-get-property thisdrawing 'blocks) 
       layers (vlax-get-property thisdrawing 'layers) 
 ) 
 (if fillc 
   (progn 
     (setq ll (entget (tblobjname "layer" nlyr)) 
    ll (vl-remove-if 
         '(lambda (x) 
     (vl-position (car x) '(62 420 430))) 
         ll 
       ) 
     ) 
     (entmod (append ll fillc)) 
   ) 
 ) 
 (if t0 
   (progn 
     (setq t1 (ea:get-utime)) 
     (princ 
       (strcat "\n成功转换至 " nlyr " 图层,  耗时(secs): ") 
     ) 
     (princ (- t1 t0)) 
   ) 
 ) 
 (if all_0 (mapcar '(lambda (x) (set x nil)) all_0)) 
      ) ;_ end progn 
    ) ;_end if 
  ) ;_ end dufun ea:translyr 
  ;;预览 
  (defun ea:pre (/ nl layers str) 
    (if (and (/= llyr nil) (/= llyr "")) 
      (progn 
 (vla-startundomark thisdrawing) 
 (setq nl     (mapcar 'atoi (ea:string_parse llyr " ")) 
       nl     (mapcar '(lambda (x) (nth x name)) nl) 
 ) 
 (vlax-map-collection 
   (vlax-get-property thisdrawing 'layers) 
   '(lambda (l) 
      (if (vl-position (vlax-get-property l 'name) nl) 
        (progn 
   (if (= (vlax-get-property l 'layeron) :vlax-false) 
     (vlax-put-property  l 'layeron :vlax-true) 
   ) 
   (if (= (vlax-get-property l 'freeze) :vlax-true) 
     (vlax-put-property l 'freeze :vlax-false) 
   ) 
        ) 
        (vlax-put-property l 'layeron :vlax-false) 
      ) 
    ) 
 ) 
 (vla-endundomark thisdrawing) 
 (setq str (getstring "\n回车退出....")) 
 (vl-cmdf ".u") 
      ) 
    ) ;_end if 
    (princ) 
  ) ;_ end defun  ea:per 
  ;;选择合并实体, 支持嵌套在块内图层? 
  (defun getssLyr (/ ss ssl lyr slyr slst) 
    (princ "\n选择要合并图层实体<退出>...") 
    (if (setq ss (ssget)) 
      (progn 
 (setq ssl (sslength ss)) 
 (while (> ssl 0) 
   (setq 
     lyr 
      (cdr (assoc 8 (entget (ssname ss (setq ssl (1- ssl)))))) 
   ) 
   (if slyr 
     (if (not (vl-position lyr slyr)) 
       (setq slyr (cons lyr slyr)) 
     ) 
     (setq slyr (list lyr)) 
   ) 
 ) ;_ end while 
 (setq slst (mapcar '(lambda (l) (vl-position l name)) 
      slyr 
     ) 
 ) 
 (if llyr 
   (setq slst 
   (append slst (mapcar 'atoi (ea:string_parse llyr " "))) 
   ) 
 ) 
 (setq llyr (ea:string_unparse 
       (mapcar 'vl-princ-to-string 
        (vl-sort slst '<) 
       ) 
       " " 
     ) 
 ) 
      ) ;_ end progn 
    ) ;_ end if 
  ) ;_ end dufun 
  ;;获取当前颜色 l 层 
  (defun ea:getcecolor (l / color el inc tc dc le) 
    (if (not l) 
      (progn 
 (setq color (getvar "cecolor")) 
 (cond 
   ((= (type (read color)) 'INT);_ ACI 
    (list (cons 62 (read color))) 
   ) 
   ((wcmatch color "RGB:*");_ truecolor 
    (setq inc 
    (RGBtoACI 
      (setq 
        tc 
         (mapcar 
    'atoi 
    (ea:string_parse (vl-string-trim "RGB:" color) ",") 
         ) 
      ) 
    ) 
    ) 
    (list (cons 62 inc) (cons 420 (RGBtoOLE_color tc))) 
   ) 
   ((= color "BYLAYER") 
    (setq el  (entget (tblobjname "layer" (getvar "clayer"))) 
   inc (assoc 62 el) 
   tc  (assoc 420 el) 
   dc  (assoc 430 el) 
    ) 
    (cond 
      (dc (list inc tc dc)) 
      (tc (list inc tc)) 
      (t (list inc)) 
    ) 
   ) 
   ((= color "BYBLOCK") 
    (setq color '(62 . 7)) 
   ) 
 );_ end cond 
      );_ end progn 
      (if (setq le (tblobjname "layer" l)) 
 (progn 
   (setq el  (entget le) 
  inc (assoc 62 el) 
  tc  (assoc 420 el) 
  dc  (assoc 430 el) 
   ) 
   (cond 
     (dc (list inc tc dc)) 
     (tc (list inc tc)) 
     (t (list inc)) 
   ) 
 ) 
 (ea:getcecolor nil) 
      ) 
    ) 
  ) ;_ end defun ea:getcecolor 
  ;;填充默认颜色 
  (defun ea:fillcolor (/ cc width height cl) 
    (cond 
      (fillc    ;acad_colordlg 
       (setq cc (abs (cdar fillc))) 
      ) 
      (nlyr 
       (setq cc (abs (cdar (ea:getcecolor nlyr)))) 
      ) 
      (t 
       (setq cc (abs (cdar (ea:getcecolor nil)))) 
      ) 
    ) 
    (setq width  (dimx_tile "col") 
   height (dimy_tile "col") 
    ) 
    (start_image "col") 
    (fill_image 0 0 width height cc) ;1 = AutoCAD red. 
    (end_image) 
  ) ;_ end defun 
  ;;修改颜色按钮 
  (defun ea:chgcolor (/ c l) 
    (setq c (ea:getcecolor nlyr)) 
    (setq fillc (if _$ver 
    (cond 
      ((= (setq l (length c)) 1);_ aci 
       (acad_truecolordlg (cdar c)) 
      ) 
      ((= l 2);_ truecolor 
       (acad_truecolordlg (cadr c)) 
      ) 
      (t (acad_truecolordlg (last c)));_ dict 
    ) 
    (acad_colordlg (car c)) 
  ) 
    ) ;_ end setq 
  ) ;_ end defun 
  (defun myerr (msg /) 
    (if (or (/= msg "*函数已取消*") 
     (= msg "*函数已取消*") 
 ) 
      (princ "\n*取消*") 
    ) 
    (if 0_in 
      (mapcar '(lambda (x) (set (read x) nil)) 0_in) 
    ) 
    (setq 0_in nil) 
    (vla-endundomark thisdrawing) 
    (setq *error* olderr) 
    (princ) 
  ) ;_end deufn 
  ;;*********************************************************** 
  ;;主程序 
  (setq oAcad     (vlax-get-acad-object) 
 thisdrawing (vlax-get-property oAcad 'activedocument) 
 _$ver     (> (atof (getvar "acadver")) 16.) 
 olderr     *error* 
 *error*     myerr 
  ) 
  (vla-startundomark thisdrawing) 
  (if (setq nullss (ssget "x" '((0 . "*text") (1 . "")))) 
    (vl-cmdf ".erase" nullss "") 
  ) 
  ;(vla-purgeall thisdrawing) 
  (if (not _ealyrtr_id) 
    (setq _ealyrtr_id (load_dialog "lyrtr.dcl")) 
  ) 
  (setq what_next 2) 
  (while (>= what_next 2) 
    (if (not name) 
      (setq name (ea:table "layer")) 
    ) 
    (if (not (new_dialog "ea_lyrtrans" _ealyrtr_id)) 
      (exit) 
    ) 
    (start_list "what") 
    (mapcar 'add_list name) 
    (end_list) 
    (start_list "Sel") 
    (mapcar 'add_list name) 
    (end_list) 
    (if llyr 
      (set_tile "what" llyr) 
    ) 
    (if (and (/= nlyr "") nlyr) 
      (set_tile "Nlyr" nlyr) 
    ) 
    (ea:fillcolor) 
    (if tf 
      (set_tile "color" tf) 
    ) 
    (if tf1 
      (set_tile "ltyp" tf1) 
    ) 
    (action_tile 
      "Trans" 
      (strcat 
 "(princ "\n请稍候，处理进行中.....")" 
 "(setq nlyr (get_tile "Nlyr"))" 
 "(setq llyr (get_tile "what"))" 
 "(setq tf (get_tile "color"))" 
 "(setq tf1 (get_tile "ltyp"))" 
 "(setq ltf (get_tile "lay"))" 
 "(done_dialog 4)" 
       ) 
    ) 
    (action_tile "accept" "(done_dialog 1)") 
    (action_tile "lay" "(setq ltf $value)") 
    (action_tile "Nlyr" "(setq nlyr $value)") 
    (action_tile "color" "(setq tf $value)") 
    (action_tile "ltyp" "(setq tf1 $value)") 
    (action_tile 
      "col" 
      "(setq nlyr (get_tile "Nlyr"))(ea:chgcolor)(ea:fillcolor)(if fillc(set_tile "color" "0"))" 
    ) 
    (action_tile 
      "Sel" 
      "(set_tile "Nlyr" (nth (atoi $value) name))" 
    ) 
    (action_tile 
      "pre" 
      "(setq nlyr (get_tile "Nlyr"))(setq llyr (get_tile "what")) (done_dialog 5)" 
    ) 
    (action_tile 
      "list" 
      "(setq llyr (get_tile "what"))(done_dialog 6)" 
    ) 
    (action_tile 
      "what" 
      (strcat 
 "(setq nlyr (get_tile "Nlyr"))" 
 "(setq llyr $value)" 
 "(if (= $reason 4)(progn (setq nlyr (get_tile "Nlyr"))(setq llyr $value)(done_dialog 5)))" ;_ double click 
      ) 
    ) 
    (setq what_next (start_dialog)) 
    (cond 
      ((= what_next 4) 
       (ea:translyr) 
      ) 
      ((= what_next 5) 
       (ea:pre) 
      ) 
      ((= what_next 6) 
       (getsslyr) 
      ) 
    ) 
  ) ;_end while 
  (unload_dialog _ealyrtr_id) 
  (vla-endundomark thisdrawing) 
  (vlax-release-object thisdrawing) 
  (vlax-release-object oAcad) 
  (if blocks (vlax-release-object blocks)) 
  (if layers (vlax-release-object layers)) 
  (if 0_in (mapcar '(lambda (x) (set (read x) nil)) 0_in)) 
  (setq 0_in nil) 
  (setq *error* olderr) 
  (princ) 
) ;_end defun 
(princ 
  "\n\t图层合并V2.3, 命令: Lyrt. BY eachy[www.xdcad.net]" 
) 
(princ)

Free-Lancer · 发表于 2013-8-17 07:38:39

flowerson 发表于 2013-8-15 19:26

既然找出了错误，想必对程序也有了了解，有心得可以和大家分享吗？

张和平 · 发表于 2013-8-30 14:54:44

flowerson 发表于 2013-8-15 19:26

是在哪里出现问题啊？？今天找了半天，，还是没有找到。。。

flowerson · 发表于 2013-8-30 19:29:52

张和平发表于 2013-8-30 14:54
是在哪里出现问题啊？？今天找了半天，，还是没有找到。。。

直接复制我上面修改好的就行啦！

zhengxiansz · 发表于 2013-9-1 15:45:08

楼主DCL对话框要是全部整合到LISP里就好了。

张和平 · 发表于 2013-9-2 09:47:51

flowerson 发表于 2013-8-30 19:29
直接复制我上面修改好的就行啦！

主要是我想知道是哪里出错了

Free-Lancer · 发表于 2013-9-2 11:29:20

张和平发表于 2013-9-2 09:47
主要是我想知道是哪里出错了

两个都复制下来，文件对比一下

hahadang · 发表于 2013-10-17 10:07:21

这个工具很实用阿！:lol:lol

编程小白 · 发表于 2014-2-16 10:52:58

程序太好了，可惜积分不够，继续努力兼积分

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

[原创] 图层合并

出现这样的错“错误: 输入中含有多余的闭括号” 我找到问题在哪了！看看下面修改。

点评

点评

点评

点评