程序：直线双向偏移并修剪(源码)2017.11.27更新...
本帖最后由 LPACMQ 于 2018-2-25 13:05 编辑程序：直线双向偏移并修剪(源码)2017.11.27更新...
以下程序采用TRIM 命令的修剪方法，弊端挺多的，要不停的缩放窗口才能勉强保住修剪的准确...
;;函数
;;返回参考点的最近点表
(defun cq-getnears (pt lst)
(vl-sort lst '(lambda(a b)(<(distance a pt)(distance b pt))))
)
;;返回参考点的最近点
(defun cq-getnear (pt lst)
(car (cq-getnears pt lst))
)
;|程序：直线双向偏移并修剪
;;作者：LPACMQ 2017.11.26 (笔录: 以下程序采用TRIM 命令的修剪方法，弊端挺多的，如窗口缩放比例会影响修剪效果...个人觉得交点打断的思路编写更为恰当。或采用纯算法画线)|;
(defun c:tt ( / *error* e1 e2 ename enlst i ipt ipts k KEY n name obj1 obj2 pt pt_lst pts ss ssg TN x xpt xpts zpts Zw 距离 正交)
(defun *error* (msg);;出错处理
; (if(or(wcmatch msg "*取消*")(wcmatch msg "*exit*"))
; (princ)
; (princ msg)
; )
(command ^c)
(alert "*失败：不能有连接点*")
(command "undo" "B")
(princ)
)
(setvar 'cmdecho 0)
(setq TN 1 e1(entlast) ssg(ssadd) pts nil ipts nil xpts nil enlst nil)
(while TN
(if (not *距离)(setq *距离 3.0)*距离)
(setq 距离(getdist (strcat "\n请输入偏移距离:" "<" (rtos *距离) ">")))
(if (not 距离)(setq 距离 *距离))
(if (not(< 0. 距离))
(progn
(setq TN T)(PRINC "\n*数值必须大于0*")
)
(progn
(setq TN nil)
(setq *距离 距离)
)
)
);while
(cond (距离
(princ "\n请选择直线:")
(setq ss(ssget '((0 . "LINE"))))
(cond (ss
(command "undo" "M")
(command "undo" "be")
(repeat (setq i(sslength ss))
(setq ename(ssname ss (setq i(1- i))))
(setq pt_lst(mapcar 'cdr(vl-remove-if-not '(lambda(x)(member (car x) '(10 11)))(entget ename))))
(setq 正交(+ (* 0.5 pi)(angle(car pt_lst)(cadr pt_lst))))
(command "offset" 距离 ename (polar (car pt_lst)正交 1.) "")
(command "mirror" (entlast)""(car pt_lst)(cadr pt_lst) "")
(setq enlst(cons ename enlst))
)
;;收集图元
(setq e2 e1)
(while (setq e2(entnext e2)) (ssadd e2 ssg))
;;求交点1列表
(repeat (setq i(sslength ss))
(setq obj1(vlax-ename->vla-object(ssname ss (setq i(1- i)))))
(repeat (setq k(sslength ssg))
(setq obj2(vlax-ename->vla-object(ssname ssg (setq k(1- k)))))
(if (setq xpt(vlax-invoke obj1 'IntersectWith obj2 acExtendNone));;acExtendOtherEntity
(setq xpts(cons xpt xpts))
)
)
)
;;求交点2列表
(repeat (setq i(sslength ss))
(setq name(ssname ss (setq i(1- i))))
(setq obj1(vlax-ename->vla-object name))
(setq ss(ssdel name ss))
(repeat (setq k(sslength ss))
(setq obj2(vlax-ename->vla-object(ssname ss (setq k(1- k)))))
(if (setq ipt(vlax-invoke obj1 'IntersectWith obj2 acExtendNone));;acExtendOtherEntity
(setq ipts(cons ipt ipts))
)
)
)
;;求交点3列表
(repeat (setq i(sslength ssg))
(setq name(ssname ssg (setq i(1- i))))
(setq obj1(vlax-ename->vla-object name))
(setq ssg(ssdel name ssg))
(repeat (setq k(sslength ssg))
(setq obj2(vlax-ename->vla-object(ssname ssg (setq k(1- k)))))
(if (setq pt(vlax-invoke obj1 'IntersectWith obj2 acExtendNone));;acExtendOtherEntity
(setq pts(cons pt pts))
)
)
)
(mapcar '(lambda(x)(entdel x)) enlst);;隐藏
(foreach ipt ipts
;;缩放窗口
(setq zpts(cq-getnears ipt xpts))
(setq Zw(cq-getnears ipt pts))
(setq Zw(list(car zw)(cadr zw)(caddr zw)(cadddr zw)))
(command "zoom" (apply 'mapcar (cons 'max Zw))(apply 'mapcar (cons 'min Zw)))
(repeat (setq n 4)
(command"trim" ssg "" (nth(setq n(1- n))zpts) "")
(setq e2 e1)(while (setq e2(entnext e2))(ssadd e2 ssg))
)
(command "zoom" "p")
)
;;恢复
(mapcar '(lambda(x)(entdel x)) enlst)
;;删除中线
(initget"Y N")
(setq KEY (getkword "\n->删除中线[是(Y)/否(N)]<N>"))
(if (= KEY "Y")(mapcar '(lambda(x)(entdel x)) enlst))
(command "undo" "e")
));cond ss
));cond 距离
(princ)
)
楼主，可否加一个倒角值？就是双向偏移再去掉中线以后，类似于一个十字路口，对这个路口的4个角进行倒圆角处理。默认为半径3就行了。 【KAIXIN】 发表于 2017-11-27 13:38
如果只是直线的话，建议用entmake
确实，用纯算法+entmake更高效。 dear sir,
learning...
thanks for sharing 还是自己编写吧，没有币 还是自己编写吧，没有币 感谢 LPACMQ 分享程序!!! 看，就不要币了吧:lol 如果只是直线的话，建议用entmake 还是自己编写吧，没有币 还是自己编写吧，没有币 let me see see