无聊源码：多义线局部线段拷贝，偏移程序v1.0-----------lxx.2004.

狂刀lxx

老程序,呷一口咖啡，追忆往事不堪回首明月中嫦娥

2. 
   
3. ;; (plncp eplst)(c:plncp)(plnff eplst)(c:plnff) = 多义线局部线段拷贝，偏移程序v1.0-----------lxx.2004.7.30
   
4. (vl-load-com)
   
5. (alert "\n 多义线局部线段拷贝，偏移程序v1.0
   
6.         \n-------梦断江南.2004.7.30--------\n
   
7.         \n(plncp eplst) = 拷贝多义线单段线段
   
8.         \nc:plc = 拷贝多义线局部线段并连接
   
9.         \n(plnff eplst) = 偏移多义线单段线段
   
10.         \nc:plf = 偏移多义线局部线段并连接
    
11.        ")
    
12. ;;/////////////////////////////////******拷贝多义线局部线段*****/////////////////////////////////////;;
    
13. ;| (plncp eplst) = 拷贝多义线单段线段------------ok!!!------------------lxx.2004.7.29
    
14. 说明: 1.支持polyline及lwpolyline. 2.仅可拷贝单段.
    
15. 参数: eplst = (entsel)返回的表.必须选中多义线!
    
16. 返回: (list eplst p2 (distance p p2) el)
    
17. 测试: (plncp (entsel))
    
18. |;
    
19. (defun plncp (eplst / e p1 p ent el el0  k seq plx plx2 p2)
    
20.   (setq e  (car eplst)
    
21. p1 (cadr eplst)
    
22. p  (vlax-curve-getclosestpointto e p1);;确保取点.
    
23.         ent(entget e))
    
24.   (if (= "LWPOLYLINE" (cdr(assoc 0 ent))) ;;转为旧式pl格式.
    
25.     (progn
    
26.       (vl-cmdf "_.convertpoly" "h" e "")
    
27.       (setq eL (entlast) el0 el ent (entget el) k T)
    
28.     )
    
29.     (setq el e el0 e)
    
30.   )
    
31.   (while (/= "SEQEND" (cdr(assoc 0 (setq seq (entget(setq el (entnext el))))))));;取seqend段.
    
32.   (setq ent (subst (cons 70 0) (assoc 70 ent) ent) ;;改为不封闭.
    
33.         plx (entget (car(nentselp p1)));;取点中段的实体表.
    
34.        plx2 (entget(entnext (cdr(assoc -1 plx)))));;下一个.
    
35.   (if (equal seq plx2)(setq plx2 (entget (entnext el0))));;如果是闭合段,下一个取pl线第一段.
    
36.   (mapcar 'entmakex(mapcar '(lambda (y) (vl-remove-if '(lambda(x)(member (car x) '(-1 5 -2))) y))(list ent plx plx2 seq)));;生成新的pl段.
    
37.   ;(if k (entdel el0));;删除多余实体.
    
38.   (vl-cmdf "_.move" (setq el (entlast)) "" p pause)
    
39.   (if (equal (setq p2 (getvar "lastpoint")) p 1e-4)
    
40.     (progn (entdel el) nil)
    
41.     (list eplst p2 (distance p p2) el)
    
42.   )
    
43. )
    
44. ;;;;;;;;;;;;;;
    
45. ;| plncp = 拷贝多义线局部线段并连接. -ok!!!------------------lxx.2004.7.30
    
46. |;
    
47. (defun c:plc (/ ss a b lst dis)
    
48.   (setq ss (ssadd))
    
49.   (while (setq a (entsel))
    
50.     (if (setq b (plncp a))(setq lst (cons b lst)))
    
51.   )
    
52.   (mapcar '(lambda(x)(ssadd (last x) ss)) lst)
    
53.   (setq dis (apply 'max (mapcar '(lambda(x)(nth 2 x)) lst)))
    
54.   (vl-cmdf "_.Pedit" "m" ss "" "J" (* 2 dis) "")
    
55. )
    
56. ;;/////////////////////////////////******以下是偏移多义线局部线段*****/////////////////////////////////////;;
    
57. ;| (plnff eplst) = 偏移多义线单段线段------------ok!!!------------------lxx.2004.7.29
    
58. 说明: 1.支持polyline及lwpolyline. 2.仅可偏移单段.
    
59. 参数: eplst = (entsel)返回的表.必须选中多义线!
    
60. 返回: (list eplst p2 (distance p p2) el)
    
61. 测试: (plnff (entsel))
    
62. |;
    
63. (defun plnff (eplst / e p1 p ent el el0  k seq plx plx2 p2 pt d)
    
64.   (setq e  (car eplst)
    
65. p1 (cadr eplst)
    
66. p  (vlax-curve-getclosestpointto e p1);;确保取点.
    
67.         ent(entget e))
    
68.   (if (= "LWPOLYLINE" (cdr(assoc 0 ent))) ;;转为旧式pl格式.
    
69.     (progn
    
70.       (vl-cmdf "_.convertpoly" "h" e "")
    
71.       (setq eL (entlast) el0 el ent (entget el) k T)
    
72.     )
    
73.     (setq el e el0 e)
    
74.   )
    
75.   (while (/= "SEQEND" (cdr(assoc 0 (setq seq (entget(setq el (entnext el))))))));;取seqend段.
    
76.   (setq ent (subst (cons 70 0) (assoc 70 ent) ent) ;;改为不封闭.
    
77.         plx (entget (car(nentselp p1)));;取点中段的实体表.
    
78.        plx2 (entget(entnext (cdr(assoc -1 plx)))));;下一个.
    
79.   (if (equal seq plx2)(setq plx2 (entget (entnext el0))));;如果是闭合段,下一个取pl线第一段.
    
80.   (mapcar 'entmakex(mapcar '(lambda (y) (vl-remove-if '(lambda(x)(member (car x) '(-1 5 -2))) y))(list ent plx plx2 seq)));;生成新的pl段.
    
81.   ;(if k (entdel el0));;删除多余实体.
    
82.   (setq pt (getpoint p "\n偏移方向及距离<输入数字or点取>:")
    
83. d  (distance p pt)
    
84. el (entlast))
    
85.   (vl-cmdf "_.offset" d (list el p) pt "")
    
86.   ;(while (/= 0 (getvar "cmdactive")) (vl-cmdf pause))
    
87.   (entdel el)
    
88.   (if (equal el (entlast)) nil (list eplst d (entlast)))
    
89. )
    
90. ;(setq eplst (entsel))
    
91. ;;;;;;;;;;;;;;
    
92. ;| plnff = 偏移多义线局部线段并连接. -ok!!!------------------lxx.2004.7.30
    
93. |;
    
94. (defun c:plf (/ ss a b lst dis)
    
95.   (setq ss (ssadd))
    
96.   (while (setq a (entsel))
    
97.     (if (setq b (plnff a))(setq lst (cons b lst)))
    
98.   )
    
99.   (mapcar '(lambda(x)(ssadd (last x) ss)) lst)
    
100.   (setq dis (apply 'max (mapcar '(lambda(x)(nth 1 x)) lst)))
     
101.   (vl-cmdf "_.Pedit" "m" ss "" "J" (* 2 dis) "")
     
102. )
     
103. 
     

<br /> ;; (plncp eplst)(c:plncp)(plnff eplst)(c:plnff) = 多义线局部线段拷贝，偏移程序v1.0-----------lxx.2004.7.30<br /> (vl-load-com)<br /> (alert "\n 多义线局部线段拷贝，偏移程序v1.0<br />         \n-------梦断江南.2004.7.30--------\n<br />         \n(plncp eplst) = 拷贝多义线单段线段<br />         \nc:plc = 拷贝多义线局部线段并连接<br />         \n(plnff eplst) = 偏移多义线单段线段<br />         \nc:plf = 偏移多义线局部线段并连接<br />        ")<br /> ;;/////////////////////////////////******拷贝多义线局部线段*****/////////////////////////////////////;;<br /> ;| (plncp eplst) = 拷贝多义线单段线段------------ok!!!------------------lxx.2004.7.29<br /> 说明: 1.支持polyline及lwpolyline. 2.仅可拷贝单段.<br /> 参数: eplst = (entsel)返回的表.必须选中多义线!<br /> 返回: (list eplst p2 (distance p p2) el)<br /> 测试: (plncp (entsel))<br /> |;<br /> (defun plncp (eplst / e p1 p ent el el0  k seq plx plx2 p2)<br />   (setq e  (car eplst)<br /> p1 (cadr eplst)<br /> p  (vlax-curve-getclosestpointto e p1);;确保取点.<br />         ent(entget e))<br />   (if (= "LWPOLYLINE" (cdr(assoc 0 ent))) ;;转为旧式pl格式.<br />     (progn<br />       (vl-cmdf "_.convertpoly" "h" e "")<br />       (setq eL (entlast) el0 el ent (entget el) k T)<br />     )<br />     (setq el e el0 e)<br />   )<br />   (while (/= "SEQEND" (cdr(assoc 0 (setq seq (entget(setq el (entnext el))))))));;取seqend段.<br />   (setq ent (subst (cons 70 0) (assoc 70 ent) ent) ;;改为不封闭.<br />         plx (entget (car(nentselp p1)));;取点中段的实体表.<br />        plx2 (entget(entnext (cdr(assoc -1 plx)))));;下一个.<br />   (if (equal seq plx2)(setq plx2 (entget (entnext el0))));;如果是闭合段,下一个取pl线第一段.<br />   (mapcar 'entmakex(mapcar '(lambda (y) (vl-remove-if '(lambda(x)(member (car x) '(-1 5 -2))) y))(list ent plx plx2 seq)));;生成新的pl段.<br />   ;(if k (entdel el0));;删除多余实体.<br />   (vl-cmdf "_.move" (setq el (entlast)) "" p pause)<br />   (if (equal (setq p2 (getvar "lastpoint")) p 1e-4)<br />     (progn (entdel el) nil)<br />     (list eplst p2 (distance p p2) el)<br />   )<br /> )<br /> ;;;;;;;;;;;;;;<br /> ;| plncp = 拷贝多义线局部线段并连接. -ok!!!------------------lxx.2004.7.30<br /> |;<br /> (defun c:plc (/ ss a b lst dis)<br />   (setq ss (ssadd))<br />   (while (setq a (entsel))<br />     (if (setq b (plncp a))(setq lst (cons b lst)))<br />   )<br />   (mapcar '(lambda(x)(ssadd (last x) ss)) lst)<br />   (setq dis (apply 'max (mapcar '(lambda(x)(nth 2 x)) lst))) <br />   (vl-cmdf "_.Pedit" "m" ss "" "J" (* 2 dis) "")<br /> )<br /> ;;/////////////////////////////////******以下是偏移多义线局部线段*****/////////////////////////////////////;;<br /> ;| (plnff eplst) = 偏移多义线单段线段------------ok!!!------------------lxx.2004.7.29<br /> 说明: 1.支持polyline及lwpolyline. 2.仅可偏移单段.<br /> 参数: eplst = (entsel)返回的表.必须选中多义线!<br /> 返回: (list eplst p2 (distance p p2) el)<br /> 测试: (plnff (entsel))<br /> |;<br /> (defun plnff (eplst / e p1 p ent el el0  k seq plx plx2 p2 pt d)<br />   (setq e  (car eplst)<br /> p1 (cadr eplst)<br /> p  (vlax-curve-getclosestpointto e p1);;确保取点.<br />         ent(entget e))<br />   (if (= "LWPOLYLINE" (cdr(assoc 0 ent))) ;;转为旧式pl格式.<br />     (progn<br />       (vl-cmdf "_.convertpoly" "h" e "")<br />       (setq eL (entlast) el0 el ent (entget el) k T)<br />     )<br />     (setq el e el0 e)<br />   )<br />   (while (/= "SEQEND" (cdr(assoc 0 (setq seq (entget(setq el (entnext el))))))));;取seqend段.<br />   (setq ent (subst (cons 70 0) (assoc 70 ent) ent) ;;改为不封闭.<br />         plx (entget (car(nentselp p1)));;取点中段的实体表.<br />        plx2 (entget(entnext (cdr(assoc -1 plx)))));;下一个.<br />   (if (equal seq plx2)(setq plx2 (entget (entnext el0))));;如果是闭合段,下一个取pl线第一段.<br />   (mapcar 'entmakex(mapcar '(lambda (y) (vl-remove-if '(lambda(x)(member (car x) '(-1 5 -2))) y))(list ent plx plx2 seq)));;生成新的pl段.<br />   ;(if k (entdel el0));;删除多余实体.<br />   (setq pt (getpoint p "\n偏移方向及距离<输入数字or点取>:")<br /> d  (distance p pt)<br /> el (entlast))<br />   (vl-cmdf "_.offset" d (list el p) pt "")<br />   ;(while (/= 0 (getvar "cmdactive")) (vl-cmdf pause))<br />   (entdel el)<br />   (if (equal el (entlast)) nil (list eplst d (entlast)))<br /> )<br /> ;(setq eplst (entsel))<br /> ;;;;;;;;;;;;;;<br /> ;| plnff = 偏移多义线局部线段并连接. -ok!!!------------------lxx.2004.7.30<br /> |;<br /> (defun c:plf (/ ss a b lst dis)<br />   (setq ss (ssadd))<br />   (while (setq a (entsel))<br />     (if (setq b (plnff a))(setq lst (cons b lst)))<br />   )<br />   (mapcar '(lambda(x)(ssadd (last x) ss)) lst)<br />   (setq dis (apply 'max (mapcar '(lambda(x)(nth 1 x)) lst))) <br />   (vl-cmdf "_.Pedit" "m" ss "" "J" (* 2 dis) "")<br /> )<br /> <br />

qjchen

回复 狂刀lxx 的帖子

谢谢 狂刀 大侠 一挥手 劈出了这么多把 锋利的刀，刀刀不平常

多年来一直在您的代码中学到许多睿智的编程思路。

追忆往事不堪回首明月中嫦娥.. 嘿嘿 好奇中

仲文玉

支持，收藏程序。这么晚了少喝咖啡，

461045462

收藏了
下来看看学习学习,慢慢领会
谢谢楼主的分享

lincctw_ccl

收藏慢慢看!!
謝謝 無私的分享

faith66

狂刀哥大源码大奉送，多谢了，努力学习lisp

cable2004

支持，收藏程序。

lohas1118

不错的程序，支持源码共享

longer1000

支持源码共享