程序：直线双向偏移并修剪(源码)2017.11.27更新...

LPACMQ

程序：直线双向偏移并修剪(源码)2017.11.27更新...
以下程序采用TRIM 命令的修剪方法，弊端挺多的，要不停的缩放窗口才能勉强保住修剪的准确...

1. ;;函数
   
2. ;;返回参考点的最近点表
   
3. (defun cq-getnears (pt lst)
   
4.   (vl-sort lst '(lambda(a b)(<(distance a pt)(distance b pt))))
   
5. )
   
6. ;;返回参考点的最近点  
   
7. (defun cq-getnear (pt lst)
   
8.   (car (cq-getnears pt lst))
   
9. )
   
10. 
    
11. 
    
12. ;|程序：直线双向偏移并修剪
    
13. ;;作者：LPACMQ 2017.11.26 (笔录: 以下程序采用TRIM 命令的修剪方法，弊端挺多的，如窗口缩放比例会影响修剪效果...个人觉得交点打断的思路编写更为恰当。或采用纯算法画线)|;
    
14. (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 距离 正交)
    
15. 
    
16.   (defun *error* (msg);;出错处理
    
17. ;    (if(or(wcmatch msg "*取消*")(wcmatch msg "*exit*"))
    
18. ;       (princ)
    
19. ;       (princ msg)
    
20. ;    )
    
21.     (command ^c)
    
22.     (alert "*失败：不能有连接点*")
    
23.     (command "undo" "B")
    
24.     (princ)
    
25.   )
    
26.   (setvar 'cmdecho 0)
    
27.   (setq TN 1 e1(entlast) ssg(ssadd) pts nil ipts nil xpts nil enlst nil)
    
28.   (while TN
    
29.       (if (not *距离)(setq *距离 3.0)*距离)
    
30.       (setq 距离(getdist (strcat "\n请输入偏移距离:" "<" (rtos *距离) ">")))
    
31.       (if (not 距离)(setq 距离 *距离))
    
32.       (if (not(< 0. 距离))
    
33.           (progn
    
34.             (setq TN T)(PRINC "\n*数值必须大于0*")
    
35.           )
    
36.           (progn
    
37.             (setq TN nil)
    
38.             (setq *距离 距离)
    
39.           )
    
40.       )
    
41.   );while
    
42.   
    
43.   (cond (距离
    
44.     (princ "\n请选择直线:")
    
45.     (setq ss(ssget '((0 . "LINE"))))
    
46.     (cond (ss
    
47.       (command "undo" "M")
    
48.       (command "undo" "be")
    
49.       (repeat (setq i(sslength ss))
    
50.         (setq ename(ssname ss (setq i(1- i))))
    
51.         (setq pt_lst(mapcar 'cdr(vl-remove-if-not '(lambda(x)(member (car x) '(10 11)))(entget ename))))
    
52.         (setq 正交(+ (* 0.5 pi)(angle(car pt_lst)(cadr pt_lst))))
    
53.         (command "offset" 距离 ename (polar (car pt_lst)正交 1.) "")
    
54.         (command "mirror" (entlast)""(car pt_lst)(cadr pt_lst) "")
    
55.         (setq enlst(cons ename enlst))
    
56.       )
    
57.       ;;收集图元
    
58.       (setq e2 e1)
    
59.       (while (setq e2(entnext e2)) (ssadd e2 ssg))
    
60.       
    
61.       ;;求交点1列表
    
62.       (repeat (setq i(sslength ss))
    
63.         (setq obj1(vlax-ename->vla-object(ssname ss (setq i(1- i)))))
    
64.         (repeat (setq k(sslength ssg))
    
65.           (setq obj2(vlax-ename->vla-object(ssname ssg (setq k(1- k)))))
    
66.           (if (setq xpt(vlax-invoke obj1 'IntersectWith obj2 acExtendNone));;acExtendOtherEntity
    
67.               (setq xpts(cons xpt xpts))
    
68.           )
    
69.         )
    
70.       )
    
71.    
    
72.       ;;求交点2列表
    
73.       (repeat (setq i(sslength ss))
    
74.         (setq name(ssname ss (setq i(1- i))))
    
75.         (setq obj1(vlax-ename->vla-object name))
    
76.         (setq ss(ssdel name ss))
    
77.         (repeat (setq k(sslength ss))
    
78.           (setq obj2(vlax-ename->vla-object(ssname ss (setq k(1- k)))))
    
79.           (if (setq ipt(vlax-invoke obj1 'IntersectWith obj2 acExtendNone));;acExtendOtherEntity
    
80.               (setq ipts(cons ipt ipts))
    
81.           )
    
82.         )
    
83.       )
    
84.       
    
85.       ;;求交点3列表
    
86.       (repeat (setq i(sslength ssg))
    
87.         (setq name(ssname ssg (setq i(1- i))))
    
88.         (setq obj1(vlax-ename->vla-object name))
    
89.         (setq ssg(ssdel name ssg))
    
90.         (repeat (setq k(sslength ssg))
    
91.           (setq obj2(vlax-ename->vla-object(ssname ssg (setq k(1- k)))))
    
92.           (if (setq pt(vlax-invoke obj1 'IntersectWith obj2 acExtendNone));;acExtendOtherEntity
    
93.               (setq pts(cons pt pts))
    
94.           )
    
95.         )
    
96.       )
    
97.       
    
98.       (mapcar '(lambda(x)(entdel x)) enlst);;隐藏
    
99.       
    
100.       (foreach ipt ipts
     
101.         ;;缩放窗口
     
102.         (setq zpts(cq-getnears ipt xpts))
     
103.         (setq Zw(cq-getnears ipt pts))
     
104.         (setq Zw(list(car zw)(cadr zw)(caddr zw)(cadddr zw)))
     
105.         (command "zoom" (apply 'mapcar (cons 'max Zw))(apply 'mapcar (cons 'min Zw)))
     
106.         (repeat (setq n 4)
     
107.           (command  "trim" ssg "" (nth(setq n(1- n))zpts) "")
     
108.           (setq e2 e1)(while (setq e2(entnext e2))(ssadd e2 ssg))
     
109.         )
     
110.         (command "zoom" "p")
     
111.       )
     
112.       
     
113.       ;;恢复
     
114.       (mapcar '(lambda(x)(entdel x)) enlst)
     
115.       ;;删除中线
     
116.       (initget  "Y N")
     
117.       (setq KEY (getkword "\n->删除中线[是(Y)/否(N)]<N>"))
     
118.       (if (= KEY "Y")(mapcar '(lambda(x)(entdel x)) enlst))
     
119.       (command "undo" "e")
     
120.     ));cond ss
     
121.   ));cond 距离
     
122.   (princ)
     
123. )

;;函数<br /> ;;返回参考点的最近点表<br /> (defun cq-getnears (pt lst)<br />   (vl-sort lst '(lambda(a b)(<(distance a pt)(distance b pt))))<br /> )<br /> ;;返回参考点的最近点  <br /> (defun cq-getnear (pt lst)<br />   (car (cq-getnears pt lst))<br /> )<br /> <br /> <br /> ;|程序：直线双向偏移并修剪<br /> ;;作者：LPACMQ 2017.11.26 (笔录: 以下程序采用TRIM 命令的修剪方法，弊端挺多的，如窗口缩放比例会影响修剪效果...个人觉得交点打断的思路编写更为恰当。或采用纯算法画线)|;<br /> (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 距离 正交)<br /> <br />   (defun *error* (msg);;出错处理<br /> ;    (if(or(wcmatch msg "*取消*")(wcmatch msg "*exit*"))<br /> ;       (princ)<br /> ;       (princ msg)<br /> ;    )<br />     (command ^c)<br />     (alert "*失败：不能有连接点*")<br />     (command "undo" "B")<br />     (princ)<br />   )<br />   (setvar 'cmdecho 0)<br />   (setq TN 1 e1(entlast) ssg(ssadd) pts nil ipts nil xpts nil enlst nil)<br />   (while TN<br />       (if (not *距离)(setq *距离 3.0)*距离)<br />       (setq 距离(getdist (strcat "\n请输入偏移距离:" "<" (rtos *距离) ">")))<br />       (if (not 距离)(setq 距离 *距离))<br />       (if (not(< 0. 距离))<br />           (progn<br />             (setq TN T)(PRINC "\n*数值必须大于0*")<br />           )<br />           (progn<br />             (setq TN nil)<br />             (setq *距离 距离)<br />           )<br />       )<br />   );while<br />   <br />   (cond (距离<br />     (princ "\n请选择直线:")<br />     (setq ss(ssget '((0 . "LINE"))))<br />     (cond (ss<br />       (command "undo" "M")<br />       (command "undo" "be")<br />       (repeat (setq i(sslength ss))<br />         (setq ename(ssname ss (setq i(1- i))))<br />         (setq pt_lst(mapcar 'cdr(vl-remove-if-not '(lambda(x)(member (car x) '(10 11)))(entget ename))))<br />         (setq 正交(+ (* 0.5 pi)(angle(car pt_lst)(cadr pt_lst))))<br />         (command "offset" 距离 ename (polar (car pt_lst)正交 1.) "")<br />         (command "mirror" (entlast)""(car pt_lst)(cadr pt_lst) "")<br />         (setq enlst(cons ename enlst))<br />       )<br />       ;;收集图元<br />       (setq e2 e1)<br />       (while (setq e2(entnext e2)) (ssadd e2 ssg))<br />       <br />       ;;求交点1列表<br />       (repeat (setq i(sslength ss))<br />         (setq obj1(vlax-ename->vla-object(ssname ss (setq i(1- i)))))<br />         (repeat (setq k(sslength ssg))<br />           (setq obj2(vlax-ename->vla-object(ssname ssg (setq k(1- k)))))<br />           (if (setq xpt(vlax-invoke obj1 'IntersectWith obj2 acExtendNone));;acExtendOtherEntity<br />               (setq xpts(cons xpt xpts))<br />           )<br />         )<br />       )<br />     <br />       ;;求交点2列表<br />       (repeat (setq i(sslength ss))<br />         (setq name(ssname ss (setq i(1- i))))<br />         (setq obj1(vlax-ename->vla-object name))<br />         (setq ss(ssdel name ss))<br />         (repeat (setq k(sslength ss))<br />           (setq obj2(vlax-ename->vla-object(ssname ss (setq k(1- k)))))<br />           (if (setq ipt(vlax-invoke obj1 'IntersectWith obj2 acExtendNone));;acExtendOtherEntity<br />               (setq ipts(cons ipt ipts))<br />           )<br />         )<br />       )<br />       <br />       ;;求交点3列表<br />       (repeat (setq i(sslength ssg))<br />         (setq name(ssname ssg (setq i(1- i))))<br />         (setq obj1(vlax-ename->vla-object name))<br />         (setq ssg(ssdel name ssg))<br />         (repeat (setq k(sslength ssg))<br />           (setq obj2(vlax-ename->vla-object(ssname ssg (setq k(1- k)))))<br />           (if (setq pt(vlax-invoke obj1 'IntersectWith obj2 acExtendNone));;acExtendOtherEntity<br />               (setq pts(cons pt pts))<br />           )<br />         )<br />       )<br />       <br />       (mapcar '(lambda(x)(entdel x)) enlst);;隐藏<br />       <br />       (foreach ipt ipts<br />         ;;缩放窗口<br />         (setq zpts(cq-getnears ipt xpts))<br />         (setq Zw(cq-getnears ipt pts))<br />         (setq Zw(list(car zw)(cadr zw)(caddr zw)(cadddr zw)))<br />         (command "zoom" (apply 'mapcar (cons 'max Zw))(apply 'mapcar (cons 'min Zw)))<br />         (repeat (setq n 4)<br />           (command  "trim" ssg "" (nth(setq n(1- n))zpts) "")<br />           (setq e2 e1)(while (setq e2(entnext e2))(ssadd e2 ssg))<br />         )<br />         (command "zoom" "p")<br />       )<br />       <br />       ;;恢复<br />       (mapcar '(lambda(x)(entdel x)) enlst)<br />       ;;删除中线<br />       (initget  "Y N")<br />       (setq KEY (getkword "\n->删除中线[是(Y)/否(N)]<N>"))<br />       (if (= KEY "Y")(mapcar '(lambda(x)(entdel x)) enlst))<br />       (command "undo" "e")<br />     ));cond ss<br />   ));cond 距离<br />   (princ)<br /> )

rocking2008

楼主，可否加一个倒角值？就是双向偏移再去掉中线以后，类似于一个十字路口，对这个路口的4个角进行倒圆角处理。默认为半径3就行了。

LPACMQ

【KAIXIN】 发表于 2017-11-27 13:38
如果只是直线的话，建议用entmake

确实，用纯算法+entmake更高效。

myhobby76

dear sir,
learning...
thanks for sharing

单恋111

还是自己编写吧，没有币

单恋111

还是自己编写吧，没有币

yoyoho

感谢 LPACMQ 分享程序!!!

逍遥天下

看，就不要币了吧

【KAIXIN】

如果只是直线的话，建议用entmake

longer1000

还是自己编写吧，没有币

linyi9121

还是自己编写吧，没有币

kosboy

let me see see