Select objects by colour

February 9, 2011

That's exactly it. My code from post #19 should enable you to do what you're after. Basically it does the following:

if (performs the check, if it returns anything but nil it continues to do the true portion)
The checking line:
- not converts anything but nil into nil, and nil gets converted to T (true)
- setq saves a value to the obj... variable
- cdr gets the rest of a list after removing the 1st item
- assoc retrieves the item from an association list (including the key value to be associated - that's why the cdr)
[*]If the entity had a 62 or 6 code, there would be a value placed in the objcol and objlty variables. Because of the not this would then stop the if statement.

[*]If the entity had a ByLayer set, then the not would return T and the if would continue:
- setq again to the same variable
- cdr again of the assoc 62 or 6 of the layer obtained from
- tblsearch the layer's name as stored in the entity's DXF code 8

Thus you have 2 scenarios for colour (same applies for linetype):

The entity has a colour other than ByLayer, say e.g. 2=Yellow, then the objcol would have a value of 2
The entity is set to colour ByLayer. Then the if continues and get's the layer's colour (say e.g. that is 3 = Green) then objcol would get a value of 3.

Where there might just be a problem is when you're testing for the linetype. The linetype's name is a string value and Lisp tests strings using case sensitivity so "Continuous" is not equal to "continuous". A way of getting round this is to convert both sides to upper / lower case. Also the = operator doesn't always work too well with strings, rather use the eq operator.

((and (= objcol 2)([color=red][b]eq[/b][/color] [b][color=seagreen](strcase [/color][/b]objlty[b][color=seagreen])[/color][/b] "[color=seagreen][b]CONTINUOUS[/b][/color]")))

February 9, 2011

Thanks a lot for breakin it down for me Irneb.

But it's still not working. Perhaps something i overlooked?

(setq objss (ssget "x" (list (cons 0 "*line"))))
(setq objent (entget (ssname objss 0)))
(if (not (setq objcol (cdr (assoc 62 objent))))
 (setq objcol (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 objent))))))
)
(if (not (setq objlty (cdr (assoc 6 objent))))
 (setq objlty (cdr (assoc 6 (tblsearch "LAYER" (cdr (assoc 8 objent))))))
)
(cond
         ((and (= objcol 2)(eq (strcase objlty) "CONTINUOUS")))
 (subst (cons 8 "ISO_LIN_UNI")(assoc 8 objent) objent))
 (entmod objent)

Drawing3.dwg

I've attached a simple drawing with 2 blocks and a rectangle to test it.

Please send me a pm with your paypal id if you have any :wink:. All efforts must be rewarded.

February 9, 2011

Please look here for David Bentel code http://www.cadtutor.net/forum/showthread.php?56654-generate-layers-based-on-color/page2 Is that you need?

I don't understand two lineas in your code:

(setq objss (ssget "x" (list (cons 0 "*line"))))
(setq objent (entget (ssname objss 0)))

You create a selection set of all entities having in its name "line", that is lines, lwpolylines, polylines, splines and multilines. And for those works only with the one first entity in selection set. There is no guarantee that your condition (and (= objcol 2)(eq (strcase objlty) "CONTINUOUS"))) will correspond to one entity. And also what about block inserts, arcs, circles etc. ?

It seems to me that you wanted to process all the entities. Or am I wrong?

Sorry that intervened.

Edited February 9, 2011 by Smirnoff
grammar

February 9, 2011

Sorry that intervened.

Not at all, you're very welcome.

Indeed, i do use a selection set. Then i pick the first one of the list.

That is becouse it's the only way i know so far to make selection sets.

I found bitsies of code on jeff's site, explaining (subst function.

This works only with entget & so. That's where the (ssname objss 0) comes in.

I don't mind about the blocks, as i have another part of code that will take care of that.

(while (setq blks (ssget "x" (list (cons 0 "insert"))))
 (command "explode" blks)
 (repeat (sslength blks))
)

But you're right, i might come across arcs, that would be a problem.

I guess you could say i'm after primitives.

Here would be an example of a simple symbol out of the library:

PUMP1.dwg

It's a pretty decent one. I could just rename layers, or merge them in new ones and then go "bylayer" for the color and linetypes. But other are so messed up i can't easely do that. I can't pick them out of the lib eighter, as there are over 1000 drawings to process:sweat:.

February 9, 2011

It seems structure of your routine should be:

(setq objss(ssget "x") [color="#8b0000"]; create SS for of entities[/color]
     i 0) [color="#8b0000"]; setq counter of entities to 0[/color]
