Topic: TrueColor object 2004 (R16.0)

[Mark]

I have just started looking into the TrueColor object (AcadAcCmColor) in 2004, this is what I have thus far.

Code: [Select]


;; to change an objects color to ByLayer
;; obj = valid VLA-Object
(defun cotbyl (obj / tco)
  (setq tco (vla-get-TrueColor obj))
  (vlax-put-property tco 'ColorMethod acColorMethodByLayer)
  (vlax-put-property obj 'TrueColor tco)
  (vlax-release-object tco)
  )

[SMadsen]

Then I'll start looking into the plain stuff behind the truecolors

Here are conversions between RGB colors and the longInt from code 420 (can't believe they didn't document the conversions - is it the end of good ol' AutoLISP?):

Code: [Select]

(defun Long2RGB (color)
  (setq r (fix (/ color 65536))
        g (fix (/ (- color (* r 65536)) 256))
        b (- color (* r 65536) (* 256 g)))
  (list r g b)
)

(defun RGB2Long (r g b)
  (+ (* r 65536) (* g 256) b)
)

[SMadsen]

Oh, they did document it in the DXF reference. Phewww

[Craig Davis]

Below is a lisp program I wrote to insert symbols on various codes and to convert colours etc. This was written originally for AutocadR14 and now displays an error as follows.

error: lisp value has no coercion to VARIANT with this type:  256

Code: [Select]

(defun ssget->vla-list (selection-set / index vla-list)
  (setq index (if selection-set
(1-
  (sslength selection-set)
)
-1
      )
  )
  (while (>= index 0)
    (setq vla-list
   (cons
     (vlax-ename->vla-object
       (ssname selection-set index)
     )
     vla-list
   )
  index    (1- index)
    )
  )
  vla-list
)

(defun MakeLay (Name)
  (vl-catch-all-apply
    'vlax-put-property
    (list
      (vla-get-ActiveDocument
(vlax-get-acad-object)
      )
      'ActiveLayer
      (vlax-invoke-method
(vla-get-layers
  (vla-get-ActiveDocument
    (vlax-get-acad-object)
  )
)
'Add
Name
      )
    )
  )
)

(defun c:PLACESDXF ()
  (vl-load-com)
  (setq thisdrawing
(vla-get-activedocument
   (vlax-get-acad-object)
)
  )
  (setq mspace (vla-get-modelspace thisdrawing))
  ;;creating arrays
  (setq layer_list_s
(vlax-make-safearray vlax-vbString '(0 . 1) '(1 . 24))
  ) ;create array sewer points
  (vlax-safearray-fill
    layer_list_s
    '(("swair"   "swcod"    "swcss" "swdcn"    "swdm"
       "swdwj"   "swelj"    "sweol" "swgcm"    "swio"
       "swjnt"   "swmat"    "swmdm" "swnrv"    "swoxy"
       "swpst"   "swsft"    "swstdm" "swsv"    "swtms"
       "swupj"   "swevt"    "swivt" "swmvt"
      )
      ("Air valve" "Change of grade"
       "Core sample site" "Decom sewer"
       "Drop manhole" "Downstream access shaft"
       "EOL access shaft" "End of line"
       "Gas check manhole" "Inspection opening"
       "Junction" "Maintenance shaft"
       "Multi drop manhole" "Non return valve"
       "Oxygen injection" "Pump station"
       "Maintenance shaft" "Standard manhole"
       "Stop valve" "Terminal maintenance"
       "Upstream access shaft" "Sewer vent"
       "Sewer vent" "Sewer vent"
      )
     )
  ) ;assign array values
  (setq layer_list_w
(vlax-make-safearray vlax-vbString '(0 . 1) '(1 . 26))
  ) ;create array water points
  (vlax-safearray-fill
    layer_list_w
    '(("wetair"    "wetcss"    "wetdcn"    "wetdlg"    "wetdls"
       "wetdos"    "weteol"    "wetfp"    "wetio"     "wetjnt"
       "wetmat"    "wetmet"    "wetnar"    "wetnrv"    "wetph"
       "wetps"    "wetrec"    "wetred"    "wetrss"    "wetsco"
       "wetser"    "wetstd"    "wetsv"    "wetswb"    "wetval"
       "wetzv"
      )
      ("Air valve"    "Cross"        "Decom water"
       "Cross"    "Cross"        "Dosing station"
       "Dead end cap"    "Fire plug"        "Inspection opening"
       "Pipe junction"    "Material change"   "Meter"
       "Non return valve"  "Non return valve"  "Pillar hydrant"
       "Pump station"    "Recorder"        "Reducer"
       "Cross"    "Scour"        "Service valve"
       "Stand pipe"    "Stop valve"        "Swabbing point"
       "Valve"    "Zone valve"
      )
     )
  ) ;assign array values
  (setq layer_list
(vlax-make-safearray vlax-vbString '(0 . 1) '(1 . 22))
  ) ;create array water & sewer mains
  (vlax-safearray-fill
    layer_list
    '(("swo*"    "weto*"     "sw000"    "sw100"     "sw150"
       "sw225"    "sw300"     "sw375"    "sw600"     "sw825"
       "swbig"    "wet000"    "wet100"    "wet150"    "wet225"
       "wet300"    "wet375"    "wet600"    "wet825"    "wetbig"
       "swdcp"    "wetdcp"
      )
      ("PLACES.sew_os_txt"   "PLACES.wat_os_txt"
       "Places_sew_mains"   "Places_sew_mains"
       "Places_sew_mains"   "Places_sew_mains"
       "Places_sew_mains"   "Places_sew_mains"
       "Places_sew_mains"   "Places_sew_mains"
       "Places_sew_mains"   "Places_wat_mains"
       "Places_wat_mains"   "Places_wat_mains"
       "Places_wat_mains"   "Places_wat_mains"
       "Places_wat_mains"   "Places_wat_mains"
       "Places_wat_mains"   "Places_wat_mains"
       "Places_sew_decom"   "Places_wat_decom"
      )
     )
  ) ;assign array values
