点表双侧偏移(类似OFFSET)

kucha007

点表双侧偏移，类似Offest的方法，不过不支持弧线。用于我的云线插件：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=186837&page=1&extra=#pid934925
在论坛找了半天只找到了这个帖子，于是只好自己写了:
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=108141&fromuid=7329538

1. ;根据UCS折线点表生成两侧偏移的折线
   
2. (defun K:GetOFFPL (UCSLst RvCol / K:DynOffUCSLst StaPt Code TmpLst i Key EntNam)
   
3.   ;点表偏移多段线
   
4.   (defun K:DynOffUCSLst (UCSLst Dst / i StaPT NxtPT Ang FstLst SecLst TmpLst K:INPLst)
   
5.         ;求偏移后的UCS每段的交点成UCS点表
   
6.         (defun K:INPLst (TmpLst / i SL EL RtnLst)
   
7.             (setq i 0)
   
8.             (while (< i (1- (length TmpLst)))
   
9.                 (setq SL (nth i TmpLst)
   
10.                       EL (nth (setq i (1+ i)) TmpLst)
    
11.                 )
    
12.                 (if (setq InP (inters (car SL) (cadr SL) (car EL) (cadr EL) nil));无限长求交点
    
13.                     (setq RtnLst (cons InP RtnLst))
    
14.                 )
    
15.             )
    
16.             (setq RtnLst (append (list (car (car TmpLst))) (reverse RtnLst) (list (cadr (Last TmpLst)))))
    
17.         )
    
18.         (setq FstLst Nil SecLst Nil)
    
19.         (setq i 0);初始化
    
20.         (while (< i (1- (length UCSLst)))
    
21.             (progn
    
22.                 (setq StaPT (nth i UCSLst);UCS
    
23.                       NxtPT (nth (setq i (1+ i)) UCSLst);UCS
    
24.                 )
    
25.                 (setq Ang (- (angle StaPT NxtPT) (* 0.5 pi)))
    
26.                 (while (minusp Ang)(setq Ang (+ Ang (* 2 pi))))
    
27.                 (setq FstLst (cons (list (polar StaPT Ang (+ 0 Dst)) (polar NxtPT Ang (+ 0 Dst))) FstLst)
    
28.                       SecLst (cons (list (polar StaPT Ang (- 0 Dst)) (polar NxtPT Ang (- 0 Dst))) SecLst)
    
29.                 )
    
30.             )
    
31.         );分段两侧偏移
    
32.         (setq TmpLst (append (K:INPLst (reverse FstLst)) (reverse (K:INPLst (reverse SecLst)))))
    
33.         TmpLst
    
34.   )
    
35.   ;点表生成多段线
    
36.   (defun K:MakeLWPOLYLINE (WCS Clsd PTLst / PT)
    
37.     (entmakeX
    
38.       (append
    
39.         (list
    
40.           (cons 0 "LWPOLYLINE")
    
41.           (cons 100 "AcDbEntity")
    
42.           (cons 100 "AcDbPolyline")
    
43.           (cons 90 (length PTLst))
    
44.         )
    
45.         (if Clsd (list (cons 70 1)))
    
46.         (mapcar '(lambda (PT)
    
47.                   (cons 10
    
48.                     (if WCS PT (trans PT 1 0))
    
49.                   )
    
50.                 )
    
51.           PTLst
    
52.         )
    
53.       )
    
54.     )
    
55.   )
    
