希望大神帮改个画单线管
在明经论坛经常有些连续画弯头的程序效果是图a，希望大神能帮添加两个功能（1）可以自定义多段线的宽度（2）在弯头处加两条短线短线（长度为线宽的5倍，如图b所示。论坛有个画连续弯头的程序：http://bbs.mjtd.com/thread-93655-3-1.html 这个程序也能实现图a的效果
(defun err (s)
(if (and (/= s "console break")
(/= s "Function cancelled")
(/= s "quit/exit abort")
)
(progn
(setvar "osmode" oldos)
(setvar "autosnap" oldosn)
(setvar "orthomode" oldor)
(setq *error* olderr)
(command "_.undo" "e")
(setvar "cmdecho" oldcmd)
(princ (strcat "\n程序出错或用户退出:" s))
)
)
)
;;;备份系统变量
(defun bak ()
(setq oldcmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "_.undo" "be")
(setq oldos (getvar "osmode")
oldosn (getvar "autosnap")
oldor (getvar "orthomode")
olderr *error*
*error* err
)
)
;;恢复系统变量
(defun rebak ()
(setvar "osmode" oldos)
(setvar "autosnap" oldosn)
(setvar "orthomode" oldor)
(setq *error* olderr)
(command "_.undo" "e")
(setvar "cmdecho" oldcmd)
)
;求交点集函数－nth
;;经过测试，nth函数仅比assoc函数快一点点。
;;故此函数也可取消i，j变量，直接使用assoc函数
(defun ssinter (el / el1 obj1 obj2 ipts pts list1 outlst i j)
(setq outlst (mapcar 'list el)
i -1 ;obj1位置指针
n 0 ;交点数计数器
)
(while el
(setq obj1 (car el)
list1 (nth (setq i (1+ i)) outlst) ;obj1已有的交点列表
el (cdr el)
el1 el
j i ;obj2位置指针
)
(while el1
(setq obj2 (car el1)
el1(cdr el1)
j(1+ j)
)
;;取交点
(if (and (setq ipts (vla-intersectwith obj1 obj2 0))
(setq ipts (vlax-variant-value ipts))
(> (vlax-safearray-get-u-bound ipts 1) 0)
)
(progn
(setq ipts (vlax-safearray->list ipts)
pts'();obj1,obj2交点临时列表变量
)
(while (> (length ipts) 0)
(setq pts(cons (list (car ipts)
(cadr ipts)
(caddr ipts)
)
pts
)
ipts (cdddr ipts)
)
)
(setq list1 (append list1 pts) ;存obj1交点表，循环结束后再更新
n (+ n (length pts)) ;交点计数累加
)
;;obj2的交点列表立即更新
(setq
outlst (subst (append (nth j outlst) pts)
(nth j outlst)
outlst
)
)
)
)
)
;| ;;当obj1存在交点，且非封闭曲线，添加两端点
(if (and (cdr list1) (not (vlax-curve-isClosed obj1)))
(setq list1 (append list1
(list (vlax-curve-getEndPoint obj1))
(list (vlax-curve-getStartPoint obj1))
)
)
)
(setq outlst (subst list1 (nth i outlst) outlst)) ;更新obj1交点列表 |;
)
outlst
)
;;点集排序及删除重复点函数
(defun InterSort (el / obj1 pts plst outlst)
(setq outlst '()) ;empty list
(foreach item el
(setq obj1 (car item)
pts(cdr item)
plst '() ;empty list
)
(if pts ;若无交点，则不修改该实体
(progn
;;交点排序，列表为逆序
(setq
pts (vl-sort
pts
(function (lambda (p1 p2)
(< (vlax-curve-getParamAtPoint obj1 p1)
(vlax-curve-getParamAtPoint obj1 p2)
)
)
)
)
)
;;剔除重复点并将列表顺序转正
(foreach p pts
(if plst
(if (not (equal p (car plst) 0.00001))
(setq plst (cons p plst))
)
(setq plst (cons p plst))
)
)
;;闭合曲线需再添加首个交点以使新实体完全封闭
(if (vlax-curve-isClosed obj1)
(setq plst (cons (last plst) plst))
)
(setq plst (cons (vlax-vla-object->ename obj1) plst)
outlst (cons plst outlst)
)
)
)
)
outlst
)
;;计算耗时
(defun xdl-getutime ()
(* 86400 (getvar "tdusrtimer"))
)
;; 清理当前选择集
(defun Clearcset (/ cset)
(if (not (vl-catch-all-error-p
(setq cset (vl-catch-all-apply 'vla-item (list(vlax-get-property (vlax-get-property (vlax-get-acad-object) 'activedocument ) 'selectionsets)"CURRENT")))
)
)
(vla-delete cset)
)
(princ)
)
(defun c:xlx( / elist ssg n t0)
(VL-LOAD-COM)
(setq pt_list1 '())
(setq r (getreal (strcat "请输入倒角半径<" (rtos (getvar "filletrad"))
">"
)
)
)
(if (null r)
(setq r (getvar "filletrad"))
(setvar "filletrad" r)
)
;(setq ss (ssget '((0 . "line"))))
(bak)
(clearcset)
(if (setq ssg (ssget '((0 . "line"))))
(vlax-for obj (vla-get-activeselectionset
(vla-get-activedocument (vlax-get-acad-object))
)
(setq elist (cons obj elist)) ; ssg->elist
)
(vlax-release-object obj)
)
(setq t0 (xdl-getutime))
(setq pt_list(InterSort (ssinter elist)))
(foreach pt pt_list
(setq pt_list1 (append (cdr pt)pt_list1))
)
(foreach pt pt_list1
;(setq pt (cadr pt))
(progn
(setq ss2 (ssget "c" pt pt))
(setq en1 (ssname ss2 0))
(setq en2 (ssname ss2 1))
(if (and en1 en2)(command "fillet" en1 en2))
)
)
(rebak)
(princ (strcat "\n*****找到交点"
(itoa n)
"个，交点倒角操作操作共耗时"
(rtos (- (xdl-getutime) t0) 2 3)
"秒。*****"
)
)
(princ)
(prompt "<<xlx>>相连线批量倒角")
)
(prompt "<<xlx>>相连线批量倒角")
(princ)
页:
[1]