收藏73哥程序，链式选择相交圆
收藏73哥程序，链式选择相交圆
(vl-load-com)
(defun xBox(s / p a b);;选择集，图元(对象)表，图元包容盒
(vl-every'(lambda(x)
(vla-getboundingbox(if(=(type x)'ename)(vlax-ename->vla-object x)x)'a'b)
(setq p(append(mapcar'vlax-safearray->list(list a b))p)))
(if(/=(type s)'pickset)(if(listp s)s(list s))
(mapcar'cadr(member(nth(1-(sslength s))(setq s(ssnamex s)))(reverse s)))))
(mapcar'(lambda(a)(apply'mapcar(cons a p)))'(min max)))
(defun rect(p)(list(List(caar p)(cadadr p))(cadr p)(list(caadr p)(cadar p))(car p)))
(defun cirx(c1 c2 / e1 e2 d r1 r2);;两
(and(=(type c1)(type c2)'ename)
(setq e1(entget c1)e2(entget c2))
(equal(assoc 0 e1)'(0 . "CIRCLE"))
(equal(assoc 0 e2)'(0 . "CIRCLE"))
(setq d(distance(mapcar'+'(0 0)(cdr(assoc 10 e1)))(cdr(assoc 10 e2)))
r1(cdr(assoc 40 e1))r2(cdr(assoc 40 e2)))
(<(abs(- r1 r2))d(+ r1 r2))))
(defun e2s(es / s)
(and(setq es(vl-remove-if-not(function(lambda(x)(equal(type x)'ename)))es))
(setq s(ssadd))(vl-every(function(lambda(x)(ssadd x s)))es))s)
(defun s2e(s / n lst)(if(=(type s)'pickset)(repeat(setq n(sslength s))(setq n(1- n)lst(cons(ssname s n)lst)))))
(defun ssgetcross(/ e n lst)
(if(setq e(ssget":E:S"'((0 . "circle"))))
(progn
(setq lst(list(ssname e 0))n 0)
(while(< n(setq n(length lst)))
(vl-some'(lambda(x)(or(vl-position x lst)
(if(vl-some'(lambda(a)(cirx x a))lst)
(setq lst(cons x lst))))nil)
(s2e(ssget"cp"(rect(xbox lst))'((0 . "circle"))))))
lst)))
(sssetfirst nil(e2s(ssgetcross)))
顶，聊天群看到的，也收藏了 。厉害 谢谢分享，收藏+1 本帖最后由 树櫴希德 于 2023-10-20 12:10 编辑
73哥 代码带容差链式选择园
(defun ssgetcross(e fuz / s lst cirx)
(defun cirx(e1 e2 / d r1 r2)
(setq e1(entget e1)e2(entget e2)
d(distance(mapcar'+'(0 0)(cdr(assoc 10 e1)))(cdr(assoc 10 e2)))
r1(cdr(assoc 40 e1))r2(cdr(assoc 40 e2)))
(<(abs(- r1 r2 fuz))d(+ r1 r2 fuz)))
(if(and(=(type e)'ENAME)(vl-position'(0 . "CIRCLE")(entget e))(numberp fuz))
(progn
(setq lst(list e)s(vl-remove(car lst)(mapcar'cadr(ssnamex(ssget"x"'((0 . "circle"))))))n 0)
(while(< n(setq n(length lst)))
(vl-some'(lambda(x)
(if(vl-some'(lambda(a)(cirx x a))lst)
(setq lst(cons x lst)s(vl-remove x s)))nil)s))
lst)))
(defun e2s(es / s)
(and(setq es(vl-remove-if-not(function(lambda(x)(equal(type x)'ename)))es))
(setq s(ssadd))(vl-every(function(lambda(x)(ssadd x s)))es))s)
(sssetfirst nil(e2s(ssgetcross(car(entsel"选择圆"))0.3))) (defun tt-el(e / a b p0);;返回椭圆的焦点;e 椭圆图元名
(if(and(=(type e)'ename)
(vl-position'(0 . "ELLIPSE")(setq e(entget e))))
(setq a(cdr(assoc 11 e))b(*(sqrt(- 1(expt(cdr(assoc 40 e))2)))(distance'(0 0)a))
p0(cdr(assoc 10 e))
p0(list(mapcar'+(polar'(0 0)(angle'(0 0)a)b)p0)
(mapcar'+(polar'(0 0)(angle a'(0 0))b)p0)))))
(defun tt147(e p);;;过曲线指定点绘制切线
(or(VL-CATCH-ALL-ERROR-P(setq p(VL-CATCH-ALL-APPLY(function vlax-curve-getclosestpointto)(list e p))))
(vlax-invoke-method(vlax-get-property(vlax-get-property(vlax-get-acad-object)'activedocument)'modelspace)
'addxline(vlax-3d-point p)
(vlax-3d-point(polar p(angle'(0 0)(vlax-curve-getFirstDeriv e(vlax-curve-getParamAtPoint e p)))1)))))
(defun tt123(e p);;;过曲线指定点绘制切线
(or(VL-CATCH-ALL-ERROR-P(setq p(VL-CATCH-ALL-APPLY(function vlax-curve-getclosestpointto)(list e p))))
(entmake(list'(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline")
(cons 10 p)
(cons 11(vlax-curve-getFirstDeriv e(vlax-curve-getParamAtPoint e p)))))))
;(tt-el (car(entsel)))
;(tt147 (car(entsel))(getpoint))
收藏藏老师程序
修复无法插入图形文件
;通过DBX读取原文件，拷贝到一个块里边，释放DBX,重建DBX,从块内拷到DBX,保存
;然后就可以插入了
(defun c:xfwfcrdwg(/ file *cad *doc blk *dbx model l n)
(and
(setq file(getfiled "修复无法插入图形文件""""dwg" 4))
(setq *cad(vlax-get-acad-object)
*doc(vlax-get-property *cad 'activedocument)
blk(vlaX-invoke-method(vlax-get-property *doc 'blocks)'add(vlax-3d-point'(0 0))"*U")
*dbx(atoi(getvar "ACADVER"))
*dbx(vla-GetInterfaceObject *cad(if(< *dbx 16)"ObjectDBX.AxDbDocument"(strcat"ObjectDBX.AxDbDocument."(itoa *dbx))))
)
(not(VL-CATCH-ALL-APPLY'vlax-invoke-method(List *dbx'open file)))
(setq model(vlax-get-property *dbx 'modelspace)
n -1
l(vlax-make-safearray 9(cons 0(1-(vlax-get-property model 'count))))
)
(vlax-for x model(setq n(1+ n))(vlax-safearray-put-element l n x))
(vlax-invoke-method *dbx'copyobjects l blk)
(setq l (vlax-variant-value(vlax-invoke-method *dbx'copyobjects l blk)))
(vlax-release-object *dbx)
(setq *dbx(atoi(getvar "ACADVER"))
*dbx(vla-GetInterfaceObject *cad(if(< *dbx 16)"ObjectDBX.AxDbDocument"(strcat"ObjectDBX.AxDbDocument."(itoa *dbx))))
)
(vlax-invoke-method *doc 'copyobjects l(vlax-get-property *dbx'modelspace))
(vlax-invoke-method blk 'delete)
(vlax-invoke-method *dbx 'saveas file)
)
)
沿多段线布圆圈
;
( defun c:ddxyuan(/juli ddx gs i pt rr)
(setq juli (getreal "\n请输入间隔距离："))
(setq rr (getreal "\n请输入圆圈半径："))
(setq ddx (car(entsel "\n请选择多段线：" )) )
(setq gs (fix(/ (vlax-get-property (vlax-ename->vla-object ddx) "length") juli )) )
(setq i 1)
(repeat(+ gs 1 )
(setq pt(vlax-curve-getPointAtDist ddx (* i juli)))
(entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 rr)))
(setq i (1+ i))
)
(princ)
)
( defun c:ddxyuan1(/juli ddx gs i pt rr)
(setq gs (getint "\n请输入圆个数："))
(setq rr (getreal "\n请输入圆圈半径："))
(setq ddx (car(entsel "\n请选择多段线：" )) )
(setq juli (/ (vlax-get-property (vlax-ename->vla-object ddx) "length") gs ))
(setq i 1)
(repeat(+ gs 0 )
(setq pt(vlax-curve-getPointAtDist ddx (* i juli)))
(entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 rr)))
(setq i (1+ i))
)
(princ)
)
(defun c:pp ( /objold) ;偏移块内多段线至图面
(prompt "\n 需要EXPRESS工具箱支持才能")
(command"ncopy" (cadr(entsel"\n请选择块内多段线：")) "" "0,0" "0,0" )
(setq objold (vlax-ename->vla-object(entlast) ) )
(vla-offsetobjold(* -1 (getreal "\n请输入偏移值：")))
(vla-Delete objold )(vla-put-Color (vlax-ename->vla-object(entlast) ) 1 )
(princ)
)
什么是链接选择 (vl-load-com)
(setq e(car(entsel"选择直线或多段线")))
;;;线完全穿过所有圆
(defun tt(e / s)
(vl-every(function(lambda(x)
(or(=(rem(vl-position x s)2)1)
(vl-cmdf"-hatch""P""SOLID""S"(cadr x)""""))))
(setq s(ssnamex(ssget"F"(list(vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e))
'((0 . "circle")))))))
(tt e)
(defun c:tt(/ ANG DIS DIS1 EN N PT1 PT2)
(setvar 'osmode 4)
(setq en (car (entsel "\nfirst circle:"))
pt1(cdr(assoc 10 (entget en)))
pt2(getpoint pt1 "\nend point:")
dis(distance pt1 pt2)
dis1 (getdist pt1 "\ngetdist:")
n (fix (/ dis dis1))
ang(angle pt1 pt2))
(setvar 'hpname "solid")
(vl-cmdf "_bhatch" "s" en "" "")
(repeat (fix(* 0.5(1+ n)))
(setq en (entlast))
(vl-cmdf "copy" (entlast) "" "none" pt1 "none" (setq pt1 (polar pt1 ang (* 2 dis1))))))
页:
[1]
2