(repeat(sslength objss) [color="#8b0000"]; repeat as many entities in SS[/color]
 (setq objent(ssname objss i)) [color="#8b0000"]; extract current entity[/color]
 (if(equal '(0 . "INSERT")(assoc 0(entget objent))) [color="#8b0000"]; if it is block insert[/color]
   (progn

    [color="#0000ff"] ; **** SOME CODE FOR BLOCKS ****[/color]

     ); end progn
   (progn [color="#8b0000"]; if it is entity[/color]

     [color="#0000ff"]; **** SOME CODE FOR ENTITIES ****[/color]

     ); end progn
   ); end if
(setq i(1+ i)) [color="#8b0000"]; set counter to extract next entity from SS[/color]
 ); end repeat

February 9, 2011

Thanks Smirnoff,

I will add this code, so other entities as lines are added to the sset.

The counter is also something i had to figure out to repeat the action on all entities.

Now i just have to figure out why the

; **** SOME CODE FOR ENTITIES ****

is not working.

Cheers,

SB

PS:

I've just tested the code. It works untill the ; **** SOME CODE FOR ENTITIES **** part.

Also i noticed that if there is a block, the entities it is composed of, are not part of the ss. Wouldn't it be better to put that code at the start?

(setq objss(ssget "x") [color=silver]; create SS of entities[/color]
     i 0) [color=silver]; setq counter of entities to 0[/color]
(repeat(sslength objss) [color=silver]; repeat as many entities in SS[/color]
 (setq objent(ssname objss i)) [color=silver]; extract current entity[/color]
 (if(equal '(0 . "INSERT")(assoc 0(entget objent))) [color=silver]; if it is block insert[/color]
   (progn
[color=royalblue](while (setq blks (ssget "x" (list (cons 0 "insert"))))[/color]
[color=royalblue]  (command "explode" blks)[/color]
[color=royalblue]  (repeat (sslength blks))[/color]
[color=royalblue])[/color]
   )[color=silver]; end progn[/color]
   (progn [color=silver]; if it is entity[/color]
[color=royalblue](if (not (setq objcol (cdr (assoc 62 objent))))[/color]
[color=royalblue]  (setq objcol (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 objent))))))[/color]
[color=royalblue])[/color]
[color=royalblue](if (not (setq objlty (cdr (assoc 6 objent))))[/color]
[color=royalblue]  (setq objlty (cdr (assoc 6 (tblsearch "LAYER" (cdr (assoc 8 objent))))))[/color]
[color=royalblue])[/color]
[color=royalblue] (cond[/color]
[color=royalblue]         ((and (= objcol 2)(eq (strcase objlty) "CONTINUOUS")))[/color]
[color=royalblue]  (subst (cons 8 "ISO_LIN_UNI")(assoc 8 objent) objent))[/color]
[color=royalblue]  (entmod objent)[/color]
   )[color=silver]; end progn[/color]
   )[color=silver]; end if[/color]
 (setq i(1+ i))[color=silver] ; set counter to extract next entity from SS[/color]
)[color=silver]; end repeat[/color]

Edited February 9, 2011 by Sittingbull
block progn

February 9, 2011

Show all your code (my+your). I'll tell you where the error occurred.

February 9, 2011

editted prev post .

Thx for quick reply!

February 10, 2011

OK just went with how I'd have done this:

(vl-load-com)
;; List of layers with their relevant properties (Color LineType LayerName)
(setq LayFix:List
      '((1 "CONTINUOUS" "LAYER1")         
        (1 "HIDDEN" "LAYER2")
        (1 "CENTER" "LAYER3")
        (2 "CONTINUOUS" "ISO_LIN_UNI")
        (2 "HIDDEN" "LAYER4")
        (2 "CENTER" "LAYER5")
       )
)

;; Multiple assoc, by Lee Mac
(defun MAssoc (key lst / pair return)
 (while (setq pair (assoc key lst))
   (setq return (cons (cdr pair) return)
         lst    (cdr (member pair lst))
   )
 )
 (reverse return)
)

