API应用 连接有间隙的等高线

st788796

1. (defun c:tt (/ ss len fuzz el s)
   
2.   (if (and (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "DGX"))))
   
3.     (> (sslength ss) 1) ;_加个判断，一般不会出现
   
4.     (setq len (getdist "\n输入最小阀值: "))
   
5.     (setq fuzz (getdist "\n输入最小间隙: "))
   
6.       )
   
7.     (progn
   
8.       (XD::Begin)
   
9.       (setq el (mapcar '(lambda (x)
   
10.      (list (xdrx_getpropertyvalue x "Elevation") x)
    
11.    )
    
12.          (xdrx_pickset->ents ss)
    
13.         )
    
14.      el (mapcar 'cdr
    
15.          (vl-remove-if
    
16.     '(lambda (x) (= (length x) 1))
    
17.     (XD::List:GroupByIndex el 0)
    
18.          )
    
19.         )
    
20.       )
    
21.       (setq
    
22. el (mapcar
    
23.       '(lambda (x / xx a b c asp aep ep pts p)
    
24.   (setq xx x)
    
25.   (while xx
    
26.     (setq a   (car xx)
    
27.    b   xx
    
28.    asp (xdrx_curve_getstartpoint a)
    
29.    aep (xdrx_curve_getendpoint a)
    
30.    ep  (fix (xdrx_curve_getendparam a))
    
31.     )
    
32.     (while (setq b (cdr b))
    
33.       (setq c   (car b)
    
34.      pts (list (xdrx_curve_getstartpoint c)
    
35.         (xdrx_curve_getendpoint c)
    
36.          )
    
37.       )
    
38.       (if (and (not (vl-position asp pts))
    
39.         (setq
    
40.           p (vl-remove-if-not
    
41.        '(lambda (d) (equal asp d fuzz))
    
42.        pts
    
43.      )
    
44.         )
    
45.    )
    
46.         (xdrx_polyline_setpointat a 0 (car p))
    
47.       )
    
48.       (if (and (not (vl-position aep pts))
    
49.         (setq
    
50.           p (vl-remove-if-not
    
51.        '(lambda (d) (equal aep d fuzz))
    
52.        pts
    
53.      )
    
54.         )
    
55.    )
    
56.         (xdrx_polyline_setpointat a ep (car p))
    
57.       )
    
58.     )
    
59.     (setq xx (cdr xx))
    
60.   )
    
61.   x
    
62.        )
    
63.       el
    
64.     )
    
65.       )
    
66.       (foreach x el
    
67. (setq s (XD::Entity->Pickset x))
    
68. ;;(command-s ".pedit" "m" s "" "j" fuzz "");_高版本用这个更高效
    
69. (vl-cmdf ".pedit" "m" s "" "j" fuzz "")
    
70.       )
    
71.     )
    
72.     (XD::End)
    
73.   )
    
74.   (princ)
    
75. )

(defun c:tt (/ ss len fuzz el s)<br />   (if (and (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "DGX"))))<br />     (> (sslength ss) 1) ;_加个判断，一般不会出现<br />     (setq len (getdist "\n输入最小阀值: "))<br />     (setq fuzz (getdist "\n输入最小间隙: "))<br />       )<br />     (progn<br />       (XD::Begin)<br />       (setq el (mapcar '(lambda (x)<br />      (list (xdrx_getpropertyvalue x "Elevation") x)<br />    )<br />          (xdrx_pickset->ents ss)<br />         )<br />      el (mapcar 'cdr<br />          (vl-remove-if<br />     '(lambda (x) (= (length x) 1))<br />     (XD::List:GroupByIndex el 0)<br />          )<br />         )<br />       )<br />       (setq<br /> el (mapcar<br />       '(lambda (x / xx a b c asp aep ep pts p)<br />   (setq xx x)<br />   (while xx<br />     (setq a   (car xx)<br />    b   xx<br />    asp (xdrx_curve_getstartpoint a)<br />    aep (xdrx_curve_getendpoint a)<br />    ep  (fix (xdrx_curve_getendparam a))<br />     )<br />     (while (setq b (cdr b))<br />       (setq c   (car b)<br />      pts (list (xdrx_curve_getstartpoint c)<br />         (xdrx_curve_getendpoint c)<br />          )<br />       )<br />       (if (and (not (vl-position asp pts))<br />         (setq<br />           p (vl-remove-if-not<br />        '(lambda (d) (equal asp d fuzz))<br />        pts<br />      )<br />         )<br />    )<br />         (xdrx_polyline_setpointat a 0 (car p))<br />       )<br />       (if (and (not (vl-position aep pts))<br />         (setq<br />           p (vl-remove-if-not<br />        '(lambda (d) (equal aep d fuzz))<br />        pts<br />      )<br />         )<br />    )<br />         (xdrx_polyline_setpointat a ep (car p))<br />       )<br />     )<br />     (setq xx (cdr xx))<br />   )<br />   x<br />        )<br />       el<br />     )<br />       )<br />       (foreach x el<br /> (setq s (XD::Entity->Pickset x))<br /> ;;(command-s ".pedit" "m" s "" "j" fuzz "");_高版本用这个更高效<br /> (vl-cmdf ".pedit" "m" s "" "j" fuzz "")<br />       )<br />     )<br />     (XD::End)<br />   )<br />   (princ)<br /> )

newer

哇，能给上个演示吗？ 多段线如果圆滑后也能用不？

st788796

lisp分坛有了，楼主贴了纯lisp，更正下，非本人

coverne

连接有间隙的等高线 去分坛看看效果

coverne

找不到源头，也不会用，哎

wxn80

这个真的好厉害！鼓掌！楼主有原帖的地址吗？