[讨论]：已解决

kevinchan

最初由 snoopychen 发布
[B]改了一下,大概和你的要求比较接近了,由于看不懂你的r是怎么变化的
所以里面这句比较奇怪 (setq rmin 0.2167 rmax 0.4506 )
这个是根据最大半径和最小半径来插值的,你可以自己改
[php]
;;; ，qjchen@xdcad

(de... [/B]

15楼的程序不错，可以稍微改一下改成框选所有圆，并进行颜色渐变！
非常感谢！

xyp1964

参考：

xyp1964

2. [FONT=courier new](load "xyp_lib.vlx")                        ;版本 V.20060515
   
3. ;|下载和加载通用函数(可在签名栏直接下载后放到搜索路径下)
   
4. 利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序：
   
5. ★1·在acad.lsp中增加(load"xyp_lib.vlx")
   
6. ■2·在每个程序内增加(load"xyp_lib.vlx")
   
7. ■3·在command下，输入(load"xyp_lib.vlx")
   
8. ■4·在菜单.mnl中增加(load"xyp_lib.vlx")
   
9. ■5·将xyp_lib.vlx文件直接拽到cad屏幕
   
10. [COLOR=red] ★通用函数下载地址：[/COLOR]
    
11. [url]http://www.xdcad.net/forum/attachment.php?s=&postid=1606661[/url]
    
12. [url]http://free.ys168.com/?xyp1964[/url]
    
13. |;
    
14. 
    
15. (defun c:test ()
    
16.   (cmdla0)
    
17.   (setq ss1 (SSALL))
    
18.   (main)
    
19.   (setq        ss  (ssdiff (SSALL) ss1)
    
20.         plst (xyp-Sort-PList (xyp-Sort ss 40 "none") 9)
    
21.         j    0
    
22.   )
    
23.   (foreach sn plst
    
24.     (setq s1 (cdr sn)
    
25.           j  (1+ j)
    
26.     )
    
27.     (xyp-put-TrueColor j s1)
    
28.   )
    
29.   (cmdla1)
    
30. )
    
31. (defun main ()
    
32.   (setvar "osmode" 0)
    
33.   (setq        a  1.0
    
34.         b  1.2
    
35.         c  60
    
36.         d1 -18
    
37.         d0 18
    
38.         x  4
    
39.         i  1
    
40.   )
    
41.   (while (and (<= x c) (>= x 4))
    
42.     (setq d  (* 0.5774 x -1.0)
    
43.           y  -18
    
44.           d2 (min d0 (* 0.5774 x))
    
45.           m  1
    
46.     )
    
47.     (while (<= y 18)
    
48.       (setq r  (/ (+ (* (sqrt (+ (* x x) (* y y))) 0.008) 0.40) 2.0)
    
49.             y1 (- y (* (/ b 2) (rem i 2)))
    
50.             pt (list x y1)
    
51.             h  (abs (/ x 1.732))
    
52.             n  (abs y)
    
53.             k  (+ (/ (- (/ (/ n x) 0.5774) 1) 11) 1)
    
54.       )
    
55.       (if (and (< x 30) (> n h))
    
56.         (setq r (* (abs k) r))
    
57.       )
    
58.       (command "circle" pt r)
    
59.       (setq y (+ y b))
    
60.     )
    
61.     (setq x (+ x a)
    
62.           i (+ i 1)
    
63.     )
    
64.   )
    
65. )[/FONT]

[FONT=courier new](load "xyp_lib.vlx")                        ;版本 V.20060515<br /> ;|下载和加载通用函数(可在签名栏直接下载后放到搜索路径下)<br /> 利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序：<br /> ★1·在acad.lsp中增加(load"xyp_lib.vlx")<br /> ■2·在每个程序内增加(load"xyp_lib.vlx")<br /> ■3·在command下，输入(load"xyp_lib.vlx")<br /> ■4·在菜单.mnl中增加(load"xyp_lib.vlx")<br /> ■5·将xyp_lib.vlx文件直接拽到cad屏幕<br /> [COLOR=red] ★通用函数下载地址：[/COLOR]<br /> [url]http://www.xdcad.net/forum/attachment.php?s=&postid=1606661[/url]<br /> [url]http://free.ys168.com/?xyp1964[/url]<br /> |;<br /> <br /> (defun c:test ()<br />   (cmdla0)<br />   (setq ss1 (SSALL))<br />   (main)<br />   (setq        ss  (ssdiff (SSALL) ss1)<br />         plst (xyp-Sort-PList (xyp-Sort ss 40 "none") 9)<br />         j    0<br />   )<br />   (foreach sn plst<br />     (setq s1 (cdr sn)<br />           j  (1+ j)<br />     )<br />     (xyp-put-TrueColor j s1)<br />   )<br />   (cmdla1)<br /> )<br /> (defun main ()<br />   (setvar "osmode" 0)<br />   (setq        a  1.0<br />         b  1.2<br />         c  60<br />         d1 -18<br />         d0 18<br />         x  4<br />         i  1<br />   )<br />   (while (and (<= x c) (>= x 4))<br />     (setq d  (* 0.5774 x -1.0)<br />           y  -18<br />           d2 (min d0 (* 0.5774 x))<br />           m  1<br />     )<br />     (while (<= y 18)<br />       (setq r  (/ (+ (* (sqrt (+ (* x x) (* y y))) 0.008) 0.40) 2.0)<br />             y1 (- y (* (/ b 2) (rem i 2)))<br />             pt (list x y1)<br />             h  (abs (/ x 1.732))<br />             n  (abs y)<br />             k  (+ (/ (- (/ (/ n x) 0.5774) 1) 11) 1)<br />       )<br />       (if (and (< x 30) (> n h))<br />         (setq r (* (abs k) r))<br />       )<br />       (command "circle" pt r)<br />       (setq y (+ y b))<br />     )<br />     (setq x (+ x a)<br />           i (+ i 1)<br />     )<br />   )<br /> )[/FONT]

kevinchan

最初由 xyp1964 发布
[B][CODE](load "xyp_lib.vlx")                        ;版本 V.20060515
;|下载和加载通用函数(可在签名栏直接下载后放到搜索路径下)
利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序：
★1... [/B]

运行有错误
Command: test
Font file doesn't exist.Unknown command "0".  Press F1 for help.
Unknown command "1".  Press F1 for help.
Unknown command "0".  Press F1 for help.
Unknown command "TEST".  Press F1 for help.
Unknown command "TEST".  Press F1 for help.

xyp1964

最初由 kevinchan 发布

kevinchan

同样运行在命令栏有错误，
Font file doesn't exist.Unknown command "0".  Press F1 for help.
Unknown command "1".  Press F1 for help.
Unknown command "0".  Press F1 for help.
Unknown command "JBS".  Press F1 for help.
Unknown command "JBS".  Press F1 for help.

xyp1964

最初由 kevinchan 发布
[B]同样运行在命令栏有错误，
Font file doesn't exist.Unknown command "0".  Press F1 for help.
Unknown command "1".  Press F1 for help.
Unknown command "0".  Press F1 for help.
Unknown command "JBS".  ... [/B]

编译程序命令:jbs
效果

snoopychen

学习了一下xyp版主的图,觉得原来用rgb插值的方法并不好,改成如下的hsl插值方法,
这个期间,到easyrgb网站找到hsl和rgb转换的公式
下面这个程序是按照16楼的意思,选取一堆圆,按照半径大小来渐变颜色,在对话框选颜色的时候,最好先选靠右边的颜色,再选靠左边的颜色,这样的效果好些,这是程序编写不够严密之故
[php]
;;; 选圆改变渐变色,采用hsl值插值的方法 qjchen@xdcad

(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 at xdcad
;;;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))
  )
)
[/php]

kevinchan

挺不错的， 已经很完美了.
如果选择的不是圆,而是矩形或者菱形,又或者是椭圆呢?

snoopychen

假如是相似型的话，有一个可以用数学公式描述其相对大小的就都不难，只是繁琐而已

xyp1964

依据实体面积排序的颜色渐变：

xyp1964

stjbs(实体渐变色)

dinochen1983

我也来一个，AUTOCAD小狗图

雨箭风刀

楼上这个作的不错嘛