设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › 编程申请 › 《悬赏3明经币》求“搜索多边形内的线”的程序
12下一页
返回列表 发新帖
查看: 3483|回复: 18

《悬赏3明经币》求“搜索多边形内的线”的程序

  [复制链接]
chenjian2159
发表于 2011-4-12 18:54:40 | 显示全部楼层 |阅读模式
3明经币
本帖最后由 chenjian2159 于 2011-4-13 14:52 编辑

根据白色的多边形自动搜索里面红色的线，返回搜索到线的选择集，白色多边形里面可能有多条线，谢谢朋友们参与！！！
附件: 您需要 登录 才可以下载或查看，没有账号？注册

最佳答案

gufeng

查看完整内容

有时间弄了下下
回复

使用道具 举报

gufeng
发表于 2011-4-12 18:54:41 | 显示全部楼层
本帖最后由 gufeng 于 2011-6-23 13:52 编辑

有时间弄了下下

  1. ;_搜索多边形内的线 TT
  2. ;_计算面积    TT1
  3. (defun c:TT (/ ENAME NEWENTLAST OLDENTLAST PT I PLIST EN OCMDECHO)
  4. (while (setq ename (car (entsel "\n选择多边形:")))
  5. (AT_Li:20110623)
  6. (if  $SS
  7. (progn
  8. (setq i -1)
  9. (while (setq en (ssname $SS (setq i (1+ i))))
  10. (redraw en 4)
  11. )
  12. )
  13. ) ;_恢复原选择集的亮度
  14. (redraw ename 3)
  15. (setq pt (AT_L:GetPlInPt (AT_S:GetEnameBox ename))) ;_得到多边形内一点
  16. (setq ocmdecho (getvar "cmdecho"))
  17. (setvar "cmdecho" 0)
  18. (command "_undo" "mark")
  19. (setq oldentlast (entlast)) ;_最后的图元名
  20. (command "-boundary" "a" "b" "n" ename "" "" pt "")
  21. (setq newentlast (entlast)) ;_Boundary后
  22. (if  (eq oldentlast newentlast)
  23. (progn
  24. (setq $SS nil)
  25. (princ "\n\t生成边界错误,搜索退出")
  26. )
  27. (progn
  28. (setq plist (AT_L:Plist newentlast))
  29. (if (> (length plist) 2)
  30. (progn
  31. (command "_zoom"
  32. (car (AT_S:GetEnameBox ename))
  33. (cadr (AT_S:GetEnameBox ename))
  34. )
  35. (setq $SS (ssget "wp" plist '((0 . "LWPOLYLINE"))))
  36. )
  37. (princ "\n\t坐标少于两个,搜索退出")
  38. )
  39. )
  40. )
  41. (command "_undo" "back")
  42. (setvar "cmdecho" ocmdecho)
  43. (redraw ename 4)
  44. (if  $SS
  45. (progn
  46. (setq i -1)
  47. (while (setq ename (ssname $SS (setq i (1+ i))))
  48. (redraw ename 3)
  49. )
  50. (princ
  51. (strcat "\n\t图元数量: " (itoa (sslength $SS)) " 已亮显")
  52. )
  53. )
  54. )
  55. )
  56. (princ)
  57. )


  60. (defun c:TT1 (/  ENAME ENAMELST ERR_5 II  ISJXELST MJ MJ1  MJ2 NEWENTLAST OCMDECHO  OLDENTLAST PLIST PT SS SS_WP WP_ENAME WS JD)
  61. (setq ws nil) ;_如果为t则先取位再加减  反之则面积先加减最后取位
  62. (setq jd 2) ;_面积小数位
  63. (setq ss (ssget '((0 . "LWPOLYLINE"))))
  64. (if ss
  65. (progn
  66. (AT_Li:20110623)
  67. (setq enamelst (AT_S:ToEnameMjLst ss)) ;_图元与面积表
  68. (setq enamelst (AT_L:Sort_lst enamelst)) ;_按面积从大到小排序
  69. (setq mj 0) ;_总面积
  70. (setq err_5 '()) ;_记录无法计算的图元句柄列表
  71. (setq isjxelst '()) ;_已经计算过面积的图元列表
  72. (setq ocmdecho (getvar "cmdecho"))
  73. (setvar "cmdecho" 0)
  74. (foreach i enamelst
  75. (setq ename (last i)) ;_图元名
  76. (if (not (member ename isjxelst))
  77. (progn
  78. (setq pt (AT_L:GetPlInPt (AT_S:GetEnameBox ename))) ;_多边形内一点
  79. (command "_undo" "mark")
  80. (setq oldentlast (entlast)) ;_最后的图元名
  81. (command "-boundary" "a" "b" "n" ename "" "" pt "")
  82. (setq newentlast (entlast)) ;_Boundary后
  83. (if  (eq oldentlast newentlast)
  84. (progn
  85. (setq err_5 (cons (cdr (assoc 5 (entget ename))) err_5)) ;_错误
  86. )
  87. (progn
  88. (setq mj1 (vlax-curve-getArea newentlast)) ;_重新计算面积
  89. (if ws
  90. (setq mj1 (AT_G:SsWr mj1 jd))
  91. )
  92. (setq plist (AT_L:Plist newentlast))
  93. (if (> (length plist) 2)
  94. (progn
  95. (command "_zoom"
  96. (car (AT_S:GetEnameBox ename))
  97. (cadr (AT_S:GetEnameBox ename))
  98. )
  99. (setq ss_wp (ssget "wp" plist '((0 . "LWPOLYLINE"))))
  100. (if  ss_wp
  101. (progn
  102. (setq ii -1)
  103. (while (setq wp_ename (ssname ss_wp (setq ii (1+ ii))))
  104. (setq isjxelst (cons wp_ename isjxelst))
  105. ;_计算内多边形面积 Start
  106. (setq pt (AT_L:GetPlInPt (AT_S:GetEnameBox wp_ename)))
  107. (command "_undo" "mark")
  108. (setq newentlast (entlast))
  109. (command "-boundary" "a" "b" "n" ename "" "" pt "")
  110. (setq oldentlast (entlast))
  111. (if (eq oldentlast newentlast)
  112. (setq mj2 (vlax-curve-getArea wp_ename)) ;_Boundary无法生成直接使用线面积
  113. (setq mj2 (vlax-curve-getArea newentlast)) ;_使用Boundary生成的线面积
  114. )
  115. (if ws
  116. (setq mj2 (AT_G:SsWr mj2 jd))
  117. )
  118. (command "_undo" "back")
  119. ;_计算内多边形面积 End
  120. (setq mj1 (- mj1 (vlax-curve-getArea wp_ename)))
  121. )
  122. )
  123. )
  124. (setq mj (+ mj mj1)) ;_加入到总面积
  125. )
  126. (setq err_5 (cons (cdr (assoc 5 (entget ename))) err_5)) ;_错误
  127. )
  128. )
  129. )
  130. (command "_undo" "back")
  131. )
  132. )
  133. )
  134. (setvar "cmdecho" ocmdecho)
  135. (princ (strcat "\n总面积是: " (rtos mj 2 jd)))
  136. (if err_5
  137. (progn
  138. (princ "\n无法计算的图元句柄表:")
  139. (princ err_5)
  140. )
  141. )
  142. )
  143. (princ "\n没有选择计算的对象")
  144. )
  145. (princ)
  146. )


  149. ;_使用到的相关函数
  150. (defun AT_Li:20110623 ()
  151. (vl-load-com)
  152. ;_四舍五入 (AT_G:SsWr NUM JD)
  153. (defun AT_G:SsWr (NUM JD / RETURN)
  154. (read (rtos num 2 jd))
  155. )
  156. ;_返回多段线的坐标表 (AT_L:Plist ENAME)
  157. (defun AT_L:Plist (ENAME / ELEV EN ENTL FLAG PT VLIST)
  158. (defun LI_item (n alist)
  159. (cdr (assoc n alist))
  160. )
  161. (setq
  162. vlist '()
  163. entl  (entget ename)
  164. en    (LI_item 0 entl)
  165. )
  166. (cond
  167. ((= en "LWPOLYLINE")
  168. (setq
  169. vlist '()
  170. Elev  (LI_item 38 entl)
  171. )
  172. (foreach  pt entl
  173. (if (= (car pt) 10)
  174. (setq vlist (cons (list (cadr pt) (caddr pt) Elev) vlist))
  175. )
  176. )
  177. (setq vlist (reverse vlist))
  178. )
  179. ((= en "SPLINE")
  180. (setq vlist (LI_mitem 11 entl))
  181. (if (not vlist)
  182. (setq vlist (LI_mitem 10 entl))
  183. (setq vlist (reverse (reverse vlist)))
  184. )
  185. )
  186. ((= en "POLYLINE")
  187. (setq
  188. ename (entnext ename)
  189. entl  (entget ename)
  190. en    (LI_item 0 entl)
  191. vlist '()
  192. )
  193. (while (= en "VERTEX")
  194. (setq flag (LI_item 70 entl))
  195. (if (and
  196. (zerop (logand flag 1))
  197. (zerop (logand flag 2))
  198. (zerop (logand flag 8))
  199. (/= flag 128)
  200. )
  201. (setq
  202. pt     (LI_item 10 entl)
  203. vlist (cons pt vlist)
  204. )
  205. )
  206. (setq
  207. ename (entnext ename)
  208. entl   (entget ename)
  209. en   (LI_item 0 entl)
  210. )
  211. )
  212. (setq vlist (reverse vlist))
  213. )
  214. ((= en "LINE")
  215. (setq vlist (list (LI_item 10 entl) (LI_item 11 entl)))
  216. )
  217. ((= en "3DFACE")
  218. (setq vlist (list
  219. (LI_item 10 entl)
  220. (LI_item 11 entl)
  221. (LI_item 12 entl)
  222. (LI_item 13 entl)
  223. )
  224. )
  225. )
  226. )
  227. vlist
  228. )

  230. ;_获得 单个图元 的最大包围框   (AT_S:GetEnameBox ENAME)
  231. (defun AT_S:GetEnameBox (ENAME / OBJ MINPOINT MAXPOINT)
  232. (setq obj (vlax-ename->vla-object ename))
  233. (vla-GetBoundingBox obj 'minpoint 'maxpoint) ;_取得包容图元的最大点和最小点
  234. (setq minpoint (vlax-safearray->list minpoint)) ;_把变体数据转化为表
  235. (setq maxpoint (vlax-safearray->list maxpoint)) ;_把变体数据转化为表
  236. (setq obj (list minpoint maxpoint))
  237. )
  238. ;_获取多边形内一点 部分适用 (AT_L:GetPlInPt PLIST)
  239. (defun AT_L:GetPlInPt  (PLIST / P1 P2 PT)
  240. (setq p1 (car plist)
  241. p2 (cadr plist)
  242. )
  243. (setq p1 (list (car p1) (cadr p1))
  244. p2 (list (car p2) (cadr p2))
  245. )
  246. (setq pt (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
  247. pt
  248. )
  249. ;_由选择集返回图元与面积表   (AT_S:ToEnameMjLst SS)
  250. (defun AT_S:ToEnameMjLst (SS / I E LST MJ)
  251. (setq i -1)
  252. (while (setq e (ssname ss (setq i (1+ i))))
  253. (setq mj (vlax-curve-getArea e))
  254. (setq lst (cons (list mj e) lst))
  255. )
  256. (reverse lst)
  257. )
  258. ;_由选择集返回图元表   (AT_S:ToEnameLst SS)
  259. (defun AT_S:ToEnameLst (SS / I E LST)
  260. (setq i -1)
  261. (while (setq e (ssname ss (setq i (1+ i))))
  262. (setq lst (cons e lst))
  263. )
  264. (reverse lst)
  265. )
  266. ;_表排序 (AT_L:Sort_lst LST)
  267. (defun AT_L:Sort_lst (LST)
  268. (vl-sort lst
  269. (function (lambda (e1 e2)
  270. (> (car e1) (car e2))
  271. )
  272. )
  273. )
  274. )
  275. )

回复

使用道具 举报

Andyhon
发表于 2011-4-12 21:53:50 | 显示全部楼层
如何取得 '白色的多边形'  只白色?
里面的一定是红色的线?

图面可还存在其他图元会影响自动搜索

单以所附文件是很容易处理,
须考量的在此之外的可能情况....
回复

使用道具 举报

chenjian2159
 楼主| 发表于 2011-4-13 12:28:34 | 显示全部楼层
回复 Andyhon 的帖子

你好朋友，我说的“白色的多边形和红色的多边形”是自己改的，是想表达的清楚点，实际上工作中，颜色是没有分出来的，都是同一种颜色。谢谢你！
回复

使用道具 举报

Andyhon
发表于 2011-4-13 13:19:45 | 显示全部楼层
....
须考量的在此之外的可能情况....
可否上传数个具代表性的图样 (*.Dwg)

还是说就这么单纯而已
回复

使用道具 举报

chenjian2159
 楼主| 发表于 2011-4-13 14:53:22 | 显示全部楼层
顶！！！！
回复

使用道具 举报

chenjian2159
 楼主| 发表于 2011-4-13 16:48:16 | 显示全部楼层
回复 Andyhon 的帖子

朋友，已经上传图样，谢谢！
回复

使用道具 举报

Andyhon
发表于 2011-4-13 17:00:09 | 显示全部楼层
这个不合 AutoCAD 求面积的规范
未曾涉及过相仿于所提样图的程序 ....

或许第三方插有这样的程序
回复

使用道具 举报

xxzwtr
发表于 2011-5-9 23:15:10 | 显示全部楼层
VLX格式的算么？
回复

使用道具 举报

xxzwtr
发表于 2011-5-9 23:15:42 | 显示全部楼层
没有源码的可以么？
回复

使用道具 举报

12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-9-28 09:22 , Processed in 0.173744 second(s), 23 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表