渐进式同心圆

荒野孤行

图片效果如下：
源码见附件。

tianyi1230

来个图片演示啊，朋友！嘿嘿，这回怎么这么含蓄

荒野孤行

tianyi1230 发表于 2013-12-13 22:42
来个图片演示啊，朋友！嘿嘿，这回怎么这么含蓄

没币了，赚点钱下载别人的源码，哈。

1993063

荒野孤行 发表于 2013-12-13 05:18
没币了，赚点钱下载别人的源码，哈。

这类型的早有了吧

荒野孤行

tianyi1230 发表于 2013-12-13 22:42
来个图片演示啊，朋友！嘿嘿，这回怎么这么含蓄

已传图片演示。

xyp1964

2. ;; 圆动态渐变偏移变色
   
3. ;;需要e派工具箱(XCAD)的支持：[url]http://yunpan.cn/QXQKsW9gAPmpF[/url](defun c:test1498 (/ s0 p0 rr mode mo co r0 i p1 dd s00 n ss)
   
4.   (xyp-CMDLA0)
   
5.   (setq d0   (Udist 1 "" "渐进距离<输入或鼠标直接量取>" d0 nil)
   
6.         s0   (car (entsel "\n选择圆: "))
   
7.         p0   (xyp-DXF 10 s0)
   
8.         rr   (xyp-DXF 40 s0)
   
9.         mode t
   
10.   )
    
11.   (while mode
    
12.     (setq mo (grread t 15 0)
    
13.           co (car mo)
    
14.           r0 0
    
15.     )
    
16.     (redraw)
    
17.     (cond ((member co '(5))
    
18.            (if (and ss (> (sslength ss) 0))
    
19.              (xyp-erase ss)
    
20.            )
    
21.            (setq i   1
    
22.                  p1  (cadr mo)
    
23.                  dd  (distance p1 p0)
    
24.                  s00 (entlast)
    
25.            )
    
26.            (xyp-Grvecs-Ptlst (list p0 p1) 1)
    
27.            (while (< (+ r0 rr) dd)
    
28.              (setq n  (* (/ (+ 1 i) 2.) i)
    
29.                    r0 (* n d0)
    
30.                    i  (1+ i)
    
31.              )
    
32.              (xyp-Offset s0 r0 t nil nil)
    
33.              (xyp-SubUpd (entlast) 62 (rem i 255))
    
34.            )
    
35.            (setq ss (xyp-SSelEntnext s00)
    
36.            )
    
37.           )
    
38.           (t (setq mode nil))
    
39.     )
    
40.   )
    
41.   (xyp-CMDLA1)
    
42. )

;; 圆动态渐变偏移变色<br /> ;;需要e派工具箱(XCAD)的支持：[url]http://yunpan.cn/QXQKsW9gAPmpF[/url](defun c:test1498 (/ s0 p0 rr mode mo co r0 i p1 dd s00 n ss)<br />   (xyp-CMDLA0)<br />   (setq d0   (Udist 1 "" "渐进距离<输入或鼠标直接量取>" d0 nil)<br />         s0   (car (entsel "\n选择圆: "))<br />         p0   (xyp-DXF 10 s0)<br />         rr   (xyp-DXF 40 s0)<br />         mode t<br />   )<br />   (while mode<br />     (setq mo (grread t 15 0)<br />           co (car mo)<br />           r0 0<br />     )<br />     (redraw)<br />     (cond ((member co '(5))<br />            (if (and ss (> (sslength ss) 0))<br />              (xyp-erase ss)<br />            )<br />            (setq i   1<br />                  p1  (cadr mo)<br />                  dd  (distance p1 p0)<br />                  s00 (entlast)<br />            )<br />            (xyp-Grvecs-Ptlst (list p0 p1) 1)<br />            (while (< (+ r0 rr) dd)<br />              (setq n  (* (/ (+ 1 i) 2.) i)<br />                    r0 (* n d0)<br />                    i  (1+ i)<br />              )<br />              (xyp-Offset s0 r0 t nil nil)<br />              (xyp-SubUpd (entlast) 62 (rem i 255))<br />            )<br />            (setq ss (xyp-SSelEntnext s00)<br />            )<br />           )<br />           (t (setq mode nil))<br />     )<br />   )<br />   (xyp-CMDLA1)<br /> )

琴剑江山_10184

相当给力的程序啊

荒野孤行

琴剑江山_10184 发表于 2015-1-8 08:10
相当给力的程序啊

(defun c:t1 ()
  (setvar "osmode" 15359)
  (setvar "cmdecho" 0)
  (princ "\n★功能：查找同心圆.")
  (command "undo" "be")
  (vl-load-com)
  (while
    (progn
      (setq ent1 (entsel "\n请选择参照圆：\n"))
      (not
        (if (= ent1 nil)
          nil
          (wcmatch (cdr (assoc 0 (entget (car ent1))))
                   "CIRCLE"
          )                                ;限定只能选取圆
        )
      )
    )
  )
  (setq entnam1 (car ent1))
  (setq circlecoord1 (cdr (assoc 10 (entget entnam1))))
  (initget 4)
  (if (not (setq wcz (getreal "请输入误差值：<0.00005>")))
    (setq wcz 0.00005)
  )
  (setq ss (ssget '((0 . "CIRCLE"))))
  (if ss
    (progn
      (setvar "osmode" 0)
      (setq i 0)
      (command "_.LAYER" "M" "层-同心圆" "C" "1" "层-同心圆" "")
      (repeat (sslength ss)
        (setq entnam2 (ssname ss i))
        (setq entdata2 (entget entnam2))
        (setq circlecoord2 (cdr (assoc 10 entdata2)))
        (setq obj2 (vlax-ename->vla-object entnam2))
        (if (equal circlecoord1 circlecoord2 wcz)
          (vla-put-layer obj2 "层-同心圆")
        )
        (setq i (1+ i))
      )
    )
    (princ "\n未选取到对象，程序退出.")
  )
  (command "undo" "e")
  (setvar "osmode" 15359)
  (princ)
)