;; Function to ensure layer exists
(defun MakeLayer (name / lData props)
 (if (not (setq lData (tblsearch "LAYER" name)))
   (progn
     (or *LayerCollection*
         (setq *LayerCollection* (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))))
     )
     (setq lData (vla-Add *LayerCollection* name))
     (if (setq props (assoc (strcase name) (mapcar 'reverse LayFix:List)))
       (progn
         (vla-put-LineType lData (cadr props))
         (vla-put-Color lData (caddr props))
       )
     )
     (setq lData (tblsearch "LAYER" name))
   )
 )
 lData
)

;; Function to obtain entity's apparent property
(defun EntAssoc (code ed / data)
 (if (not (setq data (assoc code ed)))
   (setq data (assoc code (tblsearch "LAYER" (cdr (assoc 8 ed)))))
 )
 data
)


;; Command to step through all entities in a selection set as well as block internals
;; selected. Then change all to match LayFix:List
(defun c:FixLayers (/ ss n en ed eo blk EntityFix)

 ;; Function to move entity onto correct layer
 (defun EntityFix (/ lName eCol eLty)
   (setq
     eCol (cdr (EntAssoc 62 ed))
     eLty (cdr (EntAssoc 6 ed))
   )
   (if (and (setq lName (last (assoc (strcase eLty) (MAssoc eCol LayFix:List))))
            (MakeLayer lName)
       )
     (progn
       (vl-catch-all-apply 'vla-put-Layer (list eo lName))
       (vl-catch-all-apply 'vla-put-Color (list eo 256)) ;Set color to ByLayer
       (vl-catch-all-apply 'vla-put-LineType (list eo "BYLAYER")) ;And linetype
     )
   )
 )

 (prompt "Select objects to fix: ")
 (if (and (setq ss (ssget)) (setq n (sslength ss)))
   (progn
     ;; Fix selected entities
     (while (> (setq n (1- n)) -1)
       (setq en (ssname ss n) ;Get nth entity in selection set
             eo (vlax-ename->vla-object en) ;Get its ActiveX object
             ed (entget en) ;Get its DXF data
       )
       (EntityFix) ;Fix the entity's layer
       ;; If block store for later fix
       (if (and (eq (cdr (assoc 0 ed)) "INSERT") ;If it's an insert
                (not (vl-position (vla-get-EffectiveName eo) blk)) ;And the block's name isn't already saved
           )
         (setq blk (cons (vla-get-EffectiveName eo) blk)) ;Add to list for later
       )
     )
     ;; Fix all selected block definitions
     (foreach ss blk
       (setq n  (tblsearch "BLOCK" ss) ;Get block's definition data
             en (cdr (assoc -2 n)) ;Get 1st entity inside the block
       )
       (while en ;While there is another entity inside
         (setq ed (entget en) eo (vlax-ename->vla-object en))
         (EntityFix)
         (setq en (entnext en)) ;Get next inside block definition
       )
     )
   )
   (princ "\nNothing selected.")
 )
 (princ)
)

To add more layers just add to that 1st list & modify as needed. Then the command is FixLayers, select which entities you want to fix. It won't explode the blocks, rather it will fix the entities inside the blocks' definitions.

It creates the layer if it doesn't already exist and sets its properties to that in the list. Also all entities moved to these layers are changed to bylayer.

February 10, 2011

Thx Irneb, that is nice code.

Unfortunatly i can't realy use it in a batch process, can i?

Wich is the whole deal:

Here would be an example of a simple symbol out of the library:
PUMP1.dwg

It's a pretty decent one. I could just rename layers, or merge them in new ones and then go "bylayer" for the color and linetypes. But other are so messed up i can't easely do that. I can't pick them out of the lib eighter, as there are over 1000 drawings to process:sweat:.

I don't see why i would want a lisp just for changing properties of objects, with my input. If i have to bring some input myself to change a color or linetype of an object, i can simply open the drawing and do it manualy.

The need of a lisp code is because i need to change a whole library.

It's a shame though. Your code is way to advanced for me to edit it. Sorry if i've been waisting your time:oops:.

February 10, 2011

Now this works. The code was few not working places.

(defun c:test(/ blks objss objcol objent objlty)

(while (setq blks (ssget "_X" '((0 . "INSERT"))))
  (command "_.explode" blks)
[color="#ff0000"]; there was extra string[/color]
)

(setq objss(ssget "X") ; create SS of entities
     i 0) ; setq counter of entities to 0
(repeat(sslength objss) ; repeat as many entities in SS
 (setq objent(entget(ssname objss i))) ; extract current entity
    (if (not (setq objcol (cdr (assoc 62 objent))))
       (setq objcol (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 objent))))))
      ); end if
    (if (not (setq objlty (cdr (assoc 6 objent))))
      (setq objlty (cdr (assoc 6 (tblsearch "LAYER" (cdr (assoc 8 objent))))))
     ); end if
       (cond
         ((and (= objcol 2)(eq(strcase objlty) "CONTINUOUS"))
           [color="#ff0000"](setq objent[/color](subst(cons 8 "ISO_LIN_UNI")(assoc 8 objent)objent))
  [color="#ff0000"] ); condition #1 ends here[/color]
  ); end cond
     (entmod objent)
   (setq i(1+ i)) ; set counter to extract next entity from SS
); end repeat

(princ)
); end of c:test

February 10, 2011

Yay! Looks great:thumbsup:.

Now i can add other conditions, right?

I'll experiment with that a bit later, gotto go to seminar.

But thanks a bunch m8, this is awsome.

February 10, 2011

Alright for the conditions.

This is exactly what i was looking for.

Thanks a milion times Smirnoff:D.

(defun c:test(/ blks objss objcol objent objlty)
(while (setq blks (ssget "_X" '((0 . "INSERT"))))
  (command "_.explode" blks)
; there was extra string
)
(setq objss(ssget "X") ; create SS of entities
     i 0) ; setq counter of entities to 0
(repeat(sslength objss) ; repeat as many entities in SS
 (setq objent(entget(ssname objss i))) ; extract current entity
    (if (not (setq objcol (cdr (assoc 62 objent))))
       (setq objcol (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 objent))))))
      ); end if
    (if (not (setq objlty (cdr (assoc 6 objent))))
      (setq objlty (cdr (assoc 6 (tblsearch "LAYER" (cdr (assoc 8 objent))))))
     ); end if
       (cond
         ((and (= objcol 1)(eq(strcase objlty) "CONTINUOUS"))
           (setq objent(subst(cons 8 "ISO_LIN_PIL")(assoc 8 objent)objent))
   ); condition #1 ends here
  ); end cond
       (cond
         ((and (= objcol 2)(eq(strcase objlty) "CONTINUOUS"))
           (setq objent(subst(cons 8 "ISO_LIN_UNI")(assoc 8 objent)objent))
   ); condition #2 ends here
  ); end cond
       (cond
         ((and (= objcol 252)(eq(strcase objlty) "CONTINUOUS"))
           (setq objent(subst(cons 8 "ISO_LIN_RET_SPR")(assoc 8 objent)objent))
   ); condition #3 ends here
  ); end cond
       (cond
         ((and (= objcol 3)(eq(strcase objlty) "HIDDEN"))
           (setq objent(subst(cons 8 "ISO_LIN_CON")(assoc 8 objent)objent))
   ); condition #4 ends here
  ); end cond
       (cond
         ((and (= objcol 252)(eq(strcase objlty) "CENTER"))
           (setq objent(subst(cons 8 "ISO_LIN_ASS")(assoc 8 objent)objent))
   ); condition #5 ends here
  ); end cond
     (entmod objent)
   (setq i(1+ i)) ; set counter to extract next entity from SS
); end repeat
(princ)
); end of c:test