;;setting all objects to bylayer
  (cond
    ((setq ssall (ssget "x")) ; get all entities
     (setq count 0)
     (repeat (sslength ssall)
       (setq obj (vlax-ename->vla-object (ssname ssall count)))
       (vlax-put-property obj "Color" 256)
       (vlax-put-property obj "Linetype" "ByLayer")
       (vlax-put-property obj "Lineweight" acLnWtByLwDefault)
       (vlax-release-object obj)
       (setq count (1+ count))
     )
    )
  )
  (princ "\nFinished processing all entities to ByLayer.")
  (princ)
  ;;inserting sewer symbols
  (setq ss1 (ssget->vla-list (ssget "x" '((0 . "POINT")))))
  (MakeLay "PLACES.symbol_sewer")
;Convert all points into a vla-object list
  (setq test1 0)
  (foreach item ss1 ;foreach will iterate through all point objects in above list
    (setq pt (vla-get-coordinates item)
;equiv to (cdr (assoc 10 el)) except it's a variant
  lyr (vla-get-layer item) ;equiv to (cdr (assoc 8 el))
  count 0
  test1 (+ test1 1)
    )
    (setq test1a 0)
    (setq T1 1)
    (while T1
      (setq test1a (+ test1a 1))
      (setq count (+ count 1)) ;sets number for first array
      (setq lyrlst (vlax-safearray-get-element layer_list_s 0 count))
      (if (= lyrlst lyr) ;check if layer_list_s matches point layer
(progn
  (vla-InsertBlock
    mspace
    pt
    (vlax-safearray-get-element layer_list_s 1 count)
    "1"
    "1"
    "1"
    "0"
  )
  (vla-delete item)
  (setq t1 nil)
) ;progn
      ) ;if
      (if (= count 24) ;else
(setq T1 nil)
      )
    ) ;while
  ) ;foreach
    ;;inserting water symbols
  (setq ss1 (ssget->vla-list (ssget "x" '((0 . "POINT")))))
  (MakeLay "PLACES.symbol_water")
  (setq test2 0)
  (foreach item ss1 ;foreach will iterate through all point objects in above list
    (setq pt (vla-get-coordinates item)
;equiv to (cdr (assoc 10 el)) except it's a variant
  lyr (vla-get-layer item) ;equiv to (cdr (assoc 8 el))
  count 0
  test2 (+ test2 1)
    )
    (setq test2a 0)
    (setq T1 1)
    (while T1
      (setq test2a (+ test2a 1))
      (setq count (+ count 1))
;sets number for first array
      (setq lyrlst (vlax-safearray-get-element layer_list_w 0 count))
      (if (= lyrlst lyr) ;check if layer_list_w matches point layer
(progn
  (vla-InsertBlock
    mspace
    pt
    (vlax-safearray-get-element layer_list_w 1 count)
    "1"
    "1"
    "1"
    "0"
  )
  (vla-delete item)
  (setq t1 nil)
) ;progn
      ) ;if
      (if (= count 26) ;else
(setq T1 nil)
      )
    )
;while
  ) ;foreach
  ;;changing layer names
  (setq count 1)
  (repeat 22
    (setq lyrname (vlax-safearray-get-element layer_list 0 count))
    (setq lyrnew (vlax-safearray-get-element layer_list 1 count))
    (setq ss1 (ssget->vla-list (ssget "x" (list (cons 8 lyrname)))))
    (foreach item ss1
      (vlax-put-property item "Layer" lyrnew)
    ) ;foreach
    (setq count (+ count 1))
  )
  (if (= lyrlst lyr)
    (PRINC "\nAll points processed.")
    (alert "WARNING. Points present not in layer list.")
  )
)
As far as I can tell the error is with the following piece of code. I've tried substituting Mark's piece of code but still getting an error.

Code: [Select]

(cond
    ((setq ssall (ssget "x")) ; get all entities
     (setq count 0)
     (repeat (sslength ssall)
       (setq obj (vlax-ename->vla-object (ssname ssall count)))
       (vlax-put-property obj "Color" 256)
       (vlax-put-property obj "Linetype" "ByLayer")
       (vlax-put-property obj "Lineweight" acLnWtByLwDefault)
       (vlax-release-object obj)
       (setq count (1+ count))
     )

How do I change the above code to correctly change the colour to ByLayer now that Autocad uses TrueColor? It's probably quite easy but I haven't done any lisp for a while due to being bogged down trying to get Civil3D up and running.

Thanks any help would be greatly appreciated.

Regards

Craig

[Jürg Menzi]

This functions you may give a start:

Code: [Select]

;
; -- Function MeGetTrueCol
; Returns a TrueColor list from an object.
; Arguments [Type]:
;   Obj = Object to read [VLA-OBJECT]
; Return [Type]:
;   > ColorMethod and Color or RGB list '(CM (R G B)) [LIST]
; Notes:
;   - AutoCAD 2k4+ only
;
(defun MeGetTrueCol (Obj / ColObj ColMet)
 (setq ColObj (vla-get-TrueColor Obj)
       ColMet (vla-get-ColorMethod ColObj)
 )
 (cons
  ColMet
  (if (= ColMet acColorMethodByRGB)
   (mapcar '(lambda (l) (vlax-get ColObj l)) '(Red Green Blue))
   (vla-get-ColorIndex ColObj)
  )
 )
)
;
; -- Function MeSetTrueCol
; Applies a TrueColor list to an object.
; Arguments [Type]:
;   Obj = Object to modify [VLA-OBJECT]
;   Lst = ColorMethod and Color or RGB list '(CM (R G B)) [LIST]
;         ColorMethodes:
;         - acColorMethodByACI
;         - acColorMethodByBlock
;         - acColorMethodByLayer
;         - acColorMethodByRGB
;         - acColorMethodForeground
; Return [Type]:
;   > Modified object [VLA-OBJECT]
; Notes:
;   - AutoCAD 2k4+ only
;
(defun MeSetTrueCol (Obj Lst / ColObj ColMet)
 (setq ColObj (vla-GetInterfaceObject (vlax-get-acad-object) "AutoCAD.AcCmColor.16")
       ColMet (car Lst)
 )
 (vla-put-ColorMethod ColObj ColMet)
 (if (= ColMet acColorMethodByRGB)
  (vla-SetRGB ColObj (cadr Lst) (caddr Lst) (cadddr Lst))
  (vla-put-ColorIndex ColObj (cdr Lst))
 )
 (vla-put-TrueColor Obj ColObj)
 (vlax-release-object ColObj)
 Obj
)

[T.Willey]

If you want to change objects color to bylayer I don't go through the TrueColor property, I just use Color.
(vla-put-Color obj 256)

Hope that helps.

[LE]

If you want to change objects color to bylayer I don't go through the TrueColor property, I just use Color.
(vla-put-Color obj 256)

Hope that helps.

Yes... but these guys have a note in their help document:

Remarks

This property is obsolete and will be removed in a future version. When using this property, colors can be set and read as numeric index values ranging from 0 to 256. Constants are provided for the standard seven colors, as well as for the BYBLOCK and BYLAYER designations.

We know, that it will take a lot of time before, they remove a function... but you never knows...

Have fun.

[T.Willey]

Thanks for the info Luis.  Hope it is still around in 2006, since I might be there soon.   

[Jeff_M]

It is, Tim.

I'm wondering though, since Craig said he's trying to get Civil3D up & running, if C3D's custom objects don't support the color property? Off to fire up Civil3d....back in 20 minutes, or so. (Yep, it takes a while for it to load on my laptop )

[Jeff_M]

Well, I tried using the "placesdxf" lisp in 3 different Civil3D2006 files and it ran without a hitch.

Craig, if you could post a small sample drawing that this occurs in I may be able to find the problem for you.

[Kerry]

For anyone following along ;

in the Acadxxxx\\Sample\\VisualLisp folder there is a file named color-util.lsp which has some usable functionality.

[zoltan]

Yea..this TrueColor stuff is really fun... Here are some functions I wrote for 2006 to put properties onto objetcs.

Code: [Select]

(SetQ zf_Acad-Object nil )
(Defun ZF_Get-Acad-Object ()
 (Cond
  (zf_Acad-Object)
  (T
   (VL-Load-Com )
   (SetQ zf_Acad-Object (VLAX-Get-Acad-Object) )
  )
 )
)

(SetQ zf_AcadColor nil )
(Defun ZF_Get-AcadColor ()
 (Cond
  (zf_AcadColor)
  (T
   (VL-Load-Com )
   (SetQ zf_AcadColor (VLA-GetInterfaceObject (ZF_Get-Acad-Object) "AutoCAD.AcCmColor.16") )
  )
 )
)

;;returns an AcCmColor object given color data. Data can be:
;;  1. Integer ACI number or Enumerator
;;  2. List of color data returned by ACAD_TrueColorDlg
;;  3. List of 3 Reals for RGB color
(Defun ZF_GetColor ( COLORDATA / oColor ColorVal sColorBook sColorName )
 (SetQ oColor (ZF_Get-AcadColor))
 (Cond
  ((= (Type COLORDATA) 'INT)
   (VLAX-Put-Property oColor "ColorIndex" COLORDATA )
  )
  ((And (ListP COLORDATA) (SetQ ColorVal (Cdr (Assoc 430 COLORDATA))))
   (SetQ sColorBook (SubStr ColorVal 1 (VL-String-Position (ASCII "$") ColorVal))
         sColorName (SubStr ColorVal (+ (VL-String-Position (ASCII "$") ColorVal) 2))
   )
   (VLA-SetColorBookColor oColor sColorBook sColorName )
  )
  ((And (ListP COLORDATA) (SetQ ColorVal (Cdr (Assoc 420 COLORDATA))))
   (VLA-SetRGB oColor (LSh ColorVal -16) (LSh (LSh ColorVal 16) -24) (LSh (LSh ColorVal 24) -24) )
  )
  ((And (ListP COLORDATA) (SetQ ColorVal (Cdr (Assoc 62 COLORDATA))))
   (VLAX-Put-Property oColor "ColorIndex" ColorVal )
  )
  ((ListP COLORDATA)
   (VLA-SetRGB oColor (Car COLORDATA) (Cadr COLORDATA) (Caddr COLORDATA) )
  )
  (T
   (PrinC "Error: Invalid Color Data" )
   (Exit )
  )
 )
 oColor
)

;;Releases the instace of the AutoCAD.AcCmColor.16
;;object created by GetColor
(Defun ReleaseColor ()
 (If (Not (VLAX-Object-Released-P zf_AcadColor))
  (VLAX-Release-Object zf_AcadColor )
 )
 (If zf_AcadColor
  (SetQ zf_AcadColor nil )
 )
 (GC )
)



Here is how I use it:

Code: [Select]

;;Sets Object properties to Properties List
;;PROPS : list of properties or nils
;; ( Layer Color Linetype Lineweight Plotstyle )
;;Layer: String
;;Color: Integer ACI number or Enumerator
;;       List of color data returned by ACAD_TrueColorDlg
;;       List of 3 Reals for RGB color
;;Linetype: String
;;Lineweight: acLineWeight Enumerator
;;Plotstyle: String
;;ex. ("LAYER" acByLayer "BYLAYER" acLnWtByLayer "BYLAYER")
(Defun Cons_Properties ( OBJ PROPS / oObject )
 (If (= (Type OBJ) 'ENAME)
  (SetQ oObject (VLAX-EName->VLA-Object OBJ) )
  (SetQ oObject OBJ )
 )
 
 (If (Nth 0 PROPS)
  (VLA-Put-Layer oObject (Nth 0 PROPS) )
 )
 (If (Nth 1 PROPS)
  (ProgN
   (VLA-Put-TrueColor oObject (ZF_GetColor (Nth 1 PROPS)) )
   (ReleaseColor )
  )
 )
 (If (Nth 2 PROPS)
  (VLA-Put-LineType oObject (Nth 2 PROPS) )
 )
 (If (Nth 3 PROPS)
  (VLA-Put-Lineweight oObject (Nth 3 PROPS) )
 )
 (If (And (= (GetVar "PSTYLEMODE") 0) (Nth 4 PROPS))
  (VLA-Put-PlotStyleName oObject (Nth 4 PROPS) )
 )
)

Do be aware: the ActiveX reference in 2006 list the SetColorBookColor method incorrectly:

object.SetColorBookColor (ColorName, ColorBook)

object
AcCmColor
The object or objects this method applies to.

ColorName
String; the name of the color.

ColorBook
String; the file name of the color book.

It took me about an hour of pulling out hair to figure that one out! :realmad:

[Craig Davis]

Well, I tried using the "placesdxf" lisp in 3 different Civil3D2006 files and it ran without a hitch.

Craig, if you could post a small sample drawing that this occurs in I may be able to find the problem for you.

It just seems to be giving me an error in our Civil3D. When I use it in Map5(Autocad2002) it works fine so it seems to be something specific to our Civil3D setup.

I'll look at what the posters above have supplied and do a bit of experimentation. This has me stumped for now.

Jeff thanks for trying it on your Civil3D. It's helped narrow down the problem to our installation of Civil3D if nothing else. I guess I could try it on the other installations of vanilla flavoured AutoCAD2006 that we have in the company to see if it has the same problem when I get time tomorrow.

Thanks for the posts people. Very much appreciated. 

[CAB]

Could you just skip the RTEXT objects?
Or did I miss the problem?

Code: [Select]

;;setting all objects to bylayer
(cond
  ((setq ssall (ssget "x")) ; get all entities
   (setq i -1)
   (while (setq ename (ssname ssall (setq i (1+ i))))
     (setq obj (vlax-ename->vla-object ename))
     (if (not (eq (vlax-get-property obj "ObjectName") "RText"))
       (progn
         (vlax-put-property obj "Color" 256)
         (vlax-put-property obj "Linetype" "ByLayer")
         (vlax-put-property obj "Lineweight" aclnwtbylwdefault)
       )
     )
     (vlax-release-object obj)
   )
  )
)