【K:GetClsUcsLst 】获取撑开的多边形UCS点表

kucha007

绘制撑开的多边形，这里提供另外一种思路
以前大多使用区域覆盖来曲线救国，类似这篇帖子：撑开面积区域

1. ;获取撑开的多边形UCS点表
   
2. (defun K:GetClsUcsLst (/ PTLst TgtPT TmpLst)
   
3.     (defun *error* (x)  ;出错函数
   
4.       (redraw)
   
5.     )
   
6.     (if (car (setq PTLst (list (getpoint "\n→请指定起点或空格退出"))))
   
7.         (progn
   
8.           (while
   
9.             (setq TgtPT
   
10.                 (if (>= (length PTLst) 2) ;至少两个点
    
11.                     (if (>= (length PTLst) 3) ;三个点
    
12.                         (progn
    
13.                           (initget "U")
    
14.                           (getpoint (car PTLst) "\n→请指定下一点或空格结束 [撤回(U)]: ")
    
15.                         )
    
16.                         (progn
    
17.                           (initget 1 "U")
    
18.                           (getpoint (car PTLst) "\n→请指定下一点或 [撤回(U)]:")
    
19.                         )
    
20.                     )
    
21.                     (progn
    
22.                       (initget 1 "S");非空
    
23.                       (getpoint (car PTLst)"\n→请指定下一点")
    
24.                     )
    
25.                 )
    
26.             );第二个点
    
27.             (redraw)
    
28.             (cond
    
29.                 ((and (eq (type TgtPT) 'STR) (eq TgtPT "U"))
    
30.                     (setq PTLst (cdr PTLst))
    
31.                 )
    
32.                 ((eq (type TgtPT) 'LIST)
    
33.                     (setq PTLst (cons TgtPT PTLst))
    
34.                 )
    
35.             ) ;根据关键词返回坐标点
    
36.             (if (>= (length PTLst) 3);多边形
    
37.                 (progn
    
38.                     (setq TmpLst (cons (Last PTLst) PTLst));闭合坐标
    
39.                     (mapcar '(lambda (a b) (grdraw a b 1 -1)) TmpLst (cdr TmpLst)) ;画线
    
40.                 )
    
41.                 (mapcar '(lambda (a b) (grdraw a b 1 -1)) PTLst (cdr PTLst)) ;画线
    
42.             )
    
43.           ) ;下一点OR撤回
    
44.           (redraw)
    
45.         )
    
46.     )
    
47.     (if (>= (length PTLst) 3) PTLst)
    
48. )
    

;获取撑开的多边形UCS点表<br /> (defun K:GetClsUcsLst (/ PTLst TgtPT TmpLst)<br />     (defun *error* (x)  ;出错函数<br />       (redraw)<br />     )<br />     (if (car (setq PTLst (list (getpoint "\n→请指定起点或空格退出")))) <br />         (progn<br />           (while <br />             (setq TgtPT <br />                 (if (>= (length PTLst) 2) ;至少两个点<br />                     (if (>= (length PTLst) 3) ;三个点<br />                         (progn <br />                           (initget "U")<br />                           (getpoint (car PTLst) "\n→请指定下一点或空格结束 [撤回(U)]: ")<br />                         )<br />                         (progn <br />                           (initget 1 "U")<br />                           (getpoint (car PTLst) "\n→请指定下一点或 [撤回(U)]:")<br />                         )<br />                     )<br />                     (progn <br />                       (initget 1 "S");非空<br />                       (getpoint (car PTLst)"\n→请指定下一点")<br />                     )<br />                 )<br />             );第二个点<br />             (redraw)<br />             (cond <br />                 ((and (eq (type TgtPT) 'STR) (eq TgtPT "U"))<br />                     (setq PTLst (cdr PTLst))<br />                 )<br />                 ((eq (type TgtPT) 'LIST)<br />                     (setq PTLst (cons TgtPT PTLst))<br />                 )<br />             ) ;根据关键词返回坐标点<br />             (if (>= (length PTLst) 3);多边形<br />                 (progn<br />                     (setq TmpLst (cons (Last PTLst) PTLst));闭合坐标<br />                     (mapcar '(lambda (a b) (grdraw a b 1 -1)) TmpLst (cdr TmpLst)) ;画线<br />                 )<br />                 (mapcar '(lambda (a b) (grdraw a b 1 -1)) PTLst (cdr PTLst)) ;画线<br />             )<br />           ) ;下一点OR撤回<br />           (redraw)<br />         )<br />     )<br />     (if (>= (length PTLst) 3) PTLst)<br /> )<br />

用法：

1. (if (setq UCSLst (K:GetClsUcsLst))
   
2.     (K:MakeLWPOLYLINE Nil T UCSLst)
   
3. )
   

(if (setq UCSLst (K:GetClsUcsLst))<br />     (K:MakeLWPOLYLINE Nil T UCSLst)<br /> )<br />

kucha007

补充一个基础函数

1. ;点表生成多段线
   
2. (defun K:MakeLWPOLYLINE (WCS Clsd PTLst / PT)
   
3.   (entmakeX
   
4.     (append
   
5.       (list
   
6.         (cons 0 "LWPOLYLINE")
   
7.         (cons 100 "AcDbEntity")
   
8.         (cons 100 "AcDbPolyline")
   
9.         (cons 90 (length PTLst))
   
10.       )
    
11.       (if Clsd (list (cons 70 1)))
    
12.       (mapcar '(lambda (PT)
    
13.                 (cons 10
    
14.                   (if WCS PT (trans PT 1 0))
    
15.                 )
    
16.               )
    
17.               PTLst
    
18.       )
    
19.     )
    
20.   )
    
21. )
    

;点表生成多段线<br /> (defun K:MakeLWPOLYLINE (WCS Clsd PTLst / PT) <br />   (entmakeX <br />     (append <br />       (list <br />         (cons 0 "LWPOLYLINE")<br />         (cons 100 "AcDbEntity")<br />         (cons 100 "AcDbPolyline")<br />         (cons 90 (length PTLst))<br />       )<br />       (if Clsd (list (cons 70 1)))<br />       (mapcar '(lambda (PT) <br />                 (cons 10 <br />                   (if WCS PT (trans PT 1 0))<br />                 )<br />               ) <br />               PTLst<br />       )<br />     )<br />   )<br /> )<br />