andy_lee Posted June 16, 2014 Share Posted June 16, 2014 When layer merge later , Will remove the original layer, and displayer:Conversion to " ??? " layer successful, Time(secs):0.141 .... But ,now ,Failed to normal end. Please wait, processing..... *cancel*; error: An error has occurred inside the *error* functionbad argument type: symbolp 1 why? DCL ea_lyrtrans : dialog { label = "Layer Merge"; : column { : row { : column { : boxed_column { width = 10; label = "merge to"; : row { children_alignment = top; : edit_box { height =1; key = "Nlyr"; } : image_button { height = 2; width =4; key = "col"; } } : popup_list { key = "Sel"; } } : column { : toggle { label = "Keep color"; key = "color"; value = "1"; } : toggle { label = "Keep linear"; key = "ltyp"; value = "1"; } : toggle { label = "Ignore the block layer 0"; key = "lay"; value = "1"; } } } : boxed_column { label = "layer list"; : list_box { key = "what"; height = 9; width = 17; multiple_select = true; allow_accept = true; } } } : row { alignment = centered; fixed_width = true; : button { label = "preview" ; key = "pre"; } : button { label = "select" ; key = "list"; } : button { label = "conversion" ; key = "Trans"; } : ok_button { label = "exit" ; key = "accept"; is_cancel = true; } } } } Layer Merge23.dcl Layer Merge23.lsp Quote Link to comment Share on other sites More sharing options...
andy_lee Posted June 16, 2014 Author Share Posted June 16, 2014 I want post the lisp code,but "The text that you have entered is too long (20593 characters). Please shorten it to 15000 characters long." Can download Attached Files in #1 Part1. ;by eachy ;flowerson edit (vl-load-com) (if (>= (atof (getvar "acadver")) 16.0) (vl-arx-import "acapp.arx") (vl-arx-import "acadapp.arx") ) ;| The global variable nlyr: new layer llyr: conversion list name: layer list fillc : new layer colour tf : keep colour "1" keep "0" Don't keep tf1 : keep linear "1" keep "0" Don't keep ltf : Ignore the block layer 0 "1" Ignore "0" modify |; (defun c:TEST (/ 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) ) ;;The progress bar (defun Ea:pross (k l) (grtext -2 (strcat "Has been completed" (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) ) (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) ) ;;************************************************************************** ;;conversion main code (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 ) (defun ea:chg_layer_color_ltyp_0 (obj mark / alyr cl colobj olt) (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))) ) ) ; (if (= (setq cl (vla-get-color obj )) 256) (setq cl (cdr (assoc alyr llyrc))) ) ) ;;modify layer (if (and (/= alyr nlyr) (not (and mark (= alyr "0") (= ltf "1"))) ) (vla-put-layer obj nlyr) ) ;_ end if ;;Restore color (if (= tf "1") ;_keep (cond ((and mark (= alyr "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)) ; (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 (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) ) ; (if (and (= tf1 "0") (/= (vla-get-linetype seqent ) "BYLAYER") ) (vla-put-linetype seqent "BYLAYER") ) ) ;_end defun ea:chgattblk ;;main code (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 Quote Link to comment Share on other sites More sharing options...
andy_lee Posted June 16, 2014 Author Share Posted June 16, 2014 part2 (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") ; (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 ) ; (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 "\nConversion to " nlyr " layer successful, Time(secs): ") ) (princ (- t1 t0)) ) ) (if all_0 (mapcar '(lambda (x) (set x nil)) all_0)) ) ;_ end progn ) ;_end if ) ;_ end dufun ea:translyr ;;preview (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 "\nEnter exit....")) (vl-cmdf ".u") ) ) ;_end if (princ) ) ;_ end defun ea:per (defun getssLyr (/ ss ssl lyr slyr slst) (princ "\nChoose to merge the layer entities<exit>...") (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 (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 ;;Fill in the default color (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 ;;Modify the color button (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 "*function cancelled*") (= msg "*function cancelled*") ) (princ "\n*cancel*") ) (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 ;;*********************************************************** ;;Main code (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 "Layer Merge23.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 \"\nPlease wait, processing.....\")" "(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\tLayer Merge V2.3, command : TEST. BY eachy[www.xdcad.net]" ) (princ) Quote Link to comment Share on other sites More sharing options...
andy_lee Posted June 16, 2014 Author Share Posted June 16, 2014 Who can help me to check this code ?Thanks very much! Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.