Author Topic: Vla-put-TrueColor on thousands of entities  (Read 6474 times)

0 Members and 1 Guest are viewing this topic.

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Vla-put-TrueColor on thousands of entities
« on: November 29, 2017, 04:49:12 AM »

I need to change TrueColor (I use only colors from 0 to 256), is this a good method to perform on thousands of entities?
Code: [Select]
(defun test (VlaObj ClrNum / TrCCol)
  (print (vla-get-objectname VlaObj)) (princ " ")
  (setq TrCCol (vla-get-TrueColor VlaObj))
  (princ (vla-get-ColorIndex TrCCol)) (princ " ")
  (vla-put-ColorIndex TrCCol ClrNum); 0= ByBlock - 256 Bylayer
  (vla-put-TrueColor VlaObj TrCCol)
  (princ " <<< Before - After >>> ")
  (princ (vla-get-ColorIndex TrCCol))
  (princ)
)
Command: (test MyObject 199)
"AcDbAttributeDefinition"  0  <<< Before - After >>> 199

Grrr1337

  • Swamp Rat
  • Posts: 812
Re: Vla-put-TrueColor on thousands of entities
« Reply #1 on: November 29, 2017, 06:05:13 AM »
I'd initially obtain the color object, (and initially assign the color properties - if all objects are going to have the same color). Then iterate and apply that color object, wherever I need :
Code - Auto/Visual Lisp: [Select]
  1. (defun C:test ( / *error* acDoc oCol RGB acSS )
  2.  
  3.   (defun *error* (m)
  4.     (and acSS (vla-Delete acSS))
  5.     (and (eq 'VLA-OBJECT (type oCol)) (not (vlax-object-released-p oCol)) (vl-catch-all-apply 'vlax-release-object (list oCol)))
  6.     (and acDoc (vla-EndUndoMark acDoc))
  7.     (and m (princ m)) (princ)
  8.   ); defun *error*
  9.  
  10.   (cond
  11.     (
  12.       (and
  13.         (ssget "_:L")
  14.         (setq oCol (vla-GetInterfaceObject (vlax-get-acad-object) (strcat "AutoCAD.AcCmColor." (substr (getvar 'acadver) 1 2)))) ; Supported Color Methods: acColorMethodByACI acColorMethodByBlock acColorMethodByLayer acColorMethodByRGB acColorMethodForeground
  15.       ); and
  16.       (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc)
  17.       ; If all objects in the SS will have the same color, then Initially assign the color propert(y/ies) for the color object:
  18.       ; (vla-put-ColorMethod oCol acColorMethodByACI) (vla-put-ColorIndex oCol 253) ; For Index Colors
  19.       (setq RGB '(255 255 255)) (vla-put-ColorMethod col acColorMethodByRGB) (apply 'vla-SetRGB (cons col RGB)) ; For RGB
  20.      
  21.       (vlax-for o (setq acSS (vla-get-ActiveSelectionSet acDoc))
  22.         (vla-put-TrueColor o oCol)
  23.       ); vlax-for
  24.     )
  25.   ); cond
  26.   (*error* nil) (princ)
  27. ); defun C:test


Although when the speed doesn't matter I always prefer to map subfunctions, like this:
Code - Auto/Visual Lisp: [Select]
  1. ; (_PutColor (vlax-ename->vla-object (car (entsel))) '(100 125 75))
  2. ; (_PutColor (vlax-ename->vla-object (car (entsel))) 4)
  3. (defun _PutColor ( o v / intp )
  4.   (and (eq 'VLA-OBJECT (type o)) (setq intp (lambda (x) (eq 'INT (type x))))
  5.     (cond
  6.       ( (and (intp v) (<= 0 v 256)) (vl-catch-all-apply 'vla-put-Color (list o v)) )
  7.       (
  8.         (vl-catch-all-apply
  9.           (function
  10.             (lambda ( / c )
  11.               (and
  12.                 (= 3 (length v)) (vl-every 'intp v)
  13.                 (setq c (vla-get-TrueColor o))
  14.                 (progn (vla-put-ColorMethod c acColorMethodByRGB) (apply 'vla-SetRGB (cons c v)) (vla-put-TrueColor o c) )
  15.               ); and
  16.             ); lambda
  17.           ); function
  18.         ); vl-catch-all-apply
  19.       )
  20.     ); cond
  21.   ); and
  22. ); defun _PutColor
Since the overall code would be more readable and easier to maintain.
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg


ronjonp

  • Needs a day job
  • Posts: 7526
Re: Vla-put-TrueColor on thousands of entities
« Reply #3 on: November 29, 2017, 09:15:01 AM »
You could also remove group code 420 to convert to index color:

Code - Auto/Visual Lisp: [Select]
  1. (defun c:foo (/ e s)
  2.   (if (setq s (ssget ":L"))
  3.     (foreach a (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
  4.       (if (assoc 420 (setq e (entget a '("*"))))
  5.         (entmod (vl-remove (assoc 420 e) e))
  6.       )
  7.     )
  8.   )
  9.   (princ)
  10. )
« Last Edit: November 29, 2017, 09:20:06 AM by ronjonp »

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

Grrr1337

  • Swamp Rat
  • Posts: 812
Re: Vla-put-TrueColor on thousands of entities
« Reply #4 on: November 29, 2017, 09:26:41 AM »
You could also remove group code 420 to convert to index color:
...

remove also 430 gc.  :wink:
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg

ronjonp

  • Needs a day job
  • Posts: 7526
Re: Vla-put-TrueColor on thousands of entities
« Reply #5 on: November 29, 2017, 09:42:42 AM »
You could also remove group code 420 to convert to index color:
...

remove also 430 gc.  ;)
Ahhhh color books :)
Code - Auto/Visual Lisp: [Select]
  1. (defun c:foo (/ s)
  2.   (if (setq s (ssget ":L"))
  3.     (foreach a (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
  4.       (entmod (vl-remove-if '(lambda (x) (member (car x) '(420 430))) (entget a '("*"))))
  5.     )
  6.   )
  7.   (princ)
  8. )
« Last Edit: November 29, 2017, 09:46:21 AM by ronjonp »

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
Re: Vla-put-TrueColor on thousands of entities
« Reply #6 on: November 29, 2017, 10:01:11 AM »

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: Vla-put-TrueColor on thousands of entities
« Reply #7 on: November 29, 2017, 10:39:10 AM »


Actually I would rather use vla-put -... instead of entmod, I am changing entities in the blocks
but I would like a function that also works in ODBX Doc.
I have tested all method:
Code: [Select]
Benchmark.lsp | © 2005 Michael Puckett | All Rights Reserved
Elapsed milliseconds / relative speed for 8 iteration(s):
    (FOO_GRR SELSET).....1781 / 1.78 <fastest>
    (FOO_GR2 SELSET).....2235 / 1.42
    (FOO_ALE SELSET).....2390 / 1.33
    (FOO_ROY SELSET).....2625 / 1.21                              ;only to change the color method
    (FOO_RON SELSET).....3171 / 1 <slowest>                 ;only to change the color method
Code: [Select]
(defun _PutColor ( o v / intp )
  (and (eq 'VLA-OBJECT (type o)) (setq intp (lambda (x) (eq 'INT (type x))))
    (cond
      ( (and (intp v) (<= 0 v 256)) (vl-catch-all-apply 'vla-put-Color (list o v)) )
      (
        (vl-catch-all-apply
          (function
            (lambda ( / c )
              (and
                (= 3 (length v)) (vl-every 'intp v)
                (setq c (vla-get-TrueColor o))
                (progn (vla-put-ColorMethod c acColorMethodByRGB) (apply 'vla-SetRGB (cons c v)) (vla-put-TrueColor o c) )
              ); and
            ); lambda
          ); function
        ); vl-catch-all-apply
      )
    ); cond
  ); and
); defun _PutColor


(defun Foo_grr (SelSet / *error* acDoc oCol RGB acSS )
  (defun *error* (m)
    (and acSS (vla-Delete acSS))
    (and (eq 'VLA-OBJECT (type oCol)) (not (vlax-object-released-p oCol)) (vl-catch-all-apply 'vlax-release-object (list oCol)))
    (and acDoc (vla-EndUndoMark acDoc))
    (and m (princ m)) (princ)
  ); defun *error*
  (cond
    (
      (and
        SelSet
        (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
        (setq oCol (vla-GetInterfaceObject (vlax-get-acad-object) (strcat "AutoCAD.AcCmColor." (substr (getvar 'acadver) 1 2)))) ; Supported Color Methods: acColorMethodByACI acColorMethodByBlock acColorMethodByLayer acColorMethodByRGB acColorMethodForeground
      ); and
      (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc)
      ; If all objects in the SS will have the same color, then Initially assign the color propert(y/ies) for the color object:
       (vla-put-ColorMethod oCol acColorMethodByACI) (vla-put-ColorIndex oCol 222) ; For Index Colors
      ;(setq RGB '(255 255 255)) (vla-put-ColorMethod col acColorMethodByRGB) (apply 'vla-SetRGB (cons col RGB)) ; For RGB
 
      (vlax-for o (setq acSS (vla-get-ActiveSelectionSet acDoc))
        (vla-put-TrueColor o oCol)
      ); vlax-for
    )
  ); cond
  (*error* nil) (princ)
); defun C:test
(defun Foo_gr2 (SelSet / VlaObj TrCCol)
   (foreach ForElm (vl-remove-if 'listp (mapcar 'cadr (ssnamex SelSet)))
      (_PutColor (vlax-ename->vla-object ForElm) 33)
    )
  (princ)
)

(defun Foo_ale (SelSet / VlaObj TrCCol)
   (foreach ForElm (vl-remove-if 'listp (mapcar 'cadr (ssnamex SelSet)))
      (setq TrCCol (vla-get-TrueColor (setq VlaObj (vlax-ename->vla-object ForElm))))
      (vla-put-ColorIndex TrCCol 111)
      (vla-put-TrueColor VlaObj TrCCol)
    )
  (princ)
)
(defun Foo_roy (SelSet / col obj);only to change the color method
   (foreach ForElm (vl-remove-if 'listp (mapcar 'cadr (ssnamex SelSet)))
     (setq col (vla-get-truecolor (setq obj (vlax-ename->vla-object ForElm))))
     (vla-setrgb col (vla-get-red col) (vla-get-green col) (vla-get-blue col))
     (vla-put-truecolor obj col)
   )
  (princ)
)
(defun foo_ron (SelSet);only to change the color method
    (foreach a (vl-remove-if 'listp (mapcar 'cadr (ssnamex SelSet)))
      (entmod (vl-remove-if '(lambda (x) (member (car x) '(420 430))) (entget a '("*"))))
    )
  (princ)
)
(setq SelSet (ssget "_X"))
(Benchmark '(
  (Foo_grr SelSet) 
  (Foo_ale SelSet) 
  (Foo_gr2 SelSet) 
  (foo_ron SelSet) 
  (Foo_roy SelSet) 
))


Grrr1337

  • Swamp Rat
  • Posts: 812
Re: Vla-put-TrueColor on thousands of entities
« Reply #8 on: November 29, 2017, 12:07:38 PM »

but I would like a function that also works in ODBX Doc

You've should mentioned this in the very start - so we'd know that vanilla is not an option.  :tongue2:


I have tested all method:
...

Consider repeat instead of ssnamex, quoting from Lee's selection set processing tutorial:
Quote
However, do not be deceived into thinking that this method is efficient simply because it looks more concise than the previous examples...

The ssnamex function is a process intensive function and is slow to evaluate, furthermore, the foreach loop may iterate a number of times greater than the number of items in the set as the ssnamex function includes additional information about any window selections (or other selection methods) that the user may have used.

But anyway Roy mentioned somewhere that obtaining the elist for each entity (using entget) is inefficient for some tasks, when speed is a question.




You could use Lee's ODBX Wrapper to write a Coloring Block Definition Objects wrapper for yourself:
 
Code - Auto/Visual Lisp: [Select]
  1. ; tfb - [Optional] test function that requires a single argument: block definition vla-object
  2. ; tfo - [Optional] test function that requires a single argument: vla-object (which is inside block definition)
  3. ; NOTE: do not use the following variable names in the above test functions "tfb tfo c sav f oCol fpath"
  4. ; c - Index color
  5. ; sav - [Optional] save dwg
  6. ; Requires: http://www.lee-mac.com/odbxbase.html
  7. (defun _ColorObjectsInBlockODBX ( tfb tfo c sav / f oCol fpath )
  8.  
  9.   (setq f ; fun - A function requiring a single argument (the VLA Document Object)
  10.     (lambda ( doc / Blks ) (setq Blks (vla-get-Blocks doc))
  11.       (cond
  12.         ( (and tfb tfo)
  13.           (vlax-for b Blks
  14.             (if (tfb b)
  15.               (vlax-for o b
  16.                 (if (tfo o)
  17.                   (vla-put-TrueColor o oCol)
  18.                 ); if
  19.               ); vlax-for o
  20.             ); if
  21.           ); vlax-for b
  22.         )
  23.         (tfb
  24.           (vlax-for b Blks
  25.             (if (tfb b)
  26.               (vlax-for o b
  27.                 (vla-put-TrueColor o oCol)
  28.               ); vlax-for o
  29.             ); if
  30.           ); vlax-for b
  31.         ); tfb
  32.         (tfo
  33.           (vlax-for b Blks
  34.             (vlax-for o b
  35.               (if (tfo o)
  36.                 (vla-put-TrueColor o oCol)
  37.               ); if
  38.             ); vlax-for o
  39.            
  40.           ); vlax-for b
  41.         ); tfo
  42.         (T
  43.           (vlax-for b Blks
  44.             (vlax-for o b
  45.               (vla-put-TrueColor o oCol)
  46.             ); vlax-for o
  47.           ); vlax-for b
  48.         ); T
  49.       ); cond
  50.     ); lambda
  51.   ); setq f
  52.  
  53.   (cond
  54.     ( (or (not (eq 'INT (type c))) (not (<= 0 c 256))) (prompt "\nInvalid color index.") )
  55.     ( (not LM:ODBX) (prompt "\nPlease load Lee's ObjectDBX Wrapper.") )
  56.     ( (not (setq oCol (vla-GetInterfaceObject (vlax-get-acad-object) (strcat "AutoCAD.AcCmColor." (substr (getvar 'acadver) 1 2)))))
  57.       (prompt "\nUnable to interfere with the color object.")
  58.     )
  59.     ( (not (setq fpath (getfiled "Specify dwg file" (strcat (getenv "userprofile") "\\Desktop\\") "dwg" 16)))
  60.       (prompt "\nDWG file not specified.")
  61.     )
  62.     (T (vla-put-ColorMethod oCol acColorMethodByACI) (vla-put-ColorIndex oCol c)
  63.       (LM:ODBX (function f) (list fpath) sav) ; (LM:ODBX <fun> [lst] [sav])
  64.     ); T
  65.   ); cond
  66. ); defun _ColorObjectsInBlockODBX

Examples:

To color all objects inside all blocks definitions - using color 1 (red) :
Code - Auto/Visual Lisp: [Select]
  1. (_ColorObjectsInBlockODBX
  2.   nil ; tfb
  3.   nil ; tfo
  4.   1 ; index color
  5.   nil ; save?
  6. ); _ColorObjectsInBlockODBX

To color line and circle objects inside blocks definitions with names "Donald" ... "Hands" - using color 1 (red) :
Code - Auto/Visual Lisp: [Select]
  1. (_ColorObjectsInBlockODBX
  2.   (lambda ( b ) ; tfb
  3.     (member (vla-get-Name b) '("Donald" "Drinks" "A_Bottle" "Of_Water" "Using_Both" "Hands"))
  4.   )
  5.   (lambda ( o ) ; tfo
  6.     (member (vla-get-ObjectName o) '("AcDbLine" "AcDbCircle"))
  7.   )
  8.   1 ; index color
  9.   nil ; save?
  10. ); _ColorObjectsInBlockODBX

Haven't tested it, but I'm sure you'll work it out. :)
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg

ronjonp

  • Needs a day job
  • Posts: 7526
Re: Vla-put-TrueColor on thousands of entities
« Reply #9 on: November 29, 2017, 03:42:22 PM »


Actually I would rather use vla-put -... instead of entmod, I am changing entities in the blocks
but I would like a function that also works in ODBX Doc.
I have tested all method:
Code: [Select]
Benchmark.lsp | © 2005 Michael Puckett | All Rights Reserved
Elapsed milliseconds / relative speed for 8 iteration(s):
    (FOO_GRR SELSET).....1781 / 1.78 <fastest>
    (FOO_GR2 SELSET).....2235 / 1.42
    (FOO_ALE SELSET).....2390 / 1.33
    (FOO_ROY SELSET).....2625 / 1.21                              ;only to change the color method
    (FOO_RON SELSET).....3171 / 1 <slowest>                 ;only to change the color method
Code: [Select]
(defun _PutColor ( o v / intp )
  (and (eq 'VLA-OBJECT (type o)) (setq intp (lambda (x) (eq 'INT (type x))))
    (cond
      ( (and (intp v) (<= 0 v 256)) (vl-catch-all-apply 'vla-put-Color (list o v)) )
      (
        (vl-catch-all-apply
          (function
            (lambda ( / c )
              (and
                (= 3 (length v)) (vl-every 'intp v)
                (setq c (vla-get-TrueColor o))
                (progn (vla-put-ColorMethod c acColorMethodByRGB) (apply 'vla-SetRGB (cons c v)) (vla-put-TrueColor o c) )
              ); and
            ); lambda
          ); function
        ); vl-catch-all-apply
      )
    ); cond
  ); and
); defun _PutColor


(defun Foo_grr (SelSet / *error* acDoc oCol RGB acSS )
  (defun *error* (m)
    (and acSS (vla-Delete acSS))
    (and (eq 'VLA-OBJECT (type oCol)) (not (vlax-object-released-p oCol)) (vl-catch-all-apply 'vlax-release-object (list oCol)))
    (and acDoc (vla-EndUndoMark acDoc))
    (and m (princ m)) (princ)
  ); defun *error*
  (cond
    (
      (and
        SelSet
        (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
        (setq oCol (vla-GetInterfaceObject (vlax-get-acad-object) (strcat "AutoCAD.AcCmColor." (substr (getvar 'acadver) 1 2)))) ; Supported Color Methods: acColorMethodByACI acColorMethodByBlock acColorMethodByLayer acColorMethodByRGB acColorMethodForeground
      ); and
      (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc)
      ; If all objects in the SS will have the same color, then Initially assign the color propert(y/ies) for the color object:
       (vla-put-ColorMethod oCol acColorMethodByACI) (vla-put-ColorIndex oCol 222) ; For Index Colors
      ;(setq RGB '(255 255 255)) (vla-put-ColorMethod col acColorMethodByRGB) (apply 'vla-SetRGB (cons col RGB)) ; For RGB
 
      (vlax-for o (setq acSS (vla-get-ActiveSelectionSet acDoc))
        (vla-put-TrueColor o oCol)
      ); vlax-for
    )
  ); cond
  (*error* nil) (princ)
); defun C:test
(defun Foo_gr2 (SelSet / VlaObj TrCCol)
   (foreach ForElm (vl-remove-if 'listp (mapcar 'cadr (ssnamex SelSet)))
      (_PutColor (vlax-ename->vla-object ForElm) 33)
    )
  (princ)
)

(defun Foo_ale (SelSet / VlaObj TrCCol)
   (foreach ForElm (vl-remove-if 'listp (mapcar 'cadr (ssnamex SelSet)))
      (setq TrCCol (vla-get-TrueColor (setq VlaObj (vlax-ename->vla-object ForElm))))
      (vla-put-ColorIndex TrCCol 111)
      (vla-put-TrueColor VlaObj TrCCol)
    )
  (princ)
)
(defun Foo_roy (SelSet / col obj);only to change the color method
   (foreach ForElm (vl-remove-if 'listp (mapcar 'cadr (ssnamex SelSet)))
     (setq col (vla-get-truecolor (setq obj (vlax-ename->vla-object ForElm))))
     (vla-setrgb col (vla-get-red col) (vla-get-green col) (vla-get-blue col))
     (vla-put-truecolor obj col)
   )
  (princ)
)
(defun foo_ron (SelSet);only to change the color method
    (foreach a (vl-remove-if 'listp (mapcar 'cadr (ssnamex SelSet)))
      (entmod (vl-remove-if '(lambda (x) (member (car x) '(420 430))) (entget a '("*"))))
    )
  (princ)
)
(setq SelSet (ssget "_X"))
(Benchmark '(
  (Foo_grr SelSet) 
  (Foo_ale SelSet) 
  (Foo_gr2 SelSet) 
  (foo_ron SelSet) 
  (Foo_roy SelSet) 
))

Why are you benchmarking functions that perform different tasks?
When modified all to change the index color to 111 .. the numbers are quite different ( ~32000 items processed )
Quote
;;;_$
;;;
;;;_PUTCOLOR
;;;FOO_GRR
;;;FOO_GR2
;;;FOO_ALE
;;;FOO_ROY
;;;FOO_RON
;;;<Selection set: 7f3>
;;;31922 Benchmarking ...Elapsed milliseconds / relative speed for 1 iteration(s):
;;;
;;;    (FOO_RON SELSET)......3297 / 3.12 <fastest>
;;;    (FOO_GRR SELSET)......3703 / 2.78
;;;    (FOO_ROY SELSET)......5500 / 1.87
;;;    (FOO_GR2 SELSET)......5984 / 1.72
;;;    (FOO_ALE SELSET).....10281 / 1.00 <slowest>
;;;
;;;
;;;; 9 forms loaded from #<editor "<Untitled-0> loading...">
;;;_$


Test functions:
Code - Auto/Visual Lisp: [Select]
  1. (defun _putcolor (o v / intp)
  2.   (and (eq 'vla-object (type o))
  3.        (setq intp (lambda (x) (eq 'int (type x))))
  4.        (cond ((and (intp v) (<= 0 v 256)) (vl-catch-all-apply 'vla-put-color (list o v)))
  5.              ((vl-catch-all-apply
  6.                 (function (lambda (/ c)
  7.                             (and (= 3 (length v))
  8.                                  (vl-every 'intp v)
  9.                                  (setq c (vla-get-truecolor o))
  10.                                  (progn (vla-put-colormethod c accolormethodbyrgb)
  11.                                         (apply 'vla-setrgb (cons c v))
  12.                                         (vla-put-truecolor o c)
  13.                                  )
  14.                             )           ; and
  15.                           )             ; lambda
  16.                 )                       ; function
  17.               )                         ; vl-catch-all-apply
  18.              )
  19.        )                                ; cond
  20.   )                                     ; and
  21. )                                       ; defun _PutColor
  22.  
  23.  
  24. (defun foo_grr (selset / *error* acdoc ocol rgb acss)
  25.   (defun *error* (m)
  26.     (and acss (vla-delete acss))
  27.     (and (eq 'vla-object (type ocol))
  28.          (not (vlax-object-released-p ocol))
  29.          (vl-catch-all-apply 'vlax-release-object (list ocol))
  30.     )
  31.     (and acdoc (vla-endundomark acdoc))
  32.     (and m (princ m))
  33.     (princ)
  34.   )                                     ; defun *error*
  35.   (cond ((and selset
  36.               (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
  37.               (setq ocol (vla-getinterfaceobject
  38.                            (vlax-get-acad-object)
  39.                            (strcat "AutoCAD.AcCmColor." (substr (getvar 'acadver) 1 2))
  40.                          )
  41.               )                         ; Supported Color Methods: acColorMethodByACI acColorMethodByBlock acColorMethodByLayer acColorMethodByRGB acColorMethodForeground
  42.          )                              ; and
  43.          (vla-endundomark acdoc)
  44.          (vla-startundomark acdoc)      ; If all objects in the SS will have the same color, then Initially assign the color propert(y/ies) for the color object:
  45.          (vla-put-colormethod ocol accolormethodbyaci)
  46.          (vla-put-colorindex ocol 111)  ; For Index Colors
  47.                                         ;(setq RGB '(255 255 255)) (vla-put-ColorMethod col acColorMethodByRGB) (apply 'vla-SetRGB (cons col RGB)) ; For RGB
  48.          (vlax-for o (setq acss (vla-get-activeselectionset acdoc)) (vla-put-truecolor o ocol))
  49.                                         ; vlax-for
  50.         )
  51.   )                                     ; cond
  52.   (*error* nil)
  53.   (princ)
  54. )                                       ; defun C:test
  55. (defun foo_gr2 (selset / vlaobj trccol)
  56.   (foreach forelm (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
  57.     (_putcolor (vlax-ename->vla-object forelm) 111)
  58.   )
  59.   (princ)
  60. )
  61. (defun foo_ale (selset / vlaobj trccol)
  62.   (foreach forelm (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
  63.     (setq trccol (vla-get-truecolor (setq vlaobj (vlax-ename->vla-object forelm))))
  64.     (vla-put-colorindex trccol 111)
  65.     (vla-put-truecolor vlaobj trccol)
  66.   )
  67.   (princ)
  68. )
  69. (defun foo_roy (selset /)               ;only to change the color method
  70.   (foreach forelm (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
  71.     (vla-put-color (vlax-ename->vla-object forelm) 111)
  72.   )
  73.   (princ)
  74. )
  75. (defun foo_ron (selset)                 ;only to change the color method
  76.   (foreach a (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
  77.     ;; (entmod (vl-remove-if '(lambda (x) (member (car x) '(420 430))) (entget a)))
  78.     (entmod (append (entget a) '((62 . 111))))
  79.   )
  80.   (princ)
  81. )
  82. (setq selset (ssget ":L"))
  83. (sslength selset)
  84. (benchmark '((foo_grr selset)(foo_gr2 selset) (foo_ale selset) (foo_ron selset) (foo_roy selset)))

« Last Edit: November 29, 2017, 04:01:10 PM by ronjonp »

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: Vla-put-TrueColor on thousands of entities
« Reply #10 on: November 29, 2017, 04:19:54 PM »


but I would like a function that also works in ODBX Doc
You've should mentioned this in the very start - so we'd know that vanilla is not an option.  :tongue2:
I apologize if I made the wrong question, I thought the title and test example were sufficient, anyway I think that the same is also interesting.
Thanks for the example with Odbx, I have already written my function but I think I will also use your suggestion to improve it.

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: Vla-put-TrueColor on thousands of entities
« Reply #11 on: November 29, 2017, 04:53:08 PM »

Why are you benchmarking functions that perform different tasks?
Code: [Select]
Sorry for wrong benchmarking it was only to find the best direction:
    (FOO_ROY SELSET).....2625 / 1.21                 >>>>>>>>>>          ;only to change the color method
    (FOO_RON SELSET).....3171 / 1 <slowest>    >>>>>>>>>>           ;only to change the color method

What I have not yet understood:
Code: [Select]
1)
  a) (setq TrCCol (vla-get-TrueColor (vlax-ename->vla-object (ssname SelSet 0))))
  b) (setq TrCCol (vla-GetInterfaceObject (vlax-get-acad-object) (strcat "AutoCAD.AcCmColor." (substr (getvar 'acadver) 1 2))))
why does it also work by setting TrCCol on the first selection entity as in a) without using form b)?
Code: [Select]
2) Which of these versions is more correct?
(defun Foo_al2 (SelSet / VlaObj TrCCol)
   (setq TrCCol (vla-get-TrueColor (vlax-ename->vla-object (ssname SelSet 0))))
   (foreach ForElm (vl-remove-if 'listp (mapcar 'cadr (ssnamex SelSet)))
      (vla-put-ColorIndex TrCCol 2)
      (vla-put-TrueColor (vlax-ename->vla-object ForElm) TrCCol)
    )
  (princ)
)
(defun Foo_al4 (SelSet / VlaObj TrCCol)
   (setq TrCCol (vla-get-TrueColor (setq VlaObj (vlax-ename->vla-object (ssname SelSet 0)))))
   (vla-put-ColorMethod TrCCol acColorMethodByACI) (vla-put-ColorIndex TrCCol 4) ; For Index Colors
   (foreach ForElm (vl-remove-if 'listp (mapcar 'cadr (ssnamex SelSet)))
      (vla-put-TrueColor VlaObj TrCCol)
    )
  (princ)
)
Code: [Select]
3) You used (vla-put-Color ...) in foo_roy, if I could use it I would not have all these questions asked,
unfortunately there are entities that do not have the "Color" property:
; IAcadLine: Interfaccia AutoCAD Line (Linea)
; valori della proprietà:
;   Angle (RO) = 3.14159
;   Application (RO) = #<VLA-OBJECT IAcadApplication 00007ff79d2b3318>
;   Delta (RO) = (-15019.6 0.0 0.0)
;   Document (RO) = #<VLA-OBJECT IAcadDocument 00000000340a0878>
;   EndPoint = (861402.0 -849.001 0.0)
;   EntityTransparency = "DaLayer"
;   Handle (RO) = "D1C1D2"
;   HasExtensionDictionary (RO) = 0
;   Hyperlinks (RO) = #<VLA-OBJECT IAcadHyperlinks 0000000084796b98>
;   Layer = "500-CO1"
;   Length (RO) = 15019.6
;   Linetype = "ByLayer"
;   LinetypeScale = 1.0
;   Lineweight = -1
;   Material = "ByLayer"
;   Normal = (0.0 0.0 1.0)
;   ObjectID (RO) = 1631
;   ObjectID32 (RO) = 1631
;   ObjectName (RO) = "AcDbLine"
;   OwnerID (RO) = 1632
;   OwnerID32 (RO) = 1632
;   PlotStyleName = "ByLayer"
;   StartPoint = (876422.0 -849.001 0.0)
;   Thickness = 0.0
;   TrueColor = #<VLA-OBJECT IAcadAcCmColor 0000000084797670>
;   Visible = -1

Sorry for my text formatting.

ronjonp

  • Needs a day job
  • Posts: 7526
Re: Vla-put-TrueColor on thousands of entities
« Reply #12 on: November 29, 2017, 06:47:25 PM »
When applying index colors there is no need to get the color object, vla-put-color works? Just wrap it in vl-catch-all-apply.

Maybe I'm confusing what you want to do, but my interpretation was you only use index colors right? If so, why apply true color that's really an index?
« Last Edit: November 29, 2017, 06:57:35 PM by ronjonp »

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

Grrr1337

  • Swamp Rat
  • Posts: 812
Re: Vla-put-TrueColor on thousands of entities
« Reply #13 on: November 29, 2017, 07:39:45 PM »
For 1)
I could provide nothing else, aside from the console observations:
Code: [Select]
_$ (setq oCol1 (vla-GetInterfaceObject (vlax-get-acad-object) (strcat "AutoCAD.AcCmColor." (substr (getvar 'acadver) 1 2))))
#<VLA-OBJECT IAcadAcCmColor 000000013204b9d0>
_$ (setq oCol2 (vla-get-TrueColor (vlax-ename->vla-object (car (entsel)))))
#<VLA-OBJECT IAcadAcCmColor 000000013204aef0>
_$ (equal oCol1 oCol2) ; Looks like both color objects are different
nil

_$ (vla-put-ColorMethod oCol2 acColorMethodByACI)
nil
_$ (vla-put-ColorIndex oCol2 4) ; After this the Color of the originally picked object was NOT CHANGED
nil

_$ (vla-put-TrueColor (vlax-ename->vla-object (car (entsel))) oCol2) ; After this the color of the selected object(here) is changed to 4 (cyan)
nil
_$ (vla-put-TrueColor (vlax-ename->vla-object (car (entsel))) oCol1) ; After this the color of the selected object(here) is changed to the color property of the other color object.
nil
But my thinking is: obtain just once the color object and avoid any additional checks within the iteration.
If you intend just to assign index colors, then just use Ron's suggestion with vla-put-color, since I was just making sure for the RGB ones.

For 2)
If you intend to assign the same color for all objects in the selection, (Foo_al4) should be more effective.
(Foo_al2) should be used [within a conditional] if you want to assign color for certain objects from the selection.

For 3)
Only Index colors? = Ron's suggestion.




 :-) Now.. something curious, which one is faster?:

Code: [Select]
(setq oCol (vla-GetInterfaceObject (vlax-get-acad-object) (strcat "AutoCAD.AcCmColor." (substr (getvar 'acadver) 1 2))))
(vla-put-ColorMethod oCol acColorMethodByACI) (vla-put-ColorIndex oCol 4)
(foreach o (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS))))
  (vla-put-TrueColor o oCol)
)

or:
Code: [Select]
(foreach o (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS))))
  (vla-put-Color o 4)
)
(apply ''((a b c)(a b c))
  '(
    (( f L ) (apply 'strcat (f L)))
    (( L ) (if L (cons (chr (car L)) (f (cdr L)))))
    (72 101 108 108 111 32 87 111 114 108 100)
  )
)
vevo.bg

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: Vla-put-TrueColor on thousands of entities
« Reply #14 on: November 30, 2017, 04:00:33 AM »

Thanks Ron & Grrr1337, I post my code (sorry for bad english) and a sample DWG:
Code: [Select]
; Arguments (all the names are compared in uppercase).
;   LyrNms: Layer  names - Wcmatch string > "Layer1,Layer2*"    or "*" for all or "" for None
;   BlkNms: Block  names - Wcmatch string > "Block001,BlockNnn" or "*" for all or "" for None
;                > "[~*]*"      > no anonimous blocks
;   PrpLst: '(("DEFAULTLAYER" "LayerNew" 256 "ByLayer") ("LAYERORI" "LayerNew" ColorNew LinetypeNew)(...))
;
;   BitFlg: 1 = delete attribs
;   PrxStr: "X_" prefisso nome del blocco > se nil non rinomina
;   KeyVal: nil rename blocks with _OnReq_Utils_SerialSnName  -  string for mask in _OnReq_Utils_EcryptSnName
;
; Example:
; (setq PrpLst '(("DEFAULTLAYER" "0" 1 "ByLayer") ("N" "N2" 2 "ByLayer")("A" "A3" 3 "ByLayer")("T" "T4" 4 "ByLayer")))
;
; (ALE_Block_Edit_ChangeDefProps (vla-get-activedocument (vlax-get-acad-object))  "*"    "*"     "*"   "*"    PrpLst  0     nil    nil)
;                                                                         VlaDoc LyrNms BlkNms TagNms TagVls PrpLst BitFlg PrxStr KeyVal
;
(defun ALE_Block_Edit_ChangeDefProps (VlaDoc LyrNms BlkNms TagNms TagVls PrpLst BitFlg PrxStr KeyVal / TrCCol BlkNam LyrNam Countr TmpLst ObjNam)
  (setq Countr 0)
  (vlax-for BlkFor (vla-get-blocks VlaDoc)
    (and
      (= :vlax-false (vla-get-IsXref BlkFor) (vla-get-IsLayout BlkFor)) 
      (progn
        (and
          (wcmatch (strcase (setq BlkNam (vla-get-name BlkFor))) (strcase BlkNms))
          (progn
            (and
              PrxStr
              (if KeyVal
                (_OnReq_Utils2_Put_UniqueSnName BlkFor BlkNam PrxStr                  KeyVal)
                (_OnReq_Utils2_Put_UniqueSnName BlkFor  nil   PrxStr (setq Countr (1+ Countr)))
              )
            )
          );progn
        );and
        (vlax-for ObjFor BlkFor
          (and
            (not (= (setq ObjNam (vla-get-objectname ObjFor)) "AcDbBlockTableRecord"))
            (wcmatch (setq LyrNam (strcase (vla-get-Layer ObjFor))) (strcase LyrNms))
            (if (and (= 1 (logand 1 BitFlg)) (= ObjNam "AcDbAttributeDefinition"))
              (vla-delete ObjFor)
              (progn
                (or
                  (setq TmpLst (assoc LyrNam PrpLst))
                  (setq TmpLst (car PrpLst))
                )
                (and
                  TmpLst
                  (progn
                    (setq TrCCol (vla-get-TrueColor ObjFor)) (vla-put-ColorIndex TrCCol (caddr TmpLst)); 0= ByBlock - 256 ByLayer
                    (vl-catch-all-apply
                      (function (lambda ( ) (vla-Put-Layer ObjFor (cadr TmpLst)) (vla-put-TrueColor ObjFor TrCCol) (vla-put-Linetype ObjFor (cadddr TmpLst))))
                    )
                  )
                )
                ;TagNms TagVls non ancora utilizzate - qui altre elaborazioni AcDbAttributeDefinition
              )
            );if
          );and
        )
      )
    );or
  );vlax-for
)
;
(defun ALE_Utl_GetItem (VlaCol KeyNam / VlaObj)
  (vl-catch-all-apply
   '(lambda ( )
      (setq VlaObj (vla-item VlaCol KeyNam))
    )
  )
  VlaObj
)
Code: [Select]
(or *AcadApp* (setq *AcadApp* (vlax-get-Acad-Object)            ))
(or *AcAcDwg* (setq *AcAcDwg* (vla-get-ActiveDocument *AcadApp*)))
(or *AcLayrs* (setq *AcLayrs* (vla-get-Layers         *AcAcDwg*)))
(or (ALE_Utl_GetItem *AcLayrs* "DEFAULTLAYER") (vla-Put-Color (vla-add *AcLayrs* "DEFAULTLAYER") 10))
(or (ALE_Utl_GetItem *AcLayrs* "N2") (vla-Put-Color (vla-add *AcLayrs* "N2") 20))
(or (ALE_Utl_GetItem *AcLayrs* "A3") (vla-Put-Color (vla-add *AcLayrs* "A3") 30))
(or (ALE_Utl_GetItem *AcLayrs* "T4") (vla-Put-Color (vla-add *AcLayrs* "T4") 40))
Code: [Select]
(setq PrpLst  '(("DEFAULTLAYER" "0" 256 "ByLayer") ("N" "N2" 256 "ByLayer")("A" "A3" 256 "ByLayer")("T" "T4" 256 "ByLayer")))

(ALE_Block_Edit_ChangeDefProps (vla-get-activedocument (vlax-get-acad-object))  "*" "*" "*" "*" PrpLst 0 nil nil)


(setq PrpLst  '(("DEFAULTLAYER" "0" 1 "ByLayer") ("N" "N2" 2 "ByLayer")("A" "A3" 3 "ByLayer")("T" "T4" 4 "ByLayer")))
(ALE_Block_Edit_ChangeDefProps (vla-get-activedocument (vlax-get-acad-object))  "*" "*" "*" "*" PrpLst 0 nil nil)