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

树櫴希德 · 发表于 2023-10-18 12:25:51

收藏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)))

(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)))

树櫴希德 · 发表于 2024-9-30 21:01:37

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: " '("_")))))
( (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 - [str] selection prompt
;; arg - [lst] 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 ;;
;;----------------------------------------------------------------------;;

;;----------------------=={ 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  -  <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>              ;; 
;;----------------------------------------------------------------------;; 
;;  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: " '("_<img src="static/image/smiley/default/sweat.gif" smilieid="10" border="0" alt="" />"))))) 
        (   (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 - [str] selection prompt 
;; arg - [lst] 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") 
        " <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a> ::" 
        "\n:: Type \"addtoblock\" to Invoke ::" 
    ) 
) 
(princ) 
 
;;----------------------------------------------------------------------;; 
;;                             End of File                              ;; 
;;----------------------------------------------------------------------;;

树櫴希德 · 发表于 2024-1-17 18:20:38

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

;通过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: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)    
  )   
)

树櫴希德 · 发表于 2024-6-10 16:49:05

如何获取系统的屏幕分辨率设置值？谢谢
@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")
)
)

(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") 
  ) 
)

嘒彼小星 · 发表于 2023-10-19 12:27:15

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

lxl217114 · 发表于 2023-10-19 19:40:48

谢谢分享，收藏+1

树櫴希德 · 发表于 2023-10-19 20:40:54

本帖最后由树櫴希德于 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)))

树櫴希德 · 发表于 2023-10-20 15:58:04

(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 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))

树櫴希德 · 发表于 2024-3-28 20:43:39

沿多段线布圆圈

;
( 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: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) 
 
      )

树櫴希德 · 发表于 2024-4-4 10:13:19

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

664571221 · 发表于 2024-4-13 16:10:13

什么是链接选择

树櫴希德 · 发表于 2024-5-9 19:19:24

(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))))))

账号		自动登录	找回密码
密码			注册

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

本帖子中包含更多资源

评分

本帖子中包含更多资源