56.   (if (and UCSLst (>= (length UCSLst) 2))
    
57.         (progn
    
58.             (setq StaPt (Last UCSLst));UCS
    
59.             (while
    
60.               (progn
    
61.                 (princ "\n→请指定偏移距离<或空格>: ")
    
62.                 (while (and (setq Code (grread T (+ 1 4 8))) (eq (car Code) 5))
    
63.                     (redraw)
    
64.                     (grdraw StaPt (cadr Code) RvCol);长度线
    
65.                     (setq TmpLst (K:DynOffUCSLst UCSLst (distance StaPt (cadr Code))))
    
66.                     (setq i 0);初始化
    
67.                     (while (< i (length TmpLst))
    
68.                         (if (= (setq i (1+ i)) (length TmpLst));最后一个
    
69.                             (grdraw (Last TmpLst) (car TmpLst) RvCol)
    
70.                             (grdraw (nth (1- i) TmpLst) (nth i TmpLst) RvCol)
    
71.                         )
    
72.                     );显示线
    
73.                 );显示预览
    
74.                 (setq Key (cadr Code))
    
75.                 (cond
    
76.                   ((and (eq (car Code) 3) (eq (type Key) 'LIST));点选
    
77.                       (redraw)
    
78.                       (setq EntNam (K:MakeLWPOLYLINE Nil T (K:DynOffUCSLst UCSLst (distance StaPt (cadr Code)))))
    
79.                       Nil ;退出循环
    
80.                   )
    
81.                   ((equal Code '(2 32));空格
    
82.                     (redraw)
    
83.                     (setq EntNam (K:MakeLWPOLYLINE Nil T  (K:DynOffUCSLst UCSLst (distance StaPt (cadr (grread '(2 32)))))))
    
84.                     Nil ;退出循环
    
85.                   )
    
86.                   (T Nil)
    
87.                 )
    
88.               )
    
89.             )
    
90.             EntNam
    
91.         )
    
92.   )
    
93. )
    

;根据UCS折线点表生成两侧偏移的折线<br /> (defun K:GetOFFPL (UCSLst RvCol / K:DynOffUCSLst StaPt Code TmpLst i Key EntNam)<br />   ;点表偏移多段线<br />   (defun K:DynOffUCSLst (UCSLst Dst / i StaPT NxtPT Ang FstLst SecLst TmpLst K:INPLst)<br />         ;求偏移后的UCS每段的交点成UCS点表<br />         (defun K:INPLst (TmpLst / i SL EL RtnLst)<br />             (setq i 0)<br />             (while (< i (1- (length TmpLst)))<br />                 (setq SL (nth i TmpLst)<br />                       EL (nth (setq i (1+ i)) TmpLst)<br />                 )<br />                 (if (setq InP (inters (car SL) (cadr SL) (car EL) (cadr EL) nil));无限长求交点<br />                     (setq RtnLst (cons InP RtnLst))<br />                 )<br />             )<br />             (setq RtnLst (append (list (car (car TmpLst))) (reverse RtnLst) (list (cadr (Last TmpLst)))))<br />         )<br />         (setq FstLst Nil SecLst Nil)<br />         (setq i 0);初始化<br />         (while (< i (1- (length UCSLst)))<br />             (progn<br />                 (setq StaPT (nth i UCSLst);UCS<br />                       NxtPT (nth (setq i (1+ i)) UCSLst);UCS<br />                 )<br />                 (setq Ang (- (angle StaPT NxtPT) (* 0.5 pi)))<br />                 (while (minusp Ang)(setq Ang (+ Ang (* 2 pi))))<br />                 (setq FstLst (cons (list (polar StaPT Ang (+ 0 Dst)) (polar NxtPT Ang (+ 0 Dst))) FstLst)<br />                       SecLst (cons (list (polar StaPT Ang (- 0 Dst)) (polar NxtPT Ang (- 0 Dst))) SecLst)<br />                 )<br />             )<br />         );分段两侧偏移<br />         (setq TmpLst (append (K:INPLst (reverse FstLst)) (reverse (K:INPLst (reverse SecLst)))))<br />         TmpLst <br />   )<br />   ;点表生成多段线<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 />   (if (and UCSLst (>= (length UCSLst) 2))<br />         (progn<br />             (setq StaPt (Last UCSLst));UCS<br />             (while <br />               (progn<br />                 (princ "\n→请指定偏移距离<或空格>: ")<br />                 (while (and (setq Code (grread T (+ 1 4 8))) (eq (car Code) 5)) <br />                     (redraw)<br />                     (grdraw StaPt (cadr Code) RvCol);长度线<br />                     (setq TmpLst (K:DynOffUCSLst UCSLst (distance StaPt (cadr Code))))<br />                     (setq i 0);初始化<br />                     (while (< i (length TmpLst))<br />                         (if (= (setq i (1+ i)) (length TmpLst));最后一个<br />                             (grdraw (Last TmpLst) (car TmpLst) RvCol)<br />                             (grdraw (nth (1- i) TmpLst) (nth i TmpLst) RvCol)<br />                         )<br />                     );显示线<br />                 );显示预览<br />                 (setq Key (cadr Code))<br />                 (cond<br />                   ((and (eq (car Code) 3) (eq (type Key) 'LIST));点选<br />                       (redraw)<br />                       (setq EntNam (K:MakeLWPOLYLINE Nil T (K:DynOffUCSLst UCSLst (distance StaPt (cadr Code)))))<br />                       Nil ;退出循环<br />                   )<br />                   ((equal Code '(2 32));空格<br />                     (redraw)<br />                     (setq EntNam (K:MakeLWPOLYLINE Nil T  (K:DynOffUCSLst UCSLst (distance StaPt (cadr (grread '(2 32)))))))<br />                     Nil ;退出循环<br />                   )<br />                   (T Nil)<br />                 )<br />               )<br />             )<br />             EntNam<br />         )<br />   )<br /> )<br />

补充一个基础函数：

1. ;选取多个UCS点用于生成多段线
   
2. (defun K:GetUCSPTLst (StaPT BGCol / UCSLst TgtPT)
   
3.     (setq UCSLst Nil)
   
4.     (if (car (setq UCSLst (list StaPT)))
   
5.         (while
   
6.           (setq TgtPT (if (>= (length UCSLst) 2)  ;至少两个点
   
7.                         (progn
   
8.                           (initget "U")
   
9.                           (getpoint (car UCSLst) "\n→请指定下一点或空格结束[撤回(U)]: ")
   
10.                         )
    
11.                         (getpoint (car UCSLst) "\n→请指定下一点或空格结束:")
    
12.                       )
    
13.           )
    
14.           (redraw)
    
15.           (mapcar
    
16.             '(lambda (a b) (grdraw a b BGCol 1))
    
17.             (setq UCSLst (if (eq TgtPT "U")
    
18.                           (cdr UCSLst)
    
19.                           (cons TgtPT UCSLst)
    
20.                         )
    
21.             )
    
22.             (cdr UCSLst)
    
23.           )
    
24.         )
    
25.     )
    
26.     (princ)(redraw)
    
27.     (cond ((>= (length UCSLst) 2) (reverse UCSLst)))
    
28. )
    

;选取多个UCS点用于生成多段线<br /> (defun K:GetUCSPTLst (StaPT BGCol / UCSLst TgtPT) <br />     (setq UCSLst Nil)<br />     (if (car (setq UCSLst (list StaPT))) <br />         (while <br />           (setq TgtPT (if (>= (length UCSLst) 2)  ;至少两个点<br />                         (progn <br />                           (initget "U")<br />                           (getpoint (car UCSLst) "\n→请指定下一点或空格结束[撤回(U)]: ")<br />                         )<br />                         (getpoint (car UCSLst) "\n→请指定下一点或空格结束:")<br />                       )<br />           )<br />           (redraw)<br />           (mapcar <br />             '(lambda (a b) (grdraw a b BGCol 1))<br />             (setq UCSLst (if (eq TgtPT "U") <br />                           (cdr UCSLst)<br />                           (cons TgtPT UCSLst)<br />                         )<br />             )<br />             (cdr UCSLst)<br />           )<br />         )<br />     )<br />     (princ)(redraw)<br />     (cond ((>= (length UCSLst) 2) (reverse UCSLst)))<br /> )<br />

用法：

1. (if (and
   
2.         (setq StaPT (getpoint))
   
3.         (setq UCSLst (K:GetUCSPTLst StaPT 1))
   
4.     )
   
5.     (K:GetOFFPL UCSLst 1)
   
6. )
   

(if (and <br />         (setq StaPT (getpoint))<br />         (setq UCSLst (K:GetUCSPTLst StaPT 1))<br />     ) <br />     (K:GetOFFPL UCSLst 1)<br /> )<br />

hubeiwdlue

这个真牛逼，谢谢分享。

yanchao316

看起很不错。不过打开这个页面电脑浏览器就卡爆了