卡拉KO 发表于 2004-5-22 12:14:00

[求助]请教高手获取闭合多段线顶点坐标和边凸度的lisp程序

小弟是学测绘的，毕业设计急需 获取闭合多段线（界址线）顶点（界址点）坐标和边凸度的lisp程序，望高手不吝赐教！感激不尽！谢谢关注！

meflying 发表于 2004-5-22 16:39:00

(defun GETPLVTX (E / ED)
   (defun DXF (NO)
       (cdr (assoc NO ED))
   )
   (defun GETLWPL (ED / PL BL)
       (while (setq ED (cdr (member (setq PL10 (assoc 10 ED)) ED)))
         (setq PL (cons (cdr PL10) PL))
         (setq BL (cons (cdr (assoc 42 ED)) BL))
       )
       (list (reverse PL) (reverse BL))
   )
   (defun GETPL (ED / E PL BL P10)
       (setq E (DXF -1))
       (while (setq E (entnext E))
         (if (setq P10 (cdr (assoc 10 (entget E))))
(progn
   (setq PL (cons P10 PL))
   (setq BL (cons (cdr (assoc 42 (entget E))) BL))
)
         )
       )
       (list (reverse PL) (reverse BL))
   )
   (setq ED (entget E))
   (setq PLTYPE (DXF 0))
   (cond
       ((= "POLYLINE" PLTYPE)
         (GETPL ED)
       )
       ((= "LWPOLYLINE" PLTYPE)
         (GETLWPL ED)
       )
   )
)
(defun c:test( / ent pts)
   (setq ent (car (entsel "选择界址线...")))
   (setq pts (GETPLVTX ent))
   (princ (strcat "\n界址点:" (apply 'strcat (mapcar '(lambda(e) (strcat (vl-princ-to-string e) " ")) (car pts)))))
   (princ (strcat "\n凸度:" (apply 'strcat (mapcar '(lambda(e) (strcat (vl-princ-to-string e) " ")) (cadr pts)))))
   (princ))

卡拉KO 发表于 2004-5-22 22:13:00

想不到这么快就有回应了，谢谢这位热心人，还有谢谢这个社区！

卡拉KO 发表于 2004-5-23 09:54:00

本帖最后由 作者 于 2004-5-23 11:18:57 编辑

再次感谢！

chfeng 发表于 2004-6-8 19:00:00

<A name=20346><FONT color=#000066><B>meflying</B></FONT></A>的确是高手，我的同样功能程序，长度是这个程序的两倍。我的程序要改一下了。

新黎既 发表于 2012-3-24 14:40:34

ltrliu 发表于 2015-5-17 16:45:41

新人学习中

tianbeiyuan 发表于 2019-11-23 21:22:15

新人学习中，学习学习啊
页: [1]
查看完整版本: [求助]请教高手获取闭合多段线顶点坐标和边凸度的lisp程序