检查折线间有无裂缝，请各高手提供个算法[已解决]

soly2006

如图，在求面积汇总时候(pline，无拟合)，有时会手抖，没有捕捉到位，会产生总面积与各分面积不符情况，但裂缝很小，图形又大的情况下肉眼又难以判断，有什么好的办法检查错误地方？
简而言之，内部面积之间没有很好靠一起，造成裂缝。
现在要找出来，谢谢.以下是测试图情况。

soly2006

没有人理啊？应该用的人不少啊，给个方法。
再自顶上。

Andyhon

行有不得反求诸己
单依楼主所提资料怕是难有回应...
提问可是个大学问啊,问对了有如叩钟之应...

牢固

pe m                  

功夫佬

看看这个应该是你要的效果，我没有原代码，这是别人工具箱里面的功能，会写像这样的代码的高手，请你们帮一下，谢谢.

soly2006

顶上去先，我越发严重怀疑我的表达能力了.
怎么都不能理解啊.
就是两折线间留有缝的地方标示出来。
希望大家关注一下。

Gu_xl

表达严重有问题 ！首先折线是什么类型的线没说，其次应该给个样图，样图中要有原图和你想要的结果！这样别人才能帮你，否则，自然没人关注！

soly2006

再自顶,顶不出来不罢休

Gu_xl

soly2006 发表于 2012-5-2 13:16
再自顶,顶不出来不罢休

1. (defun c:tt  (/ MKCIRCLE SS L PL FLAG S i)
   
2.   (defun mkcircle  (pt r)
   
3.     (entmake (list '(0 . "circle")
   
4.                    (cons 10 pt)
   
5.                    (cons 40 r)
   
6.                    (cons 62 1)
   
7.                    (cons 8 "检查标记")))
   
8.     )
   
9.   (setq n 0 nn 0)
   
10.   (while (progn
    
11.            (princ "\n选择要检查的物体:")
    
12.            (setq ss (ssget '((0 . "lwpolyline"))))
    
13.            )
    
14.     (setq s nil n 0)
    
15.   (repeat (setq i (sslength ss))
    
16.     (setq s (cons (ssname ss (setq i (1- i))) s))
    
17.     )
    
18.     (foreach en         s
    
19.       (setq l (vl-remove en s))
    
20.       (setq pl (mapcar 'cdr
    
21.                        (vl-remove-if-not
    
22.                          '(lambda (x) (= 10 (car x)))
    
23.                          (entget en))))
    
24.       (foreach pt  pl
    
25.         (setq Flag
    
26.                (vl-some
    
27.                  '(lambda (x)
    
28.                     (equal (vlax-curve-getclosestpointto en pt)
    
29.                            (vlax-curve-getclosestpointto x pt)
    
30.                            1e-6))
    
31.                  l))
    
32.         (if (not Flag)
    
33.           (progn
    
34.           (mkcircle pt 1)
    
35.           (setq n (1+ n))
    
36.           )
    
37.           )
    
38.         )
    
39.       )
    
40.     (princ (strcat "\n发现 " (itoa n) "处问题:"))
    
41.     (setq nn (+ n nn))
    
42.     )
    
43.   (princ (strcat "\n总共发现 " (itoa nn) "处问题:"))
    
44.   (princ)
    
45.   )
    

(defun c:tt  (/ MKCIRCLE SS L PL FLAG S i)<br />   (defun mkcircle  (pt r)<br />     (entmake (list '(0 . "circle")<br />                    (cons 10 pt)<br />                    (cons 40 r)<br />                    (cons 62 1)<br />                    (cons 8 "检查标记")))<br />     )<br />   (setq n 0 nn 0)<br />   (while (progn<br />            (princ "\n选择要检查的物体:")<br />            (setq ss (ssget '((0 . "lwpolyline"))))<br />            )<br />     (setq s nil n 0)<br />   (repeat (setq i (sslength ss))<br />     (setq s (cons (ssname ss (setq i (1- i))) s))<br />     )<br />     (foreach en         s<br />       (setq l (vl-remove en s))<br />       (setq pl (mapcar 'cdr<br />                        (vl-remove-if-not<br />                          '(lambda (x) (= 10 (car x)))<br />                          (entget en))))<br />       (foreach pt  pl<br />         (setq Flag<br />                (vl-some<br />                  '(lambda (x)<br />                     (equal (vlax-curve-getclosestpointto en pt)<br />                            (vlax-curve-getclosestpointto x pt)<br />                            1e-6))<br />                  l))<br />         (if (not Flag)<br />           (progn<br />           (mkcircle pt 1)<br />           (setq n (1+ n))<br />           )<br />           )<br />         )<br />       )<br />     (princ (strcat "\n发现 " (itoa n) "处问题:"))<br />     (setq nn (+ n nn))<br />     )<br />   (princ (strcat "\n总共发现 " (itoa nn) "处问题:"))<br />   (princ)<br />   )<br />

hejiazhao

严重顶起，期待解决中