[求多边形内相对中心点] 源码

yanguangfei

很费神的收点辛苦费啦
求得的点不会出多边形奥
感谢  辰 提供算法
感谢  E派指正
感谢 所有关注求闭合多段线的心【不是一般的心】（望高手出手）感激不尽（已解决） 的人


该贴已经同步到 yanguangfei的微博

mitenickevin

没币下不了。

轮回

大神告诉我，坐标值大了的情况下IntersectWith交点在顶点0.01范围内就会出错，所以会出现14楼那种错误，所以我在代码里加了一点修正。这个函数在测绘里还是很有用的！

2. ;;;求多边形内相对中心点[V 1.0]
   
3. ;;; 2012-11-15
   
4. ;;; 感谢 辰     提供方法
   
5. ;;; 感谢 学院派 指正
   
6. ;;;  by yanguangfei
   
7. (defun Get_center_relative (ename / 2R DelLine DistList i lst lst1 Mk Mkline N Newlst Number obj points Pt pt1 Pts R Tssbak Tssred TssSub)
   
8.   (setq Obj     (Vlax-Ename->Vla-Object ename)
   
9.     Tssbak  (Vlax-Get Obj 'Thickness )
   
10.     TssSub  (Vlax-Put Obj 'Thickness 0 )
    
11.    
    
12.   )
    
13.   (setq Pts     (GetBoundingBox ename)
    
14.     2R      (MJ:MIDPOINT (CAR Pts) (CADR Pts))
    
15.     Mk      (entmake (list (cons 0 "LINE")(cons 8 "JMDSS")(cons 10 (polar 2R 0.0 1000))(cons 11 (polar 2R pi 1000))))
    
16.     Mkline  (entlast)
    
17.     points  (vlax-invoke (vlax-ename->vla-object ename) 'IntersectWith (vlax-ename->vla-object Mkline) acExtendOtherEntity)
    
18.     Tssred  (Vlax-Put Obj 'Thickness (eval Tssbak) )
    
19.     DelLine (entdel Mkline)
    
20.     i       0
    
21.     lst     nil
    
22.     lst1     nil  
    
23.   )
    
24.   (repeat (/ (length points) 3)
    
25.     (setq lst (append lst (list (list (nth i points) (nth (1+ i) points) (nth (+ 2 i) points)))))
    
26.     (setq i (+ i 3))
    
27.   )
    
28.   (foreach p1 lst;去掉vla-IntersectWith的bug
    
29.     (setq pt1 (vlax-curve-getClosestPointTo ename p1))
    
30.     (if (equal pt1 p1 1e-8)
    
31.       (setq lst1 (append (list p1) lst1))
    
32.     )
    
33.   )
    
34.   (setq lst (px lst1))
    
35.   (if (>= (length lst) 4)
    
36.     (progn
    
37.       (setq N      0
    
38.         Newlst nil)
    
39.       (repeat (/ (length lst) 2)
    
40.         (setq Newlst (append Newlst (list (list (nth N lst) (nth (1+ N) lst)))))
    
41.         (setq N (+ 2 N))
    
42.       )
    
43.       (setq DistList nil
    
44.         R        0)
    
45.       (repeat (length Newlst)
    
46.         (setq Number (nth R Newlst)
    
47.           DistList (append DistList  (list(distance (car Number) (cadr Number)))))
    
48.         (setq R (1+ R))
    
49.       )
    
50.       (setq  Pt (nth (vl-position (car (vl-sort DistList '>)) DistList) Newlst))
    
51.       (MJ:MIDPOINT (car pt) (cadr pt));返回值
    
52.     )
    
53.     (MJ:MIDPOINT (car lst) (cadr lst));返回值
    
54.   )
    
55. )

;;;求多边形内相对中心点[V 1.0]<br /> ;;; 2012-11-15<br /> ;;; 感谢 辰     提供方法<br /> ;;; 感谢 学院派 指正<br /> ;;;  by yanguangfei<br /> (defun Get_center_relative (ename / 2R DelLine DistList i lst lst1 Mk Mkline N Newlst Number obj points Pt pt1 Pts R Tssbak Tssred TssSub)<br />   (setq Obj     (Vlax-Ename->Vla-Object ename)<br />     Tssbak  (Vlax-Get Obj 'Thickness )<br />     TssSub  (Vlax-Put Obj 'Thickness 0 )<br />     <br />   )<br />   (setq Pts     (GetBoundingBox ename)<br />     2R      (MJ:MIDPOINT (CAR Pts) (CADR Pts))<br />     Mk      (entmake (list (cons 0 "LINE")(cons 8 "JMDSS")(cons 10 (polar 2R 0.0 1000))(cons 11 (polar 2R pi 1000))))<br />     Mkline  (entlast)<br />     points  (vlax-invoke (vlax-ename->vla-object ename) 'IntersectWith (vlax-ename->vla-object Mkline) acExtendOtherEntity)<br />     Tssred  (Vlax-Put Obj 'Thickness (eval Tssbak) )<br />     DelLine (entdel Mkline)<br />     i       0<br />     lst     nil<br />     lst1     nil  <br />   )<br />   (repeat (/ (length points) 3)<br />     (setq lst (append lst (list (list (nth i points) (nth (1+ i) points) (nth (+ 2 i) points)))))<br />     (setq i (+ i 3))<br />   )<br />   (foreach p1 lst;去掉vla-IntersectWith的bug<br />     (setq pt1 (vlax-curve-getClosestPointTo ename p1))<br />     (if (equal pt1 p1 1e-8)<br />       (setq lst1 (append (list p1) lst1))<br />     )<br />   )<br />   (setq lst (px lst1))<br />   (if (>= (length lst) 4)<br />     (progn<br />       (setq N      0<br />         Newlst nil)<br />       (repeat (/ (length lst) 2)<br />         (setq Newlst (append Newlst (list (list (nth N lst) (nth (1+ N) lst)))))<br />         (setq N (+ 2 N))<br />       )<br />       (setq DistList nil<br />         R        0)<br />       (repeat (length Newlst)<br />         (setq Number (nth R Newlst) <br />           DistList (append DistList  (list(distance (car Number) (cadr Number)))))<br />         (setq R (1+ R))<br />       )<br />       (setq  Pt (nth (vl-position (car (vl-sort DistList '>)) DistList) Newlst))<br />       (MJ:MIDPOINT (car pt) (cadr pt));返回值<br />     )<br />     (MJ:MIDPOINT (car lst) (cadr lst));返回值<br />   )<br /> )

本何处来

轮回 发表于 2022-2-21 15:35
大神告诉我，坐标值大了的情况下IntersectWith交点在顶点0.01范围内就会出错，所以会出现14楼那种错误，所 ...

用了一下。提示：错误: 参数太少。不懂问题在哪

xiabin68

这么快哦，，先支持一个，，下来试一试，，，，

004

好程序。顶一下。

xxzwtr

发发

lq8000

找了好久终于解决了。

yshf

没有那条水平线与多边形交点数为奇数时的处理

328302216

暂时用不上，不过有源码，顶起

开1心

为了测试，我必须下啊~~

zjy2999

支持，下载学习了