[LISP函数]：获取多边形各边中点的座标

taner

[PHP](defun th-get-midptofpoly (ename / n ptlist pp)
  (setq ptlist (get-allvertexs ename))
  (setq n 0)
  (while (< n (1- (length ptlist)))
    (setq pp (append
               pp
               (list (mid-point (nth n ptlist) (nth (1+ n) ptlist)))
             )
    )
    (setq n (1+ n))
  )
  pp
)
(defun get-allvertexs (e / n lst)
  (repeat (setq n (fix (1+ (vlax-curve-getendparam e))))
    (setq lst (cons (vlax-curve-getpointatparam e (setq n (1- n))) lst))
  )
)
(defun mid-point (p1 p2)               
  (mapcar
    '(lambda (x)
       (/ x 2)
     )
    (mapcar
      '+
      p1
      p2
    )
  )
)[/PHP]

eachy

2. 
   
3. (defun xdl-poly-midp (ename / n ptlist pp)
   
4.   (setq ptl (xdl-pl-vertexs ename))
   
5.   (mapcar '(lambda (a b) (xdl-midp a b))
   
6.           ;;ptl
   
7.           ;;(append (cdr ptl) (list (car ptl)))
   
8.           (cdr ptl)
   
9.           ptl
   
10.   )
    
11. )

<br /> (defun xdl-poly-midp (ename / n ptlist pp)<br />   (setq ptl (xdl-pl-vertexs ename))<br />   (mapcar '(lambda (a b) (xdl-midp a b))<br />           ;;ptl<br />           ;;(append (cdr ptl) (list (car ptl)))<br />           (cdr ptl)<br />           ptl<br />   )<br /> )

下面的两个函数在前面的帖子可以找到

2. 
   
3. (defun xdl-pl-vertexs (e / n lst)
   
4.   (repeat (setq n (fix (1+ (vlax-curve-getendparam e))))
   
5.     (setq lst (cons (vlax-curve-getpointatparam e (setq n (1- n))) lst))
   
6.   )
   
7. )
   
8. (defun xdl-midp        (p1 p2)
   
9.   (mapcar '(lambda (x) (/ x 2)) (mapcar '+ p1 p2))
   
10. )

<br /> (defun xdl-pl-vertexs (e / n lst)<br />   (repeat (setq n (fix (1+ (vlax-curve-getendparam e))))<br />     (setq lst (cons (vlax-curve-getpointatparam e (setq n (1- n))) lst))<br />   )<br /> )<br /> (defun xdl-midp        (p1 p2)<br />   (mapcar '(lambda (x) (/ x 2)) (mapcar '+ p1 p2))<br /> )

狂刀

[php]
;; 取多义线各段中点坐标;支持有凸度的多义线。
(defun xdl-plmpts (e / n m mpts);; by 狂刀
  (setq n (fix (vlax-curve-getendparam e))
        m (+ n 0.5))
  (repeat n
    (setq mpts(cons (vlax-curve-getpointatparam e (setq m (1- m))) mpts))
  )
)
[/php]

lgwlgw

还是 狂刀 的好用.

yjch

感谢tanger的程序函数

lianghui2018

谢谢老师的分享

kkt123

谢谢老师的分享;P