一些函数，别人的

树櫴希德

2. (DEFUN C:TEST1(/ ENT LST SS)
   
3.   (SETQ ENT(ENTGET(CAR(ENTSEL))))
   
4.   (SETQ LST(MAPCAR'CDR(VL-REMOVE-IF-NOT'(LAMBDA(X)(= 10 (CAR X)))ENT)))
   
5.   (SETQ SS(SSGET "WP" LST))
   
6.   (SSSETFIRST nil SS)
   
7.   )
   
8. 
   
9. (defun plinexy(e)
   
10.   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
    
11.   )
    
12. 
    
13. (setq pzx (ssget "wp" (plinexy (car (entsel))) '((0 . "polyline") (8 . "sjw") ) ));选择多段线内实体
    
14. 
    
15. (sssetfirst nil pzx)
    
16. 
    
17. 
    
18. (vla-ScaleEntity (vlax-ename->vla-object ss_name) (vla-get-InsertionPoint (vlax-ename->vla-object ss_name)) beishu) ;块原地缩小
    
19.      ;(setq ss (ssdel ss_name ss))
    
20. 
    
21. 
    
22. (entmod (append (vl-remove-if '(lambda(x) (member (car x) '(41 42 43))) pzx121)  (list '(41 . 0.02) '(42 . 0.02) '(43 . 0.02) )));替换多项

(DEFUN C:TEST1(/ ENT LST SS)<br />   (SETQ ENT(ENTGET(CAR(ENTSEL))))<br />   (SETQ LST(MAPCAR'CDR(VL-REMOVE-IF-NOT'(LAMBDA(X)(= 10 (CAR X)))ENT)))<br />   (SETQ SS(SSGET "WP" LST))<br />   (SSSETFIRST nil SS)<br />   )<br /> <br /> (defun plinexy(e)<br />   (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))<br />   )<br /> <br /> (setq pzx (ssget "wp" (plinexy (car (entsel))) '((0 . "polyline") (8 . "sjw") ) ));选择多段线内实体<br /> <br /> (sssetfirst nil pzx)<br /> <br /> <br /> (vla-ScaleEntity (vlax-ename->vla-object ss_name) (vla-get-InsertionPoint (vlax-ename->vla-object ss_name)) beishu) ;块原地缩小<br />      ;(setq ss (ssdel ss_name ss))<br /> <br /> <br /> (entmod (append (vl-remove-if '(lambda(x) (member (car x) '(41 42 43))) pzx121)  (list '(41 . 0.02) '(42 . 0.02) '(43 . 0.02) )));替换多项

树櫴希德

2. (defun xyp-SS2List (ss / i s1 lst)
   
3.   (cond        ((= (type ss) 'PICKSET)
   
4.          (setq lst (reverse (ssnamex ss))
   
5.                lst (vl-remove-if-not
   
6.                      '(lambda (x) (equal (type (cadr x)) 'ENAME))
   
7.                      lst
   
8.                    )
   
9.                lst (mapcar 'cadr lst)
   
10.          )
    
11.         )
    
12.         ((= (type ss) 'ENAME) (setq lst (list ss)))
    
13.         ((= (type ss) 'LIST)
    
14.          (foreach s1 ss (setq lst (append (xyp-SS2List s1) lst)))
    
15.         )
    
16.   )
    
17. )
    
18. 
    
19. 
    
20. 
    
21. ;; tt(删除重复直线)
    
22. ;; 重复定义：起点、终点、图层
    
23. (defun c:tt ()
    
24.   (setq        ss   (ssget '((0 . "line")))
    
25.         lst  (xyp-ss2list ss)
    
26.         lst  (mapcar '(lambda (x)
    
27.                         (list
    
28.                           (vl-remove-if-not
    
29.                             '(lambda (y) (member (car y) '(10 11 8)))
    
30.                             (entget x)
    
31.                           )
    
32.                           x
    
33.                         )
    
34.                       )
    
35.                      lst
    
36.              )
    
37.         lst1 '()
    
38.   )
    
39.   (foreach a lst
    
40.     (setq b (car a))
    
41.     (if        (not (member b lst1))
    
42.       (setq lst1 (cons b lst1))
    
43.       (entdel (cadr a))
    
44.     )
    
45.   )
    
46.   (princ)
    
47. );;;院长的

(defun xyp-SS2List (ss / i s1 lst)<br />   (cond        ((= (type ss) 'PICKSET)<br />          (setq lst (reverse (ssnamex ss))<br />                lst (vl-remove-if-not<br />                      '(lambda (x) (equal (type (cadr x)) 'ENAME))<br />                      lst<br />                    )<br />                lst (mapcar 'cadr lst)<br />          )<br />         )<br />         ((= (type ss) 'ENAME) (setq lst (list ss)))<br />         ((= (type ss) 'LIST)<br />          (foreach s1 ss (setq lst (append (xyp-SS2List s1) lst)))<br />         )<br />   )<br /> )<br /> <br /> <br /> <br /> ;; tt(删除重复直线)<br /> ;; 重复定义：起点、终点、图层<br /> (defun c:tt ()<br />   (setq        ss   (ssget '((0 . "line")))<br />         lst  (xyp-ss2list ss)<br />         lst  (mapcar '(lambda (x)<br />                         (list<br />                           (vl-remove-if-not<br />                             '(lambda (y) (member (car y) '(10 11 8)))<br />                             (entget x)<br />                           )<br />                           x<br />                         )<br />                       )<br />                      lst<br />              )<br />         lst1 '()<br />   )<br />   (foreach a lst<br />     (setq b (car a))<br />     (if        (not (member b lst1))<br />       (setq lst1 (cons b lst1))<br />       (entdel (cadr a))<br />     )<br />   )<br />   (princ)<br /> );;;院长的

树櫴希德

2. ..论坛里面没有吗
   
3. ;释放所有obj对象
   
4. (defun cx-ReleaseObject ( obj )
   
5.         (and obj (eq 'VLA-OBJECT (type obj)) (not (vlax-object-released-p obj))
   
6.                 (not
   
7.                         (vl-catch-all-error-p
   
8.                                 (vl-catch-all-apply 'vlax-release-object (list obj))
   
9.                         )
   
10.                 )
    
11.         )
    
12. )
    

..论坛里面没有吗<br /> ;释放所有obj对象<br /> (defun cx-ReleaseObject ( obj )<br />         (and obj (eq 'VLA-OBJECT (type obj)) (not (vlax-object-released-p obj))<br />                 (not<br />                         (vl-catch-all-error-p<br />                                 (vl-catch-all-apply 'vlax-release-object (list obj))<br />                         )<br />                 )<br />         )<br /> )<br />

陈进佳

hao a ,人才辈出 。

知行ooo李肖坪

谢谢………………

树櫴希德

1. (defun everyposition(lst / n l2);;;lst表内各元素在表内所有出现位置，可进一步用于去重、频数统计等
   
2.   (setq n(length lst)m -1)
   
3.   (vl-every(function(lambda(x / i l l1 )
   
4.           (or(assoc x l2)
   
5.        (progn
   
6.          (setq l lst)
   
7.          (while(setq i(vl-position x l))
   
8.            (setq l1(cons(+ i n(-(length l)))l1)
   
9.            l(nthcdr(1+ i)l)))
   
10.          (setq l2(cons(cons x(reverse l1))l2))))))lst)
    
11.   (reverse l2))
    
12. EVERYPOSITION
    
13. _$ (EVERYPOSITION'(a b e f c d a h c f b d h i))
    
14. ((A 0 6) (B 1 10) (E 2) (F 3 9) (C 4 8) (D 5 11) (H 7 12) (I 13))

(defun everyposition(lst / n l2);;;lst表内各元素在表内所有出现位置，可进一步用于去重、频数统计等<br />   (setq n(length lst)m -1)<br />   (vl-every(function(lambda(x / i l l1 )<br />           (or(assoc x l2)<br />        (progn<br />          (setq l lst)<br />          (while(setq i(vl-position x l))<br />            (setq l1(cons(+ i n(-(length l)))l1)<br />            l(nthcdr(1+ i)l)))<br />          (setq l2(cons(cons x(reverse l1))l2))))))lst)<br />   (reverse l2))<br /> EVERYPOSITION<br /> _$ (EVERYPOSITION'(a b e f c d a h c f b d h i))<br /> ((A 0 6) (B 1 10) (E 2) (F 3 9) (C 4 8) (D 5 11) (H 7 12) (I 13))

树櫴希德

1. (defun plxyz(e fun / pt p n);多段线节点三维坐标，连续重合点只取一个，根据fuz阀值过滤接近点
   
2.   (or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))
   
3.   (cond((=(setq n(vlax-get-property e'objectname))"AcDbLine")
   
4.         (list(vlax-curve-getstartpoint e)(vlax-curve-getendpoint e)))
   
5.        ((WCMATCH n"*Polyline")
   
6.         (repeat(setq n(fix(+(vlax-curve-getendparam e)(if(=(vlax-get-property e'Closed):vlax-true)0 1))))
   
7.     (or(equal(setq n(1- n)p(vlax-curve-getpointatparam e n))(car pt)fun)
   
8.        (setq pt(cons p pt))))
   
9.         (if(equal(car pt)(last pt)fun)
   
10.     (butlast pt)pt))))
    
11. (defun nodekill(e fuz / area pt p1 p2 mj p a b c i l n 1-N Ntriangle);;;控制面积变化率精简多段线节点
    
12.   (defun 1-N(fun i n / a);;;第i点的前一个(fun -)或后一个(fun +)有效点
    
13.     (while(not(nth(setq i(cond((<= 0(setq a(fun i 1))n)a)((> a n)0)((MINUSP A)N)))pt)))i)
    
14.   (defun Ntriangle(i n / a b c d p1 p2 p3 p4 area);去掉第i点，重组相邻三角形数据
    
15.     (setq b(1-n - i n)a(1-n - b n)
    
16.     c(1-n + i n)d(1-n + c n)
    
17.     p1(nth a pt)p2(nth b pt)p3(nth c pt)p4(nth d pt)
    
18.     pt(subst nil(nth i pt)pt))
    
19.     (list(List b a c(setq area(2area(List p2 p1 p3)))(/(abs area)(distance p1 p3)))
    
20.    (List c b d(setq area(2area(List p3 p2 p4)))(/(abs area)(distance p2 p4)))))
    
21.   (setq pt(plxyz e 1e-8)area(vlax-curve-getarea e)darea(* area fuz 2)mj 0 n(1-(length pt))
    
22.   p1(vl-sort(mapcar(function(lambda(x / i j k a b c)
    
23.           (setq i(vl-position x pt)j(1-N - i n)k(1-N + i n)
    
24.           b(nth j pt)c(nth k pt)a(2area(List x b c)))
    
25.           (List i j k a(/(abs a)(distance b c)))))pt)
    
26.       (function(lambda(x y)(<(last x)(last y))))))
    
27.   (while(equal mj 0 darea)
    
28.     (if(equal(setq a(car p1)mj(+ mj(cadddr a)))0 darea)
    
29.       (setq b(assoc(cadr a)p1)p1(vl-remove a p1)p1(vl-remove b p1)
    
30.       p1(vl-sort(append(Ntriangle(car a)n)(vl-remove(assoc(caddr a)p1)p1))(function(lambda(x y)(<(last x)(last y))))))))
    
31.   (vl-remove 'nil pt))

(defun plxyz(e fun / pt p n);多段线节点三维坐标，连续重合点只取一个，根据fuz阀值过滤接近点<br />   (or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))<br />   (cond((=(setq n(vlax-get-property e'objectname))"AcDbLine")<br />         (list(vlax-curve-getstartpoint e)(vlax-curve-getendpoint e)))<br />        ((WCMATCH n"*Polyline")<br />         (repeat(setq n(fix(+(vlax-curve-getendparam e)(if(=(vlax-get-property e'Closed):vlax-true)0 1))))<br />     (or(equal(setq n(1- n)p(vlax-curve-getpointatparam e n))(car pt)fun)<br />        (setq pt(cons p pt))))<br />         (if(equal(car pt)(last pt)fun)<br />     (butlast pt)pt))))<br /> (defun nodekill(e fuz / area pt p1 p2 mj p a b c i l n 1-N Ntriangle);;;控制面积变化率精简多段线节点<br />   (defun 1-N(fun i n / a);;;第i点的前一个(fun -)或后一个(fun +)有效点<br />     (while(not(nth(setq i(cond((<= 0(setq a(fun i 1))n)a)((> a n)0)((MINUSP A)N)))pt)))i)<br />   (defun Ntriangle(i n / a b c d p1 p2 p3 p4 area);去掉第i点，重组相邻三角形数据<br />     (setq b(1-n - i n)a(1-n - b n)<br />     c(1-n + i n)d(1-n + c n)<br />     p1(nth a pt)p2(nth b pt)p3(nth c pt)p4(nth d pt)<br />     pt(subst nil(nth i pt)pt))<br />     (list(List b a c(setq area(2area(List p2 p1 p3)))(/(abs area)(distance p1 p3)))<br />    (List c b d(setq area(2area(List p3 p2 p4)))(/(abs area)(distance p2 p4)))))<br />   (setq pt(plxyz e 1e-8)area(vlax-curve-getarea e)darea(* area fuz 2)mj 0 n(1-(length pt))<br />   p1(vl-sort(mapcar(function(lambda(x / i j k a b c)<br />           (setq i(vl-position x pt)j(1-N - i n)k(1-N + i n)<br />           b(nth j pt)c(nth k pt)a(2area(List x b c)))<br />           (List i j k a(/(abs a)(distance b c)))))pt)<br />       (function(lambda(x y)(<(last x)(last y))))))<br />   (while(equal mj 0 darea)<br />     (if(equal(setq a(car p1)mj(+ mj(cadddr a)))0 darea)<br />       (setq b(assoc(cadr a)p1)p1(vl-remove a p1)p1(vl-remove b p1)<br />       p1(vl-sort(append(Ntriangle(car a)n)(vl-remove(assoc(caddr a)p1)p1))(function(lambda(x y)(<(last x)(last y))))))))<br />   (vl-remove 'nil pt))

1. (defun 2area(pt)(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt)))

(defun 2area(pt)(apply'+(mapcar'(lambda(x y)(-(*(car x)(cadr y))(*(car y)(cadr x))))(cons(last pt)pt)pt)))

树櫴希德

1. (defun plputCoordinates(e pt / n arr p1 p2);三维坐标更新多段线
   
2.   (or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))
   
3.   (setq n(if(WCMATCH(vlax-get-property e'objectname)"AcDb#dPolyline")3 2)
   
4.   p1(car pt)p2(cadr pt)
   
5.   pt(apply'append(if(= n 2)(mapcar(function(lambda(x)(list(car x)(cadr x))))pt)pt))
   
6.   arr(vlax-make-safearray vlax-vbDouble(cons 0(1-(length pt)))))
   
7.   (vlax-safearray-fill arr pt)
   
8.   (vlax-put-property e'Coordinates arr)
   
9.   )
   
10. 
    
11. (defun plxyz(e fun / pt p n);多段线节点三维坐标，连续重合点只取一个，根据fuz阀值过滤接近点
    
12.   (or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))
    
13.   (cond((=(setq n(vlax-get-property e'objectname))"AcDbLine")
    
14.         (list(vlax-curve-getstartpoint e)(vlax-curve-getendpoint e)))
    
15.        ((WCMATCH n"*Polyline")
    
16.         (repeat(setq n(fix(+(vlax-curve-getendparam e)(if(=(vlax-get-property e'Closed):vlax-true)0 1))))
    
17.     (or(equal(setq n(1- n)p(vlax-curve-getpointatparam e n))(car pt)fun)
    
18.        (setq pt(cons p pt))))
    
19.         (if(equal(car pt)(last pt)fun)
    
20.     (butlast pt)pt))))
    
21. 
    
22.   (setq e (car (entsel "\n选择多段线:")))   (plputCoordinates e (plxyz e 0.001 ))

(defun plputCoordinates(e pt / n arr p1 p2);三维坐标更新多段线<br />   (or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))<br />   (setq n(if(WCMATCH(vlax-get-property e'objectname)"AcDb#dPolyline")3 2)<br />   p1(car pt)p2(cadr pt)<br />   pt(apply'append(if(= n 2)(mapcar(function(lambda(x)(list(car x)(cadr x))))pt)pt))<br />   arr(vlax-make-safearray vlax-vbDouble(cons 0(1-(length pt)))))<br />   (vlax-safearray-fill arr pt)<br />   (vlax-put-property e'Coordinates arr)<br />   )<br /> <br /> (defun plxyz(e fun / pt p n);多段线节点三维坐标，连续重合点只取一个，根据fuz阀值过滤接近点<br />   (or(=(type e)'vla-object)(setq e(vlax-ename->vla-object e)))<br />   (cond((=(setq n(vlax-get-property e'objectname))"AcDbLine")<br />         (list(vlax-curve-getstartpoint e)(vlax-curve-getendpoint e)))<br />        ((WCMATCH n"*Polyline")<br />         (repeat(setq n(fix(+(vlax-curve-getendparam e)(if(=(vlax-get-property e'Closed):vlax-true)0 1))))<br />     (or(equal(setq n(1- n)p(vlax-curve-getpointatparam e n))(car pt)fun)<br />        (setq pt(cons p pt))))<br />         (if(equal(car pt)(last pt)fun)<br />     (butlast pt)pt))))<br /> <br />   (setq e (car (entsel "\n选择多段线:")))   (plputCoordinates e (plxyz e 0.001 ))