【求助】论坛图层合并V2.3源码
;http://bbs.xdcad.net/thread-669308-1-1.html;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-utimeRGBtoOLE_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 xtmp 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 objnlyr)
) ;_ end if
;;恢复颜色
(if (= tf "1") ;_ 保留
(cond
((and mark
(= alyr "0") ;_ 0 层实体
(= cl 256) ;_ bylayer
)
(if _$ver
(progn
(vla-put-colorindex colobjacByblock) ;_ 只有块内实体才需要改
(vla-put-truecolor obj ' colobj)
)
(vla-put-color obj0)
) ;_ byblock
)
((and (/= alyr nlyr) (= cl 256)) ;_ bylayer 非0层实体
(if _$ver
;;取图层颜色
(vla-put-truecolor objcolobj)
(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 objcolobj)
)
(vla-put-color obj256)
)
) ;_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-hasattributesx) :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-propertyl '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 defunea: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 "D:/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"
)
(princ)请问一下为什么输入命令后窗口弹出后闪退呀？
有人知道如何改一下可以把这两个文件直接放在d盘使用吗？或者怎么把他们合并到lsp 合并了下，似乎缺少2个函数
尘缘一生 发表于 2020-2-15 05:07
合并了下，似乎缺少2个函数
加载运行没反应 尘缘一生 发表于 2020-2-15 05:07
合并了下，似乎缺少2个函数
没跑起来:'( 图层合并可以直接laymgr命令或者在layer命令界面合并，没必要写代码 kozmosovia 发表于 2024-5-17 10:53
图层合并可以直接laymgr命令或者在layer命令界面合并，没必要写代码
laymgr命令不好用啊，用.chprop就很快，一句command解决 jun470 发表于 2024-5-19 23:31
laymgr命令不好用啊，用.chprop就很快，一句command解决
中文真好，改图层==合并图层 kozmosovia 发表于 2024-5-20 00:40
中文真好，改图层==合并图层
我自己就这么用的，改到一起就行，看需求吧
页:
[1]