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