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

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

小弟是学测绘的，毕业设计急需获取闭合多段线（界址线）顶点（界址点）坐标和边凸度的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)

(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

meflying的确是高手，我的同样功能程序，长度是这个程序的两倍。我的程序要改一下了。

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

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

新人学习中

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

新人学习中，学习学习啊

账号		自动登录	找回密码
密码			注册

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

浏览过的版块