悬赏实现多段线描绘效果LISP源码，谢谢

树櫴希德

贴上伪源码

1. ;21、绘截描线
   
2. (defun c:hjmx ( / catch e1 e2 ent ex fz getfun ls ob ob1 obs okp p1 p2 pLst pn poly ps psx ss tp tps)
   
3.   (defun getfun ()
   
4.     (if p1
   
5.       (progn (initget "C H U") (setq p2 (getpoint "\n指定下一个点[闭合(C)/描边与直线切换(H)/放弃(U)]<退出>：" p1)))
   
6.       (progn (initget "S") (setq p1 (getpoint (strcat "\n请指定'绘截描线'的起点[设置(S)]<退出>："))))
   
7.     )
   
8.     (setq psx (list p1 p2) p1 (car psx) p2 (cadr psx))
   
9.   )
   
10.   ; 主程序
    
11.   (setq tps '("LWPOLYLINE" "CIRCLE" "ARC" "ELLIPSE") fz 0.03 p1 nil p2 nil e1 nil e2 nil
    
12.       ps nil pLst nil ob nil obs nil okp t poly nil ; pLst为'((p1 p2 e1 e2 ob) ...)
    
13.   )
    
14.   (while (and okp (setq catch (vl-catch-all-apply 'getfun nil)))
    
15.     (if (and catch (not (vl-catch-all-error-p catch)))
    
16.       (progn
    
17.         (if (and p2 (listp p2) p1  (< (distance p1 p2) fz))  (progn (setq p2 nil) (princ "\n距离太近，无效点！")))
    
18.         (cond
    
19.           ((and p1 (listp p1) (not p2))
    
20.             (if (and (setq ent (nentselp p1)) (setq e1 (car ent) tp (En-GetProp* e1 0)) (vl-position tp tps))
    
21.               (setq p1 (cadr ent) ex (sssetfirst nil (Data-ToSs* e1))) ; (nentselp (getpoint))
    
22.               (setq e1 nil)
    
23.             )
    
24.             (setq ps (cons p1 ps) pLst (cons (list p1 p2 e1 e2 ob) pLst))
    
25.           )
    
26.           ((and p2 (listp p2) p1)
    
27.             (if (and (setq ent (nentselp p2)) (setq e2 (car ent) tp (En-GetProp* e2 0)) (vl-position tp tps))
    
28.               (progn
    
29.                 (sssetfirst nil nil) ; 清除之前的选择
    
30.                 (setq p2 (cadr ent) ex (sssetfirst nil (Data-ToSs* e2))) ; (nentselp (getpoint))
    
31.                 (if (and e1 (equal e1 e2))
    
32.                   (setq ob (Curve-PartCopy* e1 p1 p2)) ; 在同一条曲线上 要描边
    
33.                   (setq ob (vlax-Invoke *Model* "AddLine" p1 p2)) ; 绘制直线
    
34.                 )
    
35.               ) ; (getpoint p1) (getpoint p2)  (Else-TestPts* ps) (length ps) (length pLst) (setq ps nil)
    
36.               (setq e2 nil ob (vlax-Invoke *Model* "AddLine" p1 p2)) ; 绘制直线
    
37.             )
    
38.             (setq ps (cons p2 ps) obs (cons ob obs) pLst (cons (list p1 p2 e1 e2 ob) pLst) p1 p2 e1 e2)
    
39. ;            (if (> n 1) (setq sso (cadr (ssgetfirst)))) ; 获取并保留之前的选择
    
40. ;            (sssetfirst nil nil) ; 清除之前的选择
    
41. ;            (sssetfirst nil (Ss-Union* sso ss)) ; 夹点显示
    
42.           )
    
43.           ((= p1 "S") ; 只能最开始设置一次
    
44.             (princ "\n暂未添加设置信息，后续增加，谢谢！")
    
45.             (princ)
    
46.           )
    
47.         )
    
48.         (cond
    
49.           ((and (> (length obs) 1) (= p2 "C")) ; 闭合并退出 并 校对悬挂点
    
50.             (setq okp nil ss (cadr (ssgetfirst))) ; (sssetfirst nil ss) (sslength ss)
    
51. ;            (setq poly (car (Poly-Joina* obs t t nil nil nil))) ; (Poly-Joina* enobss polyp delp lay litp c)
    
52.             (setq poly (Cmd-JionToPoly* (Data-ToSs* obs) fz))
    
53.             (Ob-MdfProp* poly "Closed" -1)
    
54. ;            (sssetfirst nil nil) ; 清除之前的选择
    
55.           )
    
56.           ((and e1 (equal e1 e2) (= p2 "H")) ; 切换
    
57.             (setq ls (car pLst) p1 (car ls) p2 (cadr ls) ob (nth 4 ls)) ; (getpoint p1) (getpoint p2)
    
58.             (if (= (vlax-Get ob "ObjectName") "AcDbLine")
    
59.               (setq ob1 (Curve-PartCopy* e1 p1 p2)) ; 在同一条曲线上 要描边
    
60.               (setq ob1 (vlax-Invoke *Model* "AddLine" p1 p2)) ; 绘制直线
    
61.             )
    
62.             (vlax-Invoke ob "Delete") ; 删除当前线
    
63.             (setq ob ob1 obs (cdr obs) obs (cons ob obs) pLst (cdr pLst) pLst (cons (list p1 p2 e1 e2 ob) pLst) p1 p2)
    
64.           )
    
65.           ((and p1 p2 ps pn (= p2 "U")) ; 撤销
    
66.             (setq ls (car pLst) p1 (car ls) p2 (cadr ls) e1 (caddr ls) e2 (nth 3 ls) ob (nth 4 ls))
    
67.           )
    
68.         )
    
69.       )
    
70.     )
    
71.   )
    
72.   (if (and (not poly) (> (length obs) 1))
    
73.     (setq poly (Cmd-JionToPoly* (Data-ToSs* obs) fz)) ; (setq poly (car (Poly-Joinv* obs t t nil nil nil)))
    
74.   )
    
75.   (setq ex (sssetfirst nil nil) getfun nil) ; 清除之前的选择，清除子函数
    
76.   (princ "\n'绘截描线'完毕，感谢使用!")
    
77.   (princ)
    
78. )

;21、绘截描线<br /> (defun c:hjmx ( / catch e1 e2 ent ex fz getfun ls ob ob1 obs okp p1 p2 pLst pn poly ps psx ss tp tps)<br />   (defun getfun ()<br />     (if p1<br />       (progn (initget "C H U") (setq p2 (getpoint "\n指定下一个点[闭合(C)/描边与直线切换(H)/放弃(U)]<退出>：" p1)))<br />       (progn (initget "S") (setq p1 (getpoint (strcat "\n请指定'绘截描线'的起点[设置(S)]<退出>："))))<br />     )<br />     (setq psx (list p1 p2) p1 (car psx) p2 (cadr psx))<br />   )<br />   ; 主程序<br />   (setq tps '("LWPOLYLINE" "CIRCLE" "ARC" "ELLIPSE") fz 0.03 p1 nil p2 nil e1 nil e2 nil<br />       ps nil pLst nil ob nil obs nil okp t poly nil ; pLst为'((p1 p2 e1 e2 ob) ...)<br />   )<br />   (while (and okp (setq catch (vl-catch-all-apply 'getfun nil)))<br />     (if (and catch (not (vl-catch-all-error-p catch)))<br />       (progn<br />         (if (and p2 (listp p2) p1  (< (distance p1 p2) fz))  (progn (setq p2 nil) (princ "\n距离太近，无效点！")))<br />         (cond<br />           ((and p1 (listp p1) (not p2))<br />             (if (and (setq ent (nentselp p1)) (setq e1 (car ent) tp (En-GetProp* e1 0)) (vl-position tp tps))<br />               (setq p1 (cadr ent) ex (sssetfirst nil (Data-ToSs* e1))) ; (nentselp (getpoint))<br />               (setq e1 nil)<br />             )<br />             (setq ps (cons p1 ps) pLst (cons (list p1 p2 e1 e2 ob) pLst))<br />           )<br />           ((and p2 (listp p2) p1)<br />             (if (and (setq ent (nentselp p2)) (setq e2 (car ent) tp (En-GetProp* e2 0)) (vl-position tp tps))<br />               (progn<br />                 (sssetfirst nil nil) ; 清除之前的选择<br />                 (setq p2 (cadr ent) ex (sssetfirst nil (Data-ToSs* e2))) ; (nentselp (getpoint))<br />                 (if (and e1 (equal e1 e2))<br />                   (setq ob (Curve-PartCopy* e1 p1 p2)) ; 在同一条曲线上 要描边<br />                   (setq ob (vlax-Invoke *Model* "AddLine" p1 p2)) ; 绘制直线<br />                 )<br />               ) ; (getpoint p1) (getpoint p2)  (Else-TestPts* ps) (length ps) (length pLst) (setq ps nil)<br />               (setq e2 nil ob (vlax-Invoke *Model* "AddLine" p1 p2)) ; 绘制直线<br />             )<br />             (setq ps (cons p2 ps) obs (cons ob obs) pLst (cons (list p1 p2 e1 e2 ob) pLst) p1 p2 e1 e2)<br /> ;            (if (> n 1) (setq sso (cadr (ssgetfirst)))) ; 获取并保留之前的选择<br /> ;            (sssetfirst nil nil) ; 清除之前的选择<br /> ;            (sssetfirst nil (Ss-Union* sso ss)) ; 夹点显示<br />           )<br />           ((= p1 "S") ; 只能最开始设置一次<br />             (princ "\n暂未添加设置信息，后续增加，谢谢！")<br />             (princ)<br />           )<br />         )<br />         (cond<br />           ((and (> (length obs) 1) (= p2 "C")) ; 闭合并退出 并 校对悬挂点<br />             (setq okp nil ss (cadr (ssgetfirst))) ; (sssetfirst nil ss) (sslength ss)<br /> ;            (setq poly (car (Poly-Joina* obs t t nil nil nil))) ; (Poly-Joina* enobss polyp delp lay litp c)<br />             (setq poly (Cmd-JionToPoly* (Data-ToSs* obs) fz))<br />             (Ob-MdfProp* poly "Closed" -1)<br /> ;            (sssetfirst nil nil) ; 清除之前的选择<br />           )<br />           ((and e1 (equal e1 e2) (= p2 "H")) ; 切换<br />             (setq ls (car pLst) p1 (car ls) p2 (cadr ls) ob (nth 4 ls)) ; (getpoint p1) (getpoint p2)<br />             (if (= (vlax-Get ob "ObjectName") "AcDbLine")<br />               (setq ob1 (Curve-PartCopy* e1 p1 p2)) ; 在同一条曲线上 要描边<br />               (setq ob1 (vlax-Invoke *Model* "AddLine" p1 p2)) ; 绘制直线<br />             )<br />             (vlax-Invoke ob "Delete") ; 删除当前线<br />             (setq ob ob1 obs (cdr obs) obs (cons ob obs) pLst (cdr pLst) pLst (cons (list p1 p2 e1 e2 ob) pLst) p1 p2)<br />           )<br />           ((and p1 p2 ps pn (= p2 "U")) ; 撤销<br />             (setq ls (car pLst) p1 (car ls) p2 (cadr ls) e1 (caddr ls) e2 (nth 3 ls) ob (nth 4 ls))<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (if (and (not poly) (> (length obs) 1))<br />     (setq poly (Cmd-JionToPoly* (Data-ToSs* obs) fz)) ; (setq poly (car (Poly-Joinv* obs t t nil nil nil)))<br />   )<br />   (setq ex (sssetfirst nil nil) getfun nil) ; 清除之前的选择，清除子函数<br />   (princ "\n'绘截描线'完毕，感谢使用!")<br />   (princ)<br /> )

p-3-ianlcc

这个不错，希望有大佬能够修正分享！
占个位子…期待

wline

这个厉害了，坐等哪位大佬出手