收藏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)))
LM向块内添加实体
;;----------------------=={ Add Objects to Block }==--------------------;;
;; ;;
;;This program enables the user to add a selection of objects to the;;
;;definition of a selected block. ;;
;; ;;
;;Upon issuing the command syntax 'addtoblock' at the AutoCAD ;;
;;command line, the program prompts the user for a selection of ;;
;;objects residing on unlocked layers to be added to a chosen block ;;
;;definition. ;;
;; ;;
;;Following a valid selection, the program prompts the user to select ;;
;;a reference of a block whose definition is to be modified to ;;
;;incorporate all objects in the selection. ;;
;; ;;
;;At this prompt, the program will permit selection of any standard ;;
;;(non-dynamic) uniformly scaled block reference which is not ;;
;;referenced within the selection (as a block reference cannot be ;;
;;added to its own definition). ;;
;; ;;
;;Every object in the selection will then be transformed relative to;;
;;the position, scale, rotation, and orientation of the selected ;;
;;block reference, before being copied to the definition of the ;;
;;block and removed from the drawing. ;;
;;----------------------------------------------------------------------;;
;;Author:Lee Mac, Copyright ?2011-www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;;Version 1.1 - 2011-05-31 ;;
;; ;;
;;- First release. ;;
;;----------------------------------------------------------------------;;
;;Version 1.2 - 2020-11-15 ;;
;; ;;
;;- Program completely rewritten to incorporate a check for ;;
;; references of the target block within the selected objects. ;;
;;----------------------------------------------------------------------;;
(defun c:addtoblock ( / *error* bln bnl btr def ent enx idx lst sel tmp )
(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(LM:startundo (LM:acdoc))
(cond
( (not (setq sel (LM:ssget "\nSelect objects to add to block: " '("_:L")))))
( (progn
(repeat (setq idx (sslength sel))
(setq idx (1- idx)
ent (ssname sel idx)
enx (entget ent)
lst (cons (vlax-ename->vla-object ent) lst)
)
(if (and (= "INSERT" (cdr (assoc 0 enx)))
(not (member (setq bln (strcase (cdr (assoc 2 enx)))) bnl))
)
(setq bnl (cons bln bnl))
)
)
(while (setq def (tblnext "block" (not def)))
(setq ent (tblobjname "block" (cdr (assoc 2 def))))
(while (setq ent (entnext ent))
(if (= "INSERT" (cdr (assoc 0 (setq enx (entget ent)))))
(setq tmp (cons (strcase (cdr (assoc 2 enx))) tmp))
)
)
(if tmp
(setq btr (cons (cons (strcase (cdr (assoc 2 def))) tmp) btr)
tmp nil
)
)
)
(while
(progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect block: ")))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (null ent)
nil
)
( (/= "INSERT" (cdr (assoc 0 (setq enx (entget ent)))))
(princ "\nThe selected object is not a block.")
)
( (not
(and
(equal (abs (cdr (assoc 41 enx))) (abs (cdr (assoc 42 enx))) 1e-8)
(equal (abs (cdr (assoc 41 enx))) (abs (cdr (assoc 43 enx))) 1e-8)
)
)
(princ "\nThis program is not currently compatible with non-uniformly scaled blocks - sorry.")
)
( (= :vlax-true (vla-get-isdynamicblock (vlax-ename->vla-object ent)))
(princ "\nThis program is not currently compatible with dynamic blocks - sorry.")
)
( (vl-some '(lambda ( bln ) (member bln bnl))
(
(lambda ( / rtn )
(setq bln (strcase (cdr (assoc 2 enx))))
(foreach def btr
(cond
( (= bln (car def)))
( (member (car def) rtn))
( (addtoblock:referenced-p bln (cdr def) btr) (setq rtn (cons (car def) rtn)))
)
)
(cons bln rtn)
)
)
)
(princ "\nThe selected block is referenced by a block in the selection.")
)
)
)
)
ent
)
( (lambda ( mat )
(foreach obj lst (vla-transformby obj mat))
(vla-copyobjects (LM:acdoc)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject (cons 0 (1- (length lst))))
lst
)
)
(vla-item (vla-get-blocks (LM:acdoc)) (cdr (assoc 2 (entget ent))))
)
(foreach obj lst (vla-delete obj))
(vla-regen (LM:acdoc) acallviewports)
)
(apply
(function
(lambda ( mat vec )
(vlax-tmatrix
(append
(mapcar
(function
(lambda ( x v )
(append x (list v))
)
)
mat vec
)
'((0.0 0.0 0.0 1.0))
)
)
)
)
(revrefgeom ent)
)
)
)
)
(LM:endundo (LM:acdoc))
(princ)
)
(defun addtoblock:referenced-p ( bln def lst )
(or (member bln def)
(vl-some '(lambda ( nst ) (addtoblock:referenced-p bln (cdr (assoc nst lst)) lst)) def)
)
)
;; RevRefGeom (gile)
;; The inverse of RefGeom
(defun revrefgeom ( ent / ang enx mat ocs )
(setq enx (entget ent)
ang (cdr (assoc 050 enx))
ocs (cdr (assoc 210 enx))
)
(list
(setq mat
(mxm
(list
(list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0)
(list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0)
(list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx))))
)
(mxm
(list
(list (cos ang) (sin ang) 0.0)
(list (- (sin ang)) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(mapcar '(lambda ( v ) (trans v ocs 0 t))
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
)
)
)
(mapcar '- (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
(mxv mat (trans (cdr (assoc 10 enx)) ocs 0))
)
)
)
;; Matrix Transpose-Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix-Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Matrix x Vector-Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
;; ssget-Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - selection prompt
;; arg - list of ssget arguments
(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)
;; Start Undo-Lee Mac
;; Opens an Undo Group.
(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)
;; End Undo-Lee Mac
;; Closes an Undo Group.
(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)
;; Active Document-Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
;;----------------------------------------------------------------------;;
(vl-load-com)
(princ
(strcat
"\n:: AddObjectsToBlock.lsp | Version 1.2 | \\U+00A9 Lee Mac "
((lambda ( y ) (if (= y (menucmd "m=$(edtime,0,yyyy)")) y (strcat y "-" (menucmd "m=$(edtime,0,yyyy)")))) "2011")
" www.lee-mac.com ::"
"\n:: Type \"addtoblock\" to Invoke ::"
)
)
(princ)
;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;
收藏藏老师程序
修复无法插入图形文件
;通过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)
)
)
如何获取系统的屏幕分辨率设置值？谢谢
@Koz@必强感谢两位大佬！
(Defun vlsys-GetScreenResolution (/ w h wmi meth1 meth2 n)
(if (setq wmi (vlax-create-object "WbemScripting.SWbemLocator"))
(progn
(setq meth1 (vlax-invoke wmi 'ConnectServer)
meth2 (vlax-invoke
meth1 'ExecQuery
"Select * from Win32_VideoController"
"WQL" 48
)
)
(vlax-for n meth2
(setq w (vlax-get n 'CurrentVerticalResolution)
h (vlax-get n 'CurrentHorizontalResolution)
)
)
(mapcar 'vlax-release-object (list wmi meth1 meth2))
)
)
(list w h)
)
(Defun vldcl-GetScreenResolutionByH51 (/ VLO)
(setq vlo (vlax-get-property
(vlax-get-property
(vlax-get-or-Create-Object "HtmlFile")
"ParentWindow"
)
"Screen"
)
)
(mapcar '(lambda (x) (vlax-get-property vlo x))
'("width" "height" "logicalXDPI" "logicalYDPI")
)
)
顶，聊天群看到的，也收藏了 。厉害 谢谢分享，收藏+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))
沿多段线布圆圈
;
( 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