February 10, 2011

I'm glad that everything worked.

But while this code is far from perfect. Look at the irneb code, all the conditions there in a neat list at the beginning and there is an internal processing of a blocks without exploding it.

February 10, 2011

I sure will. It will be my homework for this week.

Thank both of you for sharing the knowledge:thumbsup:.

February 10, 2011

Thx Irneb, that is nice code.
Unfortunatly i can't realy use it in a batch process, can i?

You can easily run the code on multiple DWGs using something like ScriptPro or AutoScript (or even generate a SCR file of your own to do multiple DWGs - but that's a bit of a tall order for 100's of DWGs). Then all you need to do is save my code to a LSP file in one of your support folders (say call it LayFix.LSP), create the following as the SCR you want to run on each DWG:

(load "LayFix")
FixLayers _All
_QSAVE

If you use AS / SP they both create one by default and open it in Notepad for you to edit. Then simply select the DWGs you want it to run on, click the run button, wait for it as it opens each DWG in turn and runs the SCR as if you typed that into the command line.

If you don't want to change the entities to bylayer (which I cannot understand), simply remove that portion of the code.

February 10, 2011

BTW, I used ActiveX objects instead of entmod - since I've had numerous problems with annotative text through entmod. It's just a bit less dangerous.

February 10, 2011

One more code which can be useful. It helps to found entities with non 'ByLayer' properties.

(defun c:anax(/ tCnt cLst cItm cNum hLst cSet)

 (defun Collect_Non_ByLayer(SelSet / Out)
    (foreach i(mapcar
        '(lambda(x)
	  (vl-remove-if-not
	    '(lambda(m)
	       (member(car m) '(6 62 370 420))
	       )
	     x
	    )
	  )
          (mapcar 'entget
     (vl-remove-if 'listp
       (mapcar 'cadr(ssnamex SelSet)
	     )
          )
       ); end mapcar
   ); end mapcar
      (if(not(member i Out))
 (setq out(append(list i)Out)))
 ); end foreach
 ); end of Collect_Non_ByLayer
 
