多段线生成临时偏移线，然后阳角进行连线

weimeng555

如附件测试图纸思路，麻烦各位路过大佬出手。感激不尽

czb203

1. (defun c:tt (/ c:tt dist en en1 getplinepts lst-remove-dups p1 p2 p3 p4 pt ptlst ptlst1 xd_convex_hull xd_convex_hull_sort_an xdl-sort xj-getlwpt)
   
2. (vl-load-com)
   
3. (defun XDL-SORT(lst sortlst / n)
   
4.   (if (listp sortlst)
   
5.     (if (listp (car sortlst))
   
6.       (setq sortlst (reverse sortlst))
   
7.       (setq sortlst (list sortlst))
   
8.     )
   
9.     (setq sortlst (list (list nil sortlst)))
   
10.   )
    
11.   (foreach n sortlst
    
12.     (setq lst (vl-sort lst '(lambda (s1 s2)
    
13.          (apply (cadr n) (list (if (car n) (nth  (car n) s1)s1)
    
14.           (if (car n) (nth  (car n) s2)s2))))))
    
15.     )
    
16.   )
    
17. (defun lst-remove-dups(pts fuzz / pt x)
    
18. (cond ((=(length pts)1) pts)
    
19.        (t(setq pt(car pts))
    
20.          (cons pt(vl-remove-if '(lambda(x)(equal pt x fuzz))
    
21.                (lst-remove-dups(cdr pts)fuzz))
    
22.          )
    
23.      ))
    
24. )
    
25. (defun XD_convex_hull_sort_an(pt an ls / re)
    
26.   (setq re (mapcar '(lambda(x) (list (rem (+ (* 2 pi)(- (angle pt x) an))(* 2 pi))(distance pt x) x)) ls))
    
27.     (setq re (XDL-SORT re '((0 <)(1 >))))
    
28.   (last(car re))
    
29. )
    
30. (defun XD_convex_hull (lst / re tblst AN BG RESULT)
    
31.   (setq lst (lst-remove-dups lst 0))
    
32.   (setq lst (XDL-SORT lst '((0 <)(1 <))));;按XY增排序
    
33.   (setq bg (car lst)
    
34. an (/ pi -2)
    
35.   )
    
36.   (setq tblst (list bg))
    
37.   (while
    
38.     (and (> (length lst) 2)
    
39.   (not (and (> (length tblst) 1) (= (car tblst) (last tblst)))
    
40.   )
    
41.     )
    
42.      (setq result (XD_convex_hull_sort_an (car tblst) an (vl-remove (car tblst) lst)))
    
43.      (setq an (angle (car tblst) result))
    
44.      (setq tblst (cons result tblst))
    
45.   )
    
46.   tblst
    
47. )
    
48. (defun GetPlinePts( name / ents pts)
    
49.   (setq ents (entget name))
    
50.   (while (setq ents (member (assoc 10 ents) ents))
    
51.     (setq pts (append pts (list (cdar ents))))
    
52.     (setq ents (cdr ents))
    
53.   )
    
54.   pts
    
55. )
    
56.   (defun xj-getlwpt (enn / ent lst)
    
57.     (setq ent (entget enn))
    
58.     (setq lst (list))
    
59.     (foreach x ent (if (= (car x) 10) (setq lst (cons (cdr x) lst))))
    
60.     lst
    
61.   )
    
62.   (setq dist (getdist
    
63.                (strcat
    
64.                  "\n输入偏移距离:<"
    
65.                  (rtos (getvar "OFFSETDIST"))
    
66.                  ">"
    
67.                )
    
68.              )
    
69.   )
    
70.   (if (null dist)
    
71.     (setq dist (getvar "offsetdist"))
    
72.     (setvar "offsetdist" dist)
    
73.   )
    
74.   (setq en    (car (entsel "\n请选择线:"))
    
75.         ptlst (xj-getlwpt en)
    
76.                 ptlst (XD_convex_hull ptlst)
    
77.   )
    
78.   (command "offset" dist en pause "")
    
79.   (setq en1    (entlast)
    
80.         ptlst1 (xj-getlwpt en1)
    
81.                     ptlst1 (XD_convex_hull ptlst1)
    
82.   )
    
83.   (if (> (length ptlst) 2)
    
84.     (progn
    
85.       (setq ptlst  (cdr (reverse (cdr (reverse ptlst))))
    
86.             ptlst1 (cdr (reverse (cdr (reverse ptlst1))))
    
87.       )
    
88.       (mapcar '(lambda (x y) (entmake (list '(0 . "LINE") (cons 10 x) (cons 11 y)))) ptlst ptlst1)
    
89.     )
    
90.   )
    
91.   (entdel en1)
    
92.   (princ)
    
93. )

(defun c:tt (/ c:tt dist en en1 getplinepts lst-remove-dups p1 p2 p3 p4 pt ptlst ptlst1 xd_convex_hull xd_convex_hull_sort_an xdl-sort xj-getlwpt)<br /> (vl-load-com)<br /> (defun XDL-SORT(lst sortlst / n)<br />   (if (listp sortlst)<br />     (if (listp (car sortlst))<br />       (setq sortlst (reverse sortlst))<br />       (setq sortlst (list sortlst))<br />     )<br />     (setq sortlst (list (list nil sortlst)))<br />   )<br />   (foreach n sortlst<br />     (setq lst (vl-sort lst '(lambda (s1 s2)<br />          (apply (cadr n) (list (if (car n) (nth  (car n) s1)s1)<br />           (if (car n) (nth  (car n) s2)s2))))))<br />     )<br />   )<br /> (defun lst-remove-dups(pts fuzz / pt x)<br /> (cond ((=(length pts)1) pts)<br />        (t(setq pt(car pts))<br />          (cons pt(vl-remove-if '(lambda(x)(equal pt x fuzz))<br />                (lst-remove-dups(cdr pts)fuzz))<br />          )<br />      ))<br /> )<br /> (defun XD_convex_hull_sort_an(pt an ls / re)<br />   (setq re (mapcar '(lambda(x) (list (rem (+ (* 2 pi)(- (angle pt x) an))(* 2 pi))(distance pt x) x)) ls))<br />     (setq re (XDL-SORT re '((0 <)(1 >))))<br />   (last(car re))<br /> )<br /> (defun XD_convex_hull (lst / re tblst AN BG RESULT)<br />   (setq lst (lst-remove-dups lst 0))<br />   (setq lst (XDL-SORT lst '((0 <)(1 <))));;按XY增排序<br />   (setq bg (car lst)<br /> an (/ pi -2)<br />   )<br />   (setq tblst (list bg))<br />   (while<br />     (and (> (length lst) 2)<br />   (not (and (> (length tblst) 1) (= (car tblst) (last tblst)))<br />   )<br />     )<br />      (setq result (XD_convex_hull_sort_an (car tblst) an (vl-remove (car tblst) lst)))<br />      (setq an (angle (car tblst) result))<br />      (setq tblst (cons result tblst))<br />   )<br />   tblst<br /> )<br /> (defun GetPlinePts( name / ents pts)<br />   (setq ents (entget name))<br />   (while (setq ents (member (assoc 10 ents) ents))<br />     (setq pts (append pts (list (cdar ents))))<br />     (setq ents (cdr ents))<br />   )<br />   pts<br /> )<br />   (defun xj-getlwpt (enn / ent lst)<br />     (setq ent (entget enn))<br />     (setq lst (list))<br />     (foreach x ent (if (= (car x) 10) (setq lst (cons (cdr x) lst))))<br />     lst<br />   )<br />   (setq dist (getdist<br />                (strcat<br />                  "\n输入偏移距离:<"<br />                  (rtos (getvar "OFFSETDIST"))<br />                  ">"<br />                )<br />              )<br />   )<br />   (if (null dist)<br />     (setq dist (getvar "offsetdist"))<br />     (setvar "offsetdist" dist)<br />   )<br />   (setq en    (car (entsel "\n请选择线:"))<br />         ptlst (xj-getlwpt en)<br />                 ptlst (XD_convex_hull ptlst)<br />   )<br />   (command "offset" dist en pause "")<br />   (setq en1    (entlast)<br />         ptlst1 (xj-getlwpt en1)<br />                     ptlst1 (XD_convex_hull ptlst1)<br />   )<br />   (if (> (length ptlst) 2)<br />     (progn<br />       (setq ptlst  (cdr (reverse (cdr (reverse ptlst))))<br />             ptlst1 (cdr (reverse (cdr (reverse ptlst1))))<br />       )<br />       (mapcar '(lambda (x y) (entmake (list '(0 . "LINE") (cons 10 x) (cons 11 y)))) ptlst ptlst1)<br />     )<br />   )<br />   (entdel en1)<br />   (princ)<br /> )

bai2000

好像第一个点间没连线吧？

bskidtf

这个比较简单，我写过ARX版的

weimeng555

bai2000 发表于 2024-5-13 08:22
好像第一个点间没连线吧？

这里测试图，确实是漏掉了