move blocks to other (new) layer by TWO attribute values

[rlx]

replace (with _) , yes , yes , you're welcome

[hpimprint]

i tryed it but it does not work. here autocad message:

; error: Automation Error. Key not found
Command:

 

here attached the lisp file i used.

 

ah! _thank *you

blockschangenameandlayer.lsp

[rlx]

try it now (result of tag1 and tag2 should not only be tested but also saved like :

      (if (and tag1 tag2 (setq tag1 (validsn tag1)) (setq tag2 (validsn tag2)))

 

;;; get attibute value (vla version)
(defun gav (b a) (setq a (strcase a))
  (vl-some '(lambda (x)(if (= a (strcase (vla-get-tagstring x)))(vla-get-textstring x)))(vlax-invoke b 'getattributes)))

;selectionset to (object) list
(defun SS->OL (ss / i l)(setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l)

; create layer test : (create_layer "RLX")
(defun create_layer (lay) (if (not (tblsearch "layer" lay))(entmake (list (cons 0 "LAYER")
  (cons 100 "AcDbSymbolTableRecord")(cons 100 "AcDbLayerTableRecord")(cons 2 lay) (cons 70 0)))))

;;; test (validsn "abc") (validsn "a\\b<c>d/e?f\"g:h;i*j|k,l=m`n")
(defun validsn ( s / n ) (if (and (= (type s) 'STR) (setq n (vl-string->list "\\<>/?\":;*|,=`")))
  (apply 'strcat (mapcar '(lambda (x)(if (member x n) "_" (chr x))) (vl-string->list s))) nil))

(defun c:blockschangenameandlayer ( / ss tag1 tag2 lay)
  (if (setq ss (ssget "x" '((0 . "insert"))))
    (foreach block (ss->ol ss)
      ;;; qui definisce cosa sono tag1 e tag2 tra le proprietà del blocco
      (setq tag1 (gav block "systemId") tag2 (gav block "PipelineID")) 
      (if (and tag1 tag2 (setq tag1 (validsn tag1)) (setq tag2 (validsn tag2)))
        (progn
          ;;; qui crea il layer con il nuovo nome tag1 - tag2 dove tag1 e tag2 sono presi dal blocco
          (create_layer (setq lay (strcat tag1 "-" tag2))) 
          (vla-put-layer block lay)
        )
      )
    )
  )
  (princ)
)

(vl-load-com)

(defun c:bcnl ()(c:blockschangenameandlayer))

(princ "\nOn commandline (after loading lisp) type blockschangenameandlayer (or bcnl for short) to run program")
(princ)

 

[hpimprint]

it works perfectly. great script, nice work. compliments.

[hpimprint]

here i am again.

can i ask for a lisp change?

let's remeber that in the starting autocad drawing blocks we have the following attributes:
Systemld = xxx
keyword = yyy
Description
dimensionalDescription
PipelineId = zzz

actually we created layers "SystemId-PipelineId" (putting the right blocks inside) using "systemId" and "PipelineID" block attributes.

now i have some blocks having a specific "keyword" attribute =SUPPORT:
Systemld =xxx
keyword = SUPPORT
Description
dimensionalDescription
PipelineId =zzz

now i need to put objects having attribute keyword = SUPPORT in a different layer named "SystemId-PipelineId-SUPPORT"
while all other objects wll go, as per old script, in layer named "SystemId-PipelineId".

 

i think is possible to insert an "IF...ELSE" condition in script file:

 

actual script:
-------------
      (setq tag1 (gav block "systemId") tag2 (gav block "PipelineID"))
      (if (and tag1 tag2 (setq tag1 (validsn tag1)) (setq tag2 (validsn tag2)))
        (progn
          (create_layer (setq lay (strcat tag1 "-" tag2)))
          (vla-put-layer block lay)
        )

 

 

new script:
----------

      (setq tag1 (gav block "systemId") tag2 (gav block "PipelineID") tag3 (gav block "keyword")
(***) (IF "keyword" ATTRIBUTE IS EQUAL TO "SUPPORT"
    if (and tag1 tag2 tag3 (setq tag1 (validsn tag1)) (setq tag2 (validsn tag2)) (setq tag3 (validsn tag3)) )
        (progn
          (create_layer (setq lay (strcat tag1 "-" tag2 "-" tag3)))
          (vla-put-layer block lay)
        )
(***)    ELSE
      (if (and tag1 tag2 (setq tag1 (validsn tag1)) (setq tag2 (validsn tag2)))
        (progn
          (create_layer (setq lay (strcat tag1 "-" tag2)))
          (vla-put-layer block lay)
        )

can you help me to write the IF.. ELSE condition, look at (***)?

thank you

 

[rlx]

untested

(defun c:blockschangenameandlayer-update ( / ss tag1 tag2 tag3 lay)
  (if (setq ss (ssget "x" '((0 . "insert"))))
    (foreach block (ss->ol ss)
      (setq tag1 (gav block "systemId") tag2 (gav block "PipelineID") tag3 (gav block "keyword"))
      (if (and tag1 tag2 (snvalid tag1) (snvalid tag2))
        (cond
          ((and tag3 (snvalid tag3) (eq (strcase tag3) "SUPPORT"))
             (create_layer (setq lay (strcat tag1 "-" tag2 "-" tag3))) (vla-put-layer block lay))
          (t (create_layer (setq lay (strcat tag1 "-" tag2))) (vla-put-layer block lay))
        )
      )
    )
  )
  (princ)
)

 

[hpimprint]

thank you. it worked.

 

but what if i need that only layers "#-@-SUPPORT" have colour by layer also for objects inside block?

Now if i have a main block on layer "(HCV)-100-007-SUPPORT", its color is "by layer" but nested objects inside block have a forced color: so also if i change main block layer color, the block remain of same color.

Is it possible to force objects inside main block on layers "#-@-SUPPORT" so to have forced color "by layer"? probebly you can to it while you create the new layer name and move on it the block.

 

see attached file

nested objects inside SUPPORT layers color change to by layer.dwg

[rlx]

think there are many posts about nested blocks and color byblock on this forum so you shoud be able to find one and modify it to your need. Have some work to finish now , but will look later.

[hpimprint]

ok. i will wait for you

[rlx]

this one I made a while ago , not sure what is does exactly anymore but maybe it also works for you.

 

 

[hpimprint]

there is maybe a bug in the script to change layer names.

 

Here attached the last script and a test .dwg where inside are shown blocks that are not renamed by script.

RENAME_PROBLEM.dwg blockschangenameandlayer v.4.0.lsp

[rlx]

Sorry for the late reaction, have very little time at this moment (end of year stress / no pressure you know...)

First look tells me value for pipelineID contains invalid character (*) for it to be able to be used as layer name , like 100-PWA-MAN2*

I assumed validsn would replace each invalid character with "_" but apparently it doesn't. Will look later if I have more time

 

ah , rookie mistake

 

(defun c:blockschangenameandlayer ( / ss tag1 tag2 tag3 lay)
  (if (setq ss (ssget "x" '((0 . "insert"))))
    (foreach block (ss->ol ss)
      ;;; qui definisce cosa sono tag1, tag2 e tag3 tra le proprietà del blocco
      (setq tag1 (gav block "systemId") tag2 (gav block "PipelineID") tag3 (gav block "keyword"))
      (if (and tag1 (setq tag1 (validsn tag1)) tag2 (setq tag2 (validsn tag2)))
        (cond
          ((and tag3 (setq tag3 (validsn tag3)) (eq (strcase tag3) "SUPPORT"))
	     ;;; se keyword=SUPPORT aggiunge al nome layer "-SUPPORT"
             (create_layer (setq lay (strcat tag1 "-" tag2 "-" tag3))) (vla-put-layer block lay))
          (t (create_layer (setq lay (strcat tag1 "-" tag2))) (vla-put-layer block lay))
        )
      )
    )
  )
  (princ)
)

 

Edited November 18, 2021 by rlx

[hpimprint]

i tested it.

autocad message is:

 

; error: Automation Error. Key not found
Command:

[rlx]

I only changed 

(and tag1 tag2 (snvalid tag1) (snvalid tag2))

to

(and tag1 tag2 (setq tag1 (snvalid tag1)) (setq tag2 (snvalid tag2)))

 

and same for tag3

 

did you replace posted version part in your v.4.0.lsp or just tried to run it? Anyways , attached the full version. If it still gives you trouble let me know and I will create one with more error catching / messages

blockschangenameandlayer_nov_2021.lsp

[hpimprint]

it doesn't work at all.

 

; error: bad argument type: stringp T

 

here attached the test file, if you want to test it

 

 

test per stress.3 originale.dwg

Edited November 23, 2021 by hpimprint

[rlx]

well this certainly showed me the need to always test something before posting, sorry about that...

try it now...

 

;;; get attibute value (vla version)
(defun gav (b a) (setq a (strcase a))
  (vl-some '(lambda (x)(if (= a (strcase (vla-get-tagstring x)))(vla-get-textstring x)))
            (vlax-invoke b 'getattributes)))

;selectionset to (object) list
(defun SS->OL (ss / i l)(setq i 0)
  (repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l)

; create layer test : (create_layer "RLX")
(defun create_layer (lay) (if (not (tblsearch "layer" lay))(entmake (list (cons 0 "LAYER")
  (cons 100 "AcDbSymbolTableRecord")(cons 100 "AcDbLayerTableRecord")(cons 2 lay) (cons 70 0)))))

;;; test (validsn "abc") (validsn "a\\b<c>d/e?f\"g:h;i*j|k,l=m`n")
(defun validsn ( s / n ) (if (and (= (type s) 'STR) (setq n (vl-string->list " \\<>/?\":;*|,=`")))
  (apply 'strcat (mapcar '(lambda (x)(if (member x n) "_" (chr x))) (vl-string->list s))) nil))

(defun c:blockschangenameandlayer ( / ss tag1 tag2 tag3 lay)
  (if (setq ss (ssget "x" '((0 . "insert"))))
    (foreach block (ss->ol ss)
      ;;; qui definisce cosa sono tag1, tag2 e tag3 tra le proprietà del blocco
      (setq tag1 (gav block "systemId") tag2 (gav block "PipelineID") tag3 (gav block "keyword"))
      (if (and tag1 tag2 (setq tag1 (validsn tag1)) (setq tag2 (validsn tag2)))
        (cond
          ((and tag3 (setq tag3 (validsn tag3)) (eq (strcase tag3) "SUPPORT"))
	     ;;; se keyword=SUPPORT aggiunge al nome layer "-SUPPORT"
             (create_layer (setq lay (strcat tag1 "-" tag2 "-" tag3))) (vla-put-layer block lay))
          (t (create_layer (setq lay (strcat tag1 "-" tag2))) (vla-put-layer block lay))
        )
      )
    )
  )
  (princ)
)

(vl-load-com)

(defun c:bcnl ()(c:blockschangenameandlayer))

(princ
  (strcat "\nOn commandline (after loading lisp) type blockschangenameandlayer "
          "(or bcnl for short) to run program"))
(princ)

 

Edited November 23, 2021 by rlx

[hpimprint]

perfect! now it works well. SOLVED! thank you

 

in your scripts, perhaps do you know how to set layer of nested objects inside blocks to "by block"?

i mean: all objects should have "by block" as colour.

 

[rlx]

Only thing I have  at this moment for setting objects to color byblock ,  I posted nov 15. It used to work for me but I admid I rarely have to use it. Maybe start new topic and include a drawing with before and after situation , not just a pic.

But I'm happy at least the other one works at last. 

[hpimprint]

ok thank you. so this topic is solved and stops here   thank you again, you saved me!

[hpimprint]

dear rlx

i used the lisp on a HUGE dwg file containing more than 1000.000 (!!!) blocks..... and lisp stopped working (error, something as "access violation"): i think autocad lisp cache memory ended. infact separating the huge file in two files (each one containg an half of blocks), lisp worked.

Is there  way to modify the script so that it can work also on huge dwg contaianin maaaAAAaany blocks?

thank you