(setq tCnt 1)
(if(setq cLst(Collect_Non_ByLayer(ssget "_X")))
(progn
(princ "\n     *** ENTITIES WITH NON ByLayer PROPERTIES FOUND ***")
(princ "\n +-----+-----------+--------------------------+----------+")
(princ "\n | #   | Color     | Linetype                 | Weight   |")
(foreach i cLst
(princ "\n +-----+-----------+--------------------------+----------+")
(setq cItm(itoa tCnt))
(princ(strcat "\n | " cItm))
(repeat(- 4(strlen cItm))(princ " "))
   
   (if(or
 (setq cItm(cdr(assoc 420 i)))
 (setq cItm(cdr(assoc 62 i)))
 ); or
     (progn
      (setq cItm(itoa cItm))
      (princ(strcat "| " cItm))
      (repeat(- 10(strlen cItm))(princ " "))
     ); end progn
     (princ "|           ")
     ); end if

   (if(setq cItm(cdr(assoc 6 i)))
     (progn
(princ(strcat "| " cItm))
(repeat(- 25(strlen cItm))(princ " "))
); end progn
     (princ "|                          ")
     ); end if

    (if(setq cItm(cdr(assoc 370 i)))
     (progn
(setq cItm(cdr(assoc cItm '((0 . "0.0")(9 . "0.09")(13 . "0.13")(15 . "0.15")
			    (18 . "0.18")(20 . "0.20")(25 . "0.25")(30 . "0.30")
			    (35 . "0.35")(40 . "0.40")(50 . "0.50")(53 . "0.53")
			    (60 . "0.60")(70 . "0.70")(80 . "0.80")(90 . "0.90")
			    (100 . "1.00")(106 . "1.06")(120 . "1.20")(140 . "1.40")
			    (158 . "1.58")(200 . "2.00")(211 . "2.11") (-2 . "ByBlock")
			    (-3 . "Default"))
		     )
	      )
      ); end setq
(princ(strcat "| " cItm))
(repeat(- 9(strlen cItm))(princ " "))
(princ "|")
); end progn
     (princ "|          |")
     ); end if

   (setq tCnt(1+ tCnt))
   ); end foreach
  (princ "\n +-----+-----------+--------------------------+----------+\n")
  (textscr)
  (while(setq cNum(getint "\nSpecify # to highlight entities (or Spacebar to Quit): "))
    (if(setq hLst(nth(1- cNum) cLst))
      (progn
       (graphscr)
       (setq cSet(ssget "_X" hLst))
 (setvar "CMDECHO" 0)
 (command "_.zoom" "_ob" cSet "")
 (setvar "CMDECHO" 1)
        (sssetfirst nil cSet)
(getkword "\nPress any key to view table... ")
(textscr)
      ); end progn
      (princ "\n<!> Item not found <!> ")
      ); end if
    ); end while 
  ); end progn
 (princ "\n <<< All entities has 'ByLayer' properties >>>")
 ); end if
 
 (princ)
); end of c:anax

Screehshot:

[color="#0000ff"]Command: anax

    *** ENTITIES WITH NON ByLayer PROPERTIES FOUND ***
+-----+-----------+--------------------------+----------+
| #   | Color     | Linetype                 | Weight   |
+-----+-----------+--------------------------+----------+
| 1   | 1         |                          |          |
+-----+-----------+--------------------------+----------+
| 2   |           |                          | 0.70     |
+-----+-----------+--------------------------+----------+
| 3   |           | ACAD_ISO03W100           |          |
+-----+-----------+--------------------------+----------+

Specify # to highlight entities (or Spacebar to Quit): 3[/color]

February 10, 2011

I'm so spoiled

SB

Select objects by colour

Recommended Posts

irneb

Link to comment

Share on other sites

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

alanjt

Posted Images

Sittingbull

Link to comment

Share on other sites

Smirnoff

Link to comment

Share on other sites

Sittingbull

Link to comment

Share on other sites

Smirnoff

Link to comment

Share on other sites

Sittingbull

Link to comment

Share on other sites

Smirnoff

Link to comment

Share on other sites

Sittingbull

Link to comment

Share on other sites

irneb

Link to comment

Share on other sites

Sittingbull

Link to comment

Share on other sites

Smirnoff

Link to comment

Share on other sites

Sittingbull

Link to comment

Share on other sites

Sittingbull

Link to comment

Share on other sites

Smirnoff

Link to comment

Share on other sites

Sittingbull

Link to comment

Share on other sites

irneb

Link to comment

Share on other sites

irneb

Link to comment

Share on other sites

Smirnoff

Link to comment

Share on other sites

Sittingbull

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity