Lee: I've tried your routine, it works perfectly for me. And, I wrote some pre-works to cooperate with yours. See the code below.
1) run the "Layers";
2) run the "editlst";
3) run the "cblayers";
It's quite dirty, coz I am not quite good at coding:(
;=================================================================================
;;;;Function: Generate two lists of existing layernames for edit
;;;;Thanks to Hasan M. Asous's great routine
;;;;I've made some revision according to my need
;;;;Edit by litss 2011-01-12
;=================================================================================
;;-------------------=={ Layers List }==----------------;;
;; ;;
;; Create a line & text for each layer and have ;;
;; layer properties and text string is layer name ;;
;; for each layer ;;
;; ;;
;;------------------------------------------------------;;
;; Author: Hasan M. Asous, 2010 ;;
;; ;;
;; Copyright ? 2010 by HasanCAD, All Rights Reserved. ;;
;; Contact: HasanCAD @ TheSwamp.org, ;;
;; asos2000 @ CADTutor.net ;;
;;------------------------------------------------------;;
;; Version: 1 20100928 ;;
;;------------------------------------------------------;;
;; o_l_ll \_ll o_l l \_l ;;
;;
(defun c:Layers (/ AcObj ActDoc Cntr Pnt0 e l Pnt1 Pnt2 LyrName LyrLType
LyrClr
)
(vl-load-com)
(setq AcObj (vlax-get-Acad-Object))
(setq ActDoc (vla-get-ActiveDocument AcObj))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(setq Cntr -1)
(setq Pnt0 (trans (getpoint "\nBase point") 1 0))
(setq Pnt1 (list (+ (car pnt0) 3000) (cadr pnt0) (caddr pnt0)))
(setq Pnt2 (list (+ (car pnt0) 6000) (cadr pnt0) (caddr pnt0)));SETQ
;;-----HEADER------
(entmakex (list (cons 0 "TEXT") (cons 1 "OLD-LAYER") (cons 8 "0")
(cons 10 Pnt0) (cons 40 220) (cons 41 0.8) (cons 62 1)
)
)
(entmakex (list (cons 0 "TEXT") (cons 1 "NEW-LAYER") (cons 8 "0")
(cons 10 Pnt1) (cons 40 220) (cons 41 0.8) (cons 62 2)
)
)
(entmakex (list (cons 0 "TEXT") (cons 1 "OLD ==> NEW") (cons 8 "0")
(cons 10 Pnt2) (cons 40 220) (cons 41 0.8) (cons 62 3)
)
) ;;-----LAYERS LIST------
(setq Pnt0 (list (car pnt0) (+ (cadr pnt0) -200) (caddr pnt0)))
(while (setq Lyr (tblnext "LAYER" (null Lyr)))
(setq LyrName (cdr (assoc 2 Lyr)))
(setq LyrLType (cdr (assoc 6 Lyr)))
(setq LyrClr (cdr (assoc 62 Lyr)))
(if (setq Pnt1 (list (+ (car pnt0) 3000) (cadr pnt0) (caddr pnt0)))
(progn
(entmakex (list (cons 0 "TEXT") (cons 1 LyrName) (cons 8 LyrName)
(cons 10 Pnt0) (cons 40 110) (cons 41 0.8)
)
)
(entmakex (list (cons 0 "TEXT") (cons 1 LyrName) (cons 8 LyrName)
(cons 10 Pnt1) (cons 40 110) (cons 41 0.8)
)
)
(setq Pnt0 (list (car pnt0) (+ (cadr pnt0) -200) (caddr pnt0)))
)
)
(vla-EndUndoMark ActDoc)
)
(princ)
)
;defun ;;
;; o_l_ll \_ll o_l l \_l ;;
;=================================================================================
;;;;Function: Specify the layers that should be combined
;;;;Written by litss 2011-01-12
;=================================================================================
(defun C:editlst (/ cblay flag newlay oldent oldlay oldx oldy pnt2)
(setq flag nil)
(setvar "osmode" 0)
(while (not flag)
(setq oldent (car (entsel "\nSelect old-layer item from the list:")))
(setq oldlay (cdr (assoc 1 (entget oldent))))
(setq oldX (nth 0 (cdr (assoc 10 (entget oldent)))))
(setq oldY (nth 1 (cdr (assoc 10 (entget oldent)))))
(setq newent (car (entsel "\nSelect new-layer item from the list:")))
(setq newlay (cdr (assoc 1 (entget newent))))
(setq newXY (cdr (assoc 10 (entget newent))))
(if (and
oldlay
newlay
)
(progn
(setq Pnt2 (list (+ oldX 6000) oldY 0))
(setq cblay (strcat oldlay " ==> " newlay))
(entmakex (list (cons 0 "TEXT") (cons 1 cblay) (cons 8 newlay)
(cons 10 Pnt2) (cons 40 110) (cons 41 0.8)
)
)
(command "line" (list oldX oldY) newXY Pnt2 "")
);progn
(setq flag t)
);if
);while
;;-----Prepare Trans LIST------
)
;=================================================================================
;;;;Function: Combine layers by selecting the editlst
;;;;Thanks to Lee Mac whose routine is the core function.
;;;;Written by litss 2011-01-12
;=================================================================================
(defun c:cblayers (/ ent n posi ss1 str0 translst)
(setq ss1 (ssget))
(setq n 0)
(setq translst '())
(repeat (sslength ss1)
(setq ent (ssname ss1 n))
(setq str0 (cdr (assoc 1 (entget ent))))
(setq posi (vl-string-search " ==> " str0))
(setq translst (cons (cons (substr str0 1 posi) (substr str0 (+ posi 6)))
translst
)
)
(setq n (1+ n))
);repeat
(princ translst)
(layertrans translst)
(princ)
)
;=================================================================================
;;;;Subroutine by Lee Mac
;;;;The core function
;;;;Written by Lee Mac
;=================================================================================
(defun LayerTrans (layerlist / _lst->str doc blocks layers locked ss)
(vl-load-com) ;; Example by Lee Mac 2011 - www.lee-mac.com
;; LayerList should be in the form:
;; '(
;; ( "OldLayer1" . "NewLayer1" )
;; ( "OldLayer2" . "NewLayer2" )
;; ( "OldLayer3" . "NewLayer3" )
;; ...
;; ( "OldLayerN" . "NewLayerN" )
;; )
;; Layers are case-sensitive
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
blocks (vla-get-Blocks doc)
layers (vla-get-Layers doc)
)
(defun _lst->str (lst del)
(if (cdr lst)
(strcat (car lst) del (_lst->str (cdr lst) del))
(car lst)
)
)
(vla-StartUndoMark doc)
(mapcar
(function (lambda (item)
(vla-Add layers (cdr item))
)
)
layerlist
)
(vlax-for layer layers (if (eq :vlax-true (vla-get-lock layer))
(vla-put-lock (car (setq locked (cons layer
locked
)
)
) :vlax-false
)
)
)
(vlax-for block blocks (vlax-for obj block (if (setq layer (cdr
(assoc
(vla-get-layer obj) layerlist
)
)
)
(vla-put-layer obj layer)
)
)
)
(if (ssget "_X" (list (cons 8 (_lst->str (mapcar
'car
layerlist
) ","
)
)
)
)
(progn
(vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))
(if (setq layer (cdr (assoc (vla-get-layer obj) layerlist)))
(vla-put-layer obj layer)
)
)
(vla-delete ss)
)
)
(foreach layer locked
(vla-put-lock layer :vlax-true)
)
(vl-cmdf "_.-purge" "_LA" (_lst->str (mapcar
'car
layerlist
) ","
) "_N"
) ;; Thanks CAB!
(vla-regen doc acAllViewports)
(vla-EndUndoMark doc)
(princ)
)
