_标记不闭合处画圆

admin

1. ;;采用标记不闭合处画圆 By ls (2013年2月2日10时30分47秒)
2. (defun c:tt (/ AT采用M:SearchSSByList AT采用Pl:GetClose C DIST ENAME ENDPT FILTER FIND I L R RETURN SS STARTPT)
3. (vl-load-com)
4. (setq filter (list (cons 0 "*line,ELLIPSE,ARC")));采用针对线 椭圆 圆弧
5. (setq ss (ssget filter));采用创建选择集
6. (setq return '());采用返回的点表
7. (setq dist 0.01);采用距离
9. (setq r 2);采用圆的半径 实型
10. (setq l "Err");采用创建的圆所在的图层 字符型
11. (setq c 3);采用圆的颜色(颜色号) 整型
13. ;;采用指定距离搜索实体图元
14. (defun AT采用M:SearchSSByList (pt S采用Dist tylst / PT采用A PT采用CL PT采用LIST RVAL SS X)
15. (setq pt采用list '())
16. (setq rVal nil)
17. (setq pt采用cl (list 0 0.25 0.5 0.75 1 1.25 1.5 1.75))
18. (setq pt采用a (mapcar '(lambda (x) (* x pi)) pt采用cl))
19. (foreach n采用pt采用a pt采用a
20. (setq pt采用list (cons (polar pt n采用pt采用a S采用Dist) pt采用list))
21. )
22. (setq  ss (ssget "cp" pt采用list tylst))
23. (if (/= ss nil)
24. (setq rVal ss)
25. (setq rVal nil)
26. )
27. rVal
28. )
29. ;;采用曲线是否闭合
30. (defun AT采用Pl:GetClose (ename / PLIST RETURN)
31. (setq return nil)
32. (if (vlax-curve-isClosed ename)
33. (setq return T)
34. (progn
35. (setq plist (list (vlax-curve-getStartPoint ename) (vlax-curve-getEndPoint ename)))
36. (if (equal (car plist) (last plist))
37. (setq return T)
38. (setq return nil)
39. )
40. )
41. )
42. return
43. )
44. (if ss
45. (progn
46. (setq i -1)
47. (command "zoom" "e")
48. (princ "\n正在处理,请稍等...")
49. (princ)
50. (while (setq ename (ssname ss (setq i (1+ i))))
51. (if (not (AT采用Pl:GetClose ename));采用忽略本身已闭合的
52. (progn
53. (setq startpt (vlax-curve-getStartPoint ename));采用起点
54. (setq endpt (vlax-curve-getEndPoint ename));采用终点
55. (foreach pt (list startpt endpt)
56. (setq find (AT采用M:SearchSSByList pt dist filter))
57. (if find
58. (progn
59. (setq find (ssdel ename find)) ;采用删除自身的
60. (if (= (sslength find) 0)
61. (setq return (cons pt return))
62. )
63. )
64. (setq return (cons pt return))
65. )
66. )
67. )
68. )
69. )
70. (command "zoom" "p")
71. )
72. )
73. (if return
74. (progn
75. (foreach pt return
76. (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "ACDbCircle") (cons 10 pt) (cons 40 r) (cons 8 l) (cons 62 c) '(210 0. 0. 1.)))
77. )
78. (princ (strcat "\n共检测到 " (itoa (length return)) " 处.."))
79. )
80. )
81. (princ)
82. )

复制代码