color gradient change

 


;;; Function:Change the color of the circle gradient according to their radius

;;; by qjchen,South China University of Technology

;;; Thanks Menzi for his good function 

;;; 2006.5.17

 

;;main function
(defun c:test2 (/ rgb1 hsl1 rgb2 hsl2 color1 rcolor1 color2 rcolor2 rmin rmax sscircle i cirr cirobj ratio irgb
           )
  (setvar "osmode" 0)
  ;;;get the start color and end color
  (setq color1 (acad_truecolordlg (cons 420 2594)))
  (setq rcolor1 (cdr (assoc 420 (cdr color1))))
  (setq rgb1 (megetrgb rcolor1))
  (setq hsl1 (MeCalcHslModel rgb1))
  (setq color2 (acad_truecolordlg (cons 420 12594)))
  (setq rcolor2 (cdr (assoc 420 (cdr color2))))
  (setq rgb2 (megetrgb rcolor2))
  (setq hsl2 (MeCalcHslModel rgb2))
  (setq sscircle (ssget '((0 . "Circle"))))
  (setq i 0)
  ;;;get the maximum and minimum radius of the circle
  (repeat (sslength sscircle)
    (setq cirr (cdr (assoc 40 (entget (ssname sscircle i)))))
    (if (= i 1)
      (setq rmin cirr
        rmax cirr
      )
    )
    (if (< cirr rmin)
      (setq rmin cirr)
    )
    (if (> cirr rmax)
      (setq rmax cirr)
    )
    (setq i (1+ i))
  )

  (setq i 0)
  (repeat (sslength sscircle)
    (setq cirr (cdr (assoc 40 (entget (ssname sscircle i)))))
    (setq cirobj (vlax-ename->vla-object (ssname sscircle i)))
    (setq ratio (/ (- cirr rmin) (- rmax rmin)))
    (setq irgb (intercolor hsl1 hsl2 ratio))
    (puttruecolor cirobj ratio irgb)
    (setq i (1+ i))
  )
)


;;color interpolation
(defun intercolor(shsl1 shsl2 sratio / interhsl interrgb)
  (setq interhsl (list (interpolating (nth 0 shsl1) (nth 0 shsl2) sratio)
            (interpolating (nth 1 shsl1) (nth 1 hsl2) sratio)
            (interpolating (nth 2 shsl1) (nth 2 hsl2) sratio)
          )
  )
  (setq interrgb (hsl2rgb interhsl))
  interrgb
)


;;put true color to object
(defun puttruecolor (obj rati interrgb / AcadObject AcadDocument mSpace center
             acCmColor
            )
  (VL-LOAD-COM)
  (setq AcadObject (vlax-get-acad-object)
    AcadDocument (vla-get-ActiveDocument AcadObject)
    mSpace (vla-get-ModelSpace AcadDocument)
  )
  (setq acCmColor (vla-GetInterfaceObject (vlax-get-acad-object)
                      "AutoCAD.AcCmColor.16"
          )
  )
  (vla-put-colorMethod acCmColor acColorMethodByRGB)
  (vla-put-colorIndex acCmColor 7)
  (vla-put-entityColor acCmColor -1073741824)
  (vla-SetRGB acCmColor (nth 0 interrgb) (nth 1 interrgb) (nth 2 interrgb)
  )
  (vla-put-trueColor obj acCmColor)
)


;;;;;GetRGB value
(defun MeGetRGB (Val)
  (list (lsh Val -16) (lsh (lsh Val 16) -24) (lsh (lsh Val 24) -24))
)


;;function for interpolating by qjchen,
;;not a b should be integer,c should be real between [0,1]
;;so start from a 0 and end b 1, c is the ratio between a and b
(defun interpolating (a b c / e)
  (setq a (itor a)
    b (itor b)
  )
  (setq e (- a (* c (/ (- a b)))))
  (setq e (fix e))
  e
)

;;;function for convert integer to real
(defun itor (a)
  (atof (itoa a))
)


;;;convert hsl value to rgb value,by qjchen 

;;;HSL value should be integer
;;;The formular is obtained from the website of easyRGB
;;;The hsl is taken from Autocad H:[0,360],S:[0,100],L:[0,100]

(defun hsl2rgb (hsllist / h s l r g b var2 var1)
  (setq h (/ (nth 0 hsllist) 360.0)
    s (/ (nth 1 hsllist) 100.0)
    l (/ (nth 2 hsllist) 100.0)
  )
  (cond
    ((= s 0)
      (setq r (* l 255)
        g (* l 255)
        b (* l 255)
      )
    )
    ((/= s 0)
      (cond
    ((< l 0.5)
      (setq var2 (* l (1+ s)))
    )
    (t
      (setq var2 (- (+ l s) (* s l)))
    )
      )
      (setq var1 (- (* 2 l) var2))
      (setq r (* 255 (func var1 var2 (+ h 0.33333))))
      (setq g (* 255 (func var1 var2 h)))
      (setq b (* 255 (func var1 var2 (- h 0.33333))))
    )
  )
  (list (fix r) (fix g) (fix b))
)

(defun func (v1 v2 vh / result)
  (if (< vh 0)
    (setq vh (1+ vh))
  )
  (if (> vh 1)
    (setq vh (- vh 1))
  )
  (cond
    ((< (* 6 vh) 1)
      (setq result (+ v1 (* 6 vh (- v2 v1))))
    )
    ((< (* 2 vh) 1)
      (setq result v2)
    )
    ((< vh 0.66667)
      (setq result (+ v1 (* 6 (- v2 v1) (- 0.666667 vh))))
    )
    (t
      (setq result v1)
    )
  )
  result
)

; Author      :   jme
; Copyright   :   MENZI ENGINEERING GmbH, Switzerland
;;; by Menzi, for convert rgb value to hsl value
(defun MeCalcHslModel (Rgb / ColDta ColHue ColLum ColSat MaxVal MinVal
               TmpRgb
              )
  (setq TmpRgb (mapcar
         '/
         Rgb
         '(255.0 255.0 255.0)
           )
    MaxVal (apply
         'max
         TmpRgb
           )
    MinVal (apply
         'min
         TmpRgb
           )
    ColDta (- MaxVal MinVal)
    ColLum (/ (+ MaxVal MinVal) 2.0)
    ColSat 0.0
    ColHue 0.0
  )
  (if (/= MaxVal MinVal)
    (setq ColSat (if (<= ColLum 0.5)
           (/ ColDta (+ MaxVal MinVal))
           (/ ColDta (- 2.0 MaxVal MinVal))
         )
      ColHue (cond
           ((= (car TmpRgb) MaxVal)
             (/ (- (cadr TmpRgb) (caddr TmpRgb)) ColDta)
           )
           ((= (cadr TmpRgb) MaxVal)
             (+ 2.0 (/ (- (caddr TmpRgb) (car TmpRgb)) ColDta))
           )
           ((= (caddr TmpRgb) MaxVal)
             (+ 4.0 (/ (- (car TmpRgb) (cadr TmpRgb)) ColDta))
           )
         )
      ColHue (* ColHue 60.0)
      ColHue (if (minusp ColHue)
           (+ ColHue 360.0)
           ColHue
         )
    )
  )

  (list (if (> ColSat 0.0)
      (fix ColHue)
      nil
    ) (fix (* ColSat 100.0)) (fix (* ColLum 100.0))
  )
)