收藏73哥程序，链式选择相交圆

树櫴希德

收藏73哥程序，链式选择相交圆

1. (vl-load-com)
   
2. (defun xBox(s / p a b);;选择集，图元(对象)表，图元包容盒
   
3.   (vl-every'(lambda(x)
   
4.         (vla-getboundingbox(if(=(type x)'ename)(vlax-ename->vla-object x)x)'a'b)
   
5.         (setq p(append(mapcar'vlax-safearray->list(list a b))p)))
   
6.      (if(/=(type s)'pickset)(if(listp s)s(list s))
   
7.       (mapcar'cadr(member(nth(1-(sslength s))(setq s(ssnamex s)))(reverse s)))))
   
8.   (mapcar'(lambda(a)(apply'mapcar(cons a p)))'(min max)))
   
9. (defun rect(p)(list(List(caar p)(cadadr p))(cadr p)(list(caadr p)(cadar p))(car p)))
   
10. (defun cirx(c1 c2 / e1 e2 d r1 r2);;两
    
11.   (and(=(type c1)(type c2)'ename)
    
12.       (setq e1(entget c1)e2(entget c2))
    
13.       (equal(assoc 0 e1)'(0 . "CIRCLE"))
    
14.       (equal(assoc 0 e2)'(0 . "CIRCLE"))
    
15.       (setq d(distance(mapcar'+'(0 0)(cdr(assoc 10 e1)))(cdr(assoc 10 e2)))
    
16.       r1(cdr(assoc 40 e1))r2(cdr(assoc 40 e2)))
    
17.       (<(abs(- r1 r2))d(+ r1 r2))))
    
18. (defun e2s(es / s)
    
19.   (and(setq es(vl-remove-if-not(function(lambda(x)(equal(type x)'ename)))es))
    
20.       (setq s(ssadd))(vl-every(function(lambda(x)(ssadd x s)))es))s)
    
21. (defun s2e(s / n lst)(if(=(type s)'pickset)(repeat(setq n(sslength s))(setq n(1- n)lst(cons(ssname s n)lst)))))
    
22. (defun ssgetcross(/ e n lst)
    
23.   (if(setq e(ssget":E:S"'((0 . "circle"))))
    
24.     (progn
    
25.       (setq lst(list(ssname e 0))n 0)
    
26.       (while(< n(setq n(length lst)))
    
27.   (vl-some'(lambda(x)(or(vl-position x lst)
    
28.             (if(vl-some'(lambda(a)(cirx x a))lst)
    
29.         (setq lst(cons x lst))))nil)
    
30.     (s2e(ssget"cp"(rect(xbox lst))'((0 . "circle"))))))
    
31.       lst)))
    
32. (sssetfirst nil(e2s(ssgetcross)))

(vl-load-com)<br /> (defun xBox(s / p a b);;选择集，图元(对象)表，图元包容盒<br />   (vl-every'(lambda(x)<br />         (vla-getboundingbox(if(=(type x)'ename)(vlax-ename->vla-object x)x)'a'b)<br />         (setq p(append(mapcar'vlax-safearray->list(list a b))p)))<br />      (if(/=(type s)'pickset)(if(listp s)s(list s))<br />       (mapcar'cadr(member(nth(1-(sslength s))(setq s(ssnamex s)))(reverse s)))))<br />   (mapcar'(lambda(a)(apply'mapcar(cons a p)))'(min max)))<br /> (defun rect(p)(list(List(caar p)(cadadr p))(cadr p)(list(caadr p)(cadar p))(car p)))<br /> (defun cirx(c1 c2 / e1 e2 d r1 r2);;两<br />   (and(=(type c1)(type c2)'ename)<br />       (setq e1(entget c1)e2(entget c2))<br />       (equal(assoc 0 e1)'(0 . "CIRCLE"))<br />       (equal(assoc 0 e2)'(0 . "CIRCLE"))<br />       (setq d(distance(mapcar'+'(0 0)(cdr(assoc 10 e1)))(cdr(assoc 10 e2)))<br />       r1(cdr(assoc 40 e1))r2(cdr(assoc 40 e2)))<br />       (<(abs(- r1 r2))d(+ r1 r2))))<br /> (defun e2s(es / s)<br />   (and(setq es(vl-remove-if-not(function(lambda(x)(equal(type x)'ename)))es))<br />       (setq s(ssadd))(vl-every(function(lambda(x)(ssadd x s)))es))s)<br /> (defun s2e(s / n lst)(if(=(type s)'pickset)(repeat(setq n(sslength s))(setq n(1- n)lst(cons(ssname s n)lst)))))<br /> (defun ssgetcross(/ e n lst)<br />   (if(setq e(ssget":E:S"'((0 . "circle"))))<br />     (progn<br />       (setq lst(list(ssname e 0))n 0)<br />       (while(< n(setq n(length lst)))<br />   (vl-some'(lambda(x)(or(vl-position x lst)<br />             (if(vl-some'(lambda(a)(cirx x a))lst)<br />         (setq lst(cons x lst))))nil)<br />     (s2e(ssget"cp"(rect(xbox lst))'((0 . "circle"))))))<br />       lst)))<br /> (sssetfirst nil(e2s(ssgetcross)))

嘒彼小星

顶，聊天群看到的，也收藏了 。厉害

lxl217114

谢谢分享，收藏+1

树櫴希德

73哥 代码  带容差链式选择园

1. (defun ssgetcross(e fuz / s lst cirx)
   
2.   (defun cirx(e1 e2 / d r1 r2)
   
3.     (setq e1(entget e1)e2(entget e2)
   
4.     d(distance(mapcar'+'(0 0)(cdr(assoc 10 e1)))(cdr(assoc 10 e2)))
   
5.     r1(cdr(assoc 40 e1))r2(cdr(assoc 40 e2)))
   
6.     (<(abs(- r1 r2 fuz))d(+ r1 r2 fuz)))
   
7.   (if(and(=(type e)'ENAME)(vl-position'(0 . "CIRCLE")(entget e))(numberp fuz))
   
8.     (progn
   
9.       (setq lst(list e)s(vl-remove(car lst)(mapcar'cadr(ssnamex(ssget"x"'((0 . "circle"))))))n 0)
   
10.       (while(< n(setq n(length lst)))
    
11.   (vl-some'(lambda(x)
    
12.        (if(vl-some'(lambda(a)(cirx x a))lst)
    
13.          (setq lst(cons x lst)s(vl-remove x s)))nil)s))
    
14.       lst)))
    
15. 
    
16. (defun e2s(es / s)
    
17.   (and(setq es(vl-remove-if-not(function(lambda(x)(equal(type x)'ename)))es))
    
18.       (setq s(ssadd))(vl-every(function(lambda(x)(ssadd x s)))es))s)
    
19. 
    
20. 
    
21. (sssetfirst nil(e2s(ssgetcross(car(entsel"选择圆"))0.3)))

(defun ssgetcross(e fuz / s lst cirx)<br />   (defun cirx(e1 e2 / d r1 r2)<br />     (setq e1(entget e1)e2(entget e2)<br />     d(distance(mapcar'+'(0 0)(cdr(assoc 10 e1)))(cdr(assoc 10 e2)))<br />     r1(cdr(assoc 40 e1))r2(cdr(assoc 40 e2)))<br />     (<(abs(- r1 r2 fuz))d(+ r1 r2 fuz)))<br />   (if(and(=(type e)'ENAME)(vl-position'(0 . "CIRCLE")(entget e))(numberp fuz))<br />     (progn<br />       (setq lst(list e)s(vl-remove(car lst)(mapcar'cadr(ssnamex(ssget"x"'((0 . "circle"))))))n 0)<br />       (while(< n(setq n(length lst)))<br />   (vl-some'(lambda(x)<br />        (if(vl-some'(lambda(a)(cirx x a))lst)<br />          (setq lst(cons x lst)s(vl-remove x s)))nil)s))<br />       lst)))<br /> <br /> (defun e2s(es / s)<br />   (and(setq es(vl-remove-if-not(function(lambda(x)(equal(type x)'ename)))es))<br />       (setq s(ssadd))(vl-every(function(lambda(x)(ssadd x s)))es))s)<br /> <br /> <br /> (sssetfirst nil(e2s(ssgetcross(car(entsel"选择圆"))0.3)))

树櫴希德

1. (defun tt-el(e / a b p0);;返回椭圆的焦点;e 椭圆图元名
   
2.   (if(and(=(type e)'ename)
   
3.    (vl-position'(0 . "ELLIPSE")(setq e(entget e))))
   
4.     (setq a(cdr(assoc 11 e))b(*(sqrt(- 1(expt(cdr(assoc 40 e))2)))(distance'(0 0)a))
   
5.     p0(cdr(assoc 10 e))
   
6.     p0(list(mapcar'+(polar'(0 0)(angle'(0 0)a)b)p0)
   
7.      (mapcar'+(polar'(0 0)(angle a'(0 0))b)p0)))))
   
8. (defun tt147(e p);;;过曲线指定点绘制切线
   
9.   (or(VL-CATCH-ALL-ERROR-P(setq p(VL-CATCH-ALL-APPLY(function vlax-curve-getclosestpointto)(list e p))))
   
10.      (vlax-invoke-method(vlax-get-property(vlax-get-property(vlax-get-acad-object)'activedocument)'modelspace)
    
11.        'addxline(vlax-3d-point p)
    
12.        (vlax-3d-point(polar p(angle'(0 0)(vlax-curve-getFirstDeriv e(vlax-curve-getParamAtPoint e p)))1)))))
    
13. 
    
14. (defun tt123(e p);;;过曲线指定点绘制切线
    
15.   (or(VL-CATCH-ALL-ERROR-P(setq p(VL-CATCH-ALL-APPLY(function vlax-curve-getclosestpointto)(list e p))))
    
16.      (entmake(list'(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline")
    
17.       (cons 10 p)
    
18.       (cons 11(vlax-curve-getFirstDeriv e(vlax-curve-getParamAtPoint e p)))))))
    
19. 
    
20. ;(tt-el (car(entsel)))
    
21. ;(tt147 (car(entsel))  (getpoint))

(defun tt-el(e / a b p0);;返回椭圆的焦点;e 椭圆图元名<br />   (if(and(=(type e)'ename)<br />    (vl-position'(0 . "ELLIPSE")(setq e(entget e))))<br />     (setq a(cdr(assoc 11 e))b(*(sqrt(- 1(expt(cdr(assoc 40 e))2)))(distance'(0 0)a))<br />     p0(cdr(assoc 10 e))<br />     p0(list(mapcar'+(polar'(0 0)(angle'(0 0)a)b)p0)<br />      (mapcar'+(polar'(0 0)(angle a'(0 0))b)p0)))))<br /> (defun tt147(e p);;;过曲线指定点绘制切线<br />   (or(VL-CATCH-ALL-ERROR-P(setq p(VL-CATCH-ALL-APPLY(function vlax-curve-getclosestpointto)(list e p))))<br />      (vlax-invoke-method(vlax-get-property(vlax-get-property(vlax-get-acad-object)'activedocument)'modelspace)<br />        'addxline(vlax-3d-point p)<br />        (vlax-3d-point(polar p(angle'(0 0)(vlax-curve-getFirstDeriv e(vlax-curve-getParamAtPoint e p)))1)))))<br /> <br /> (defun tt123(e p);;;过曲线指定点绘制切线<br />   (or(VL-CATCH-ALL-ERROR-P(setq p(VL-CATCH-ALL-APPLY(function vlax-curve-getclosestpointto)(list e p))))<br />      (entmake(list'(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline")<br />       (cons 10 p)<br />       (cons 11(vlax-curve-getFirstDeriv e(vlax-curve-getParamAtPoint e p)))))))<br /> <br /> ;(tt-el (car(entsel)))<br /> ;(tt147 (car(entsel))  (getpoint))

树櫴希德

收藏藏老师程序
修复无法插入图形文件

;通过DBX读取原文件，拷贝到一个块里边，释放DBX,重建DBX,从块内拷到DBX,保存
;然后就可以插入了

1. (defun c:xfwfcrdwg(/ file *cad *doc blk *dbx model l n)
   
2.   (and
   
3.     (setq file(getfiled "修复无法插入图形文件""""dwg" 4))
   
4.     (setq *cad(vlax-get-acad-object)
   
5.           *doc(vlax-get-property *cad 'activedocument)
   
6.           blk(vlaX-invoke-method(vlax-get-property *doc 'blocks)'add(vlax-3d-point'(0 0))"*U")
   
7.           *dbx(atoi(getvar "ACADVER"))
   
8.           *dbx(vla-GetInterfaceObject *cad(if(< *dbx 16)"ObjectDBX.AxDbDocument"(strcat"ObjectDBX.AxDbDocument."(itoa *dbx))))      
   
9.     )
   
10.     (not(VL-CATCH-ALL-APPLY'vlax-invoke-method(List *dbx'open file)))
    
11.     (setq model(vlax-get-property *dbx 'modelspace)
    
12.           n -1
    
13.       l(vlax-make-safearray 9(cons 0(1-(vlax-get-property model 'count))))      
    
14.     )
    
15.     (vlax-for x model(setq n(1+ n))(vlax-safearray-put-element l n x))
    
16.     (vlax-invoke-method *dbx'copyobjects l blk)
    
17.     (setq l (vlax-variant-value(vlax-invoke-method *dbx'copyobjects l blk)))
    
18.     (vlax-release-object *dbx)
    
19.     (setq *dbx(atoi(getvar "ACADVER"))
    
20.           *dbx(vla-GetInterfaceObject *cad(if(< *dbx 16)"ObjectDBX.AxDbDocument"(strcat"ObjectDBX.AxDbDocument."(itoa *dbx))))      
    
21.     )
    
22.     (vlax-invoke-method *doc 'copyobjects l(vlax-get-property *dbx'modelspace))
    
23.     (vlax-invoke-method blk 'delete)
    
24.     (vlax-invoke-method *dbx 'saveas file)   
    
25.   )  
    
26. )

(defun c:xfwfcrdwg(/ file *cad *doc blk *dbx model l n)<br />   (and<br />     (setq file(getfiled "修复无法插入图形文件""""dwg" 4))<br />     (setq *cad(vlax-get-acad-object)<br />           *doc(vlax-get-property *cad 'activedocument)<br />           blk(vlaX-invoke-method(vlax-get-property *doc 'blocks)'add(vlax-3d-point'(0 0))"*U")<br />           *dbx(atoi(getvar "ACADVER"))<br />           *dbx(vla-GetInterfaceObject *cad(if(< *dbx 16)"ObjectDBX.AxDbDocument"(strcat"ObjectDBX.AxDbDocument."(itoa *dbx))))      <br />     )<br />     (not(VL-CATCH-ALL-APPLY'vlax-invoke-method(List *dbx'open file)))<br />     (setq model(vlax-get-property *dbx 'modelspace)<br />           n -1<br />       l(vlax-make-safearray 9(cons 0(1-(vlax-get-property model 'count))))      <br />     )<br />     (vlax-for x model(setq n(1+ n))(vlax-safearray-put-element l n x))<br />     (vlax-invoke-method *dbx'copyobjects l blk)<br />     (setq l (vlax-variant-value(vlax-invoke-method *dbx'copyobjects l blk)))<br />     (vlax-release-object *dbx)<br />     (setq *dbx(atoi(getvar "ACADVER"))<br />           *dbx(vla-GetInterfaceObject *cad(if(< *dbx 16)"ObjectDBX.AxDbDocument"(strcat"ObjectDBX.AxDbDocument."(itoa *dbx))))      <br />     )<br />     (vlax-invoke-method *doc 'copyobjects l(vlax-get-property *dbx'modelspace))<br />     (vlax-invoke-method blk 'delete)<br />     (vlax-invoke-method *dbx 'saveas file)    <br />   )  <br /> )

树櫴希德

沿多段线布圆圈

1. ;
   
2. 
   
3. ( defun c:ddxyuan  (/  juli ddx gs i pt rr)
   
4. (setq juli (getreal "\n请输入间隔距离："))
   
5.   (setq rr (getreal "\n请输入圆圈半径："))
   
6. (setq ddx (car(entsel "\n请选择多段线：" )) )
   
7.   (setq gs (fix(/ (vlax-get-property (vlax-ename->vla-object   ddx) "length") juli )) )
   
8.      (setq i 1)
   
9.        (repeat  (+ gs 1 )
   
10.          (setq pt  (vlax-curve-getPointAtDist ddx (* i juli)))
    
11.    (entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 rr)))
    
12.    (setq i (1+ i))
    
13.    )
    
14. 
    
15.        (princ)
    
16. 
    
17.       )
    
18. 
    
19. ( defun c:ddxyuan1  (/  juli ddx gs i pt rr)
    
20. (setq gs (getint "\n请输入圆个数："))
    
21.   (setq rr (getreal "\n请输入圆圈半径："))
    
22. (setq ddx (car(entsel "\n请选择多段线：" )) )
    
23.   (setq juli (/ (vlax-get-property (vlax-ename->vla-object   ddx) "length") gs ))
    
24.      (setq i 1)
    
25.        (repeat  (+ gs 0 )
    
26.          (setq pt  (vlax-curve-getPointAtDist ddx (* i juli)))
    
27.    (entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 rr)))
    
28.    (setq i (1+ i))
    
29.    )
    
30. 
    
31.        (princ)
    
32. 
    
33.       )

;<br /> <br /> ( defun c:ddxyuan  (/  juli ddx gs i pt rr)<br /> (setq juli (getreal "\n请输入间隔距离："))<br />   (setq rr (getreal "\n请输入圆圈半径："))<br /> (setq ddx (car(entsel "\n请选择多段线：" )) ) <br />   (setq gs (fix(/ (vlax-get-property (vlax-ename->vla-object   ddx) "length") juli )) )<br />      (setq i 1)<br />        (repeat  (+ gs 1 )<br />          (setq pt  (vlax-curve-getPointAtDist ddx (* i juli)))<br />    (entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 rr)))<br />    (setq i (1+ i))<br />    )<br /> <br />        (princ)<br /> <br />       )<br /> <br /> ( defun c:ddxyuan1  (/  juli ddx gs i pt rr)<br /> (setq gs (getint "\n请输入圆个数："))<br />   (setq rr (getreal "\n请输入圆圈半径："))<br /> (setq ddx (car(entsel "\n请选择多段线：" )) ) <br />   (setq juli (/ (vlax-get-property (vlax-ename->vla-object   ddx) "length") gs )) <br />      (setq i 1)<br />        (repeat  (+ gs 0 )<br />          (setq pt  (vlax-curve-getPointAtDist ddx (* i juli)))<br />    (entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 rr)))<br />    (setq i (1+ i))<br />    )<br /> <br />        (princ)<br /> <br />       )

树櫴希德

1. (defun c:pp ( /  objold  ) ;偏移块内多段线至图面
   
2.   (prompt "\n 需要EXPRESS工具箱支持才能")
   
3. (command  "ncopy" (cadr(entsel"\n请选择块内多段线：")) "" "0,0" "0,0" )
   
4. (setq objold   (vlax-ename->vla-object(entlast) ) )
   
5. (vla-offset  objold  (* -1 (getreal "\n请输入偏移值：")))
   
6. (vla-Delete objold )  (vla-put-Color (vlax-ename->vla-object(entlast) ) 1 )
   
7. (princ)
   
8. )

(defun c:pp ( /  objold  ) ;偏移块内多段线至图面<br />   (prompt "\n 需要EXPRESS工具箱支持才能")<br /> (command  "ncopy" (cadr(entsel"\n请选择块内多段线：")) "" "0,0" "0,0" )<br /> (setq objold   (vlax-ename->vla-object(entlast) ) )<br /> (vla-offset  objold  (* -1 (getreal "\n请输入偏移值："))) <br /> (vla-Delete objold )  (vla-put-Color (vlax-ename->vla-object(entlast) ) 1 )<br /> (princ)<br /> )

664571221

什么是链接选择