(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)You could also remove group code 420 to convert to index color:
...
Ahhhh color books :)You could also remove group code 420 to convert to index color:
...
remove also 430 gc. ;)
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
(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)
))
but I would like a function that also works in ODBX Doc
I have tested all method:
...
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.
Why are you benchmarking functions that perform different tasks?
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 methodCode: [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)
))
;;;_$
;;;
;;;_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...">
;;;_$
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.but I would like a function that also works in ODBX DocYou've should mentioned this in the very start - so we'd know that vanilla is not an option. :tongue2:
Why are you benchmarking functions that perform different tasks?
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
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)?
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)
)
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
_$ (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.(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)
)
(foreach o (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS))))
(vla-put-Color o 4)
)
; 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
)
(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))
(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)
Why still:Code - Auto/Visual Lisp: [Select]When this does the same thing?Code - Auto/Visual Lisp: [Select]Here's some quick thoughts minus the proplist and layer masking:
...
(vl-catch-all-apply ;
(function (lambda ( ) (vla-Put-Layer ObjFor (cadr TmpLst)) (vla-put-Color ObjFor (caddr TmpLst)) (vla-put-Linetype ObjFor (cadddr TmpLst))))
)
I have modified... now it is working... :crazy2: I do not know why!(defun foo (doc color erase_att)
(vlax-for l (vla-get-layers doc) (and (= -1 (vlax-get l 'lock)) (vlax-put l 'lock 0)))
(vlax-for a (vla-get-blocks doc)
(if (= 0 (vlax-get a 'isxref) (vlax-get a 'islayout))
(vlax-for b a
(vl-catch-all-apply 'vla-put-color (list b color))
(print (vla-get-objectname b)) (princ " 1 ")
(cond
( (and (= "AcDbBlockReference" (vla-get-objectname b)) (= -1 (vlax-get b 'hasattributes)))
(print (vla-get-objectname b)) (princ " 2 ")
(foreach c (vlax-invoke b 'getattributes)
(if erase_att
(vl-catch-all-apply 'vla-delete (list c))
(vl-catch-all-apply 'vla-put-color (list c color))
)
)
)
)
)
)
)
)
In my sample DWG:Command: (foo (vla-get-activedocument (vlax-get-acad-object)) 1 t)
"AcDbLine" 1
"AcDbLine" 1
"AcDbLine" 1
"AcDbAttributeDefinition" 1
"AcDbAttributeDefinition" 1
"AcDbAttributeDefinition" 1
"AcDbAttributeDefinition" 1
"AcDbCircle" 1
"AcDbText" 1 nil
There are not "AcDbBlockReference" (only inside Layout/Model) then attribs are not deleted.
Note: my function ALE_Block_Edit_ChangeDef(inition)Props works on "AcDbBlockTableRecord" and delete "AcDbAttributeDefinition" not "AcDbAttribute"
so the "INSERT" loose only constant Attributes.
You're right .. copy paste error :oops: need to take out the layout check:
...
BTW .. why are you doing this ? Seems like you're intentionally trashing a drawing?
Yes, I am cleaning all Block definitions (delete attribs), change layers/color/linetype, rename/encrypt.
After, I pass all Model/Layouts change layers/color/linetype for all objects, transform Attribs to Texts. This is done on a copy of the DWG.
I apologize to everyone for Truecolor question, maybe I was initially trying to apply vla-put-color to objects that did not accept it, without using the form
with vl-catch-all-apply.