请教如何以图块最外层的边界修剪图块下面的直线？

阿然 · 发表于 2013-1-2 01:52:20

我就不写了，lee大已经写过一个这样的程序了，很强大
非常好的例子

;;----------------=={ Automatic Block Break }==---------------;;
;; ;;
;; Prompts user for selection of a block, then point for ;;
;; insertion. ;;
;; ;;
;; If a curve is detected at the selected point, the ;;
;; inserted block is rotated to align with the curve. ;;
;; ;;
;; All surrounding objects found to intersect with the block ;;
;; are then trimmed to the rectangular block outline. ;;
;; ;;
;; Program works in all views & UCS. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Version 1.0 - 22.11.2010 ;;
;; ;;
;; First Release. ;;
;;------------------------------------------------------------;;
;; Version 1.1 - 07.02.2011 ;;
;; ;;
;; Entire program rewritten to allow subfunction to be ;;
;; called with block object argument. ;;
;; Multiple intersecting objects are trimmed. ;;
;;------------------------------------------------------------;;
;; Version 1.2 - 08.02.2011 ;;
;; ;;
;; Changed block insertion to VL InsertBlock method. ;;
;; Added calling function to trim a block in-situ (ABBE). ;;
;;------------------------------------------------------------;;
;; Version 1.3 - 03.08.2011 ;;
;; ;;
;; Altered method to create bounding polyline to exclude ;;
;; attributes when trimming objects surrounding block. ;;
;; Objects surrounding blocks whose insertion point does not ;;
;; lie on a curve are now also trimmed. ;;
;;------------------------------------------------------------;;
;; Version 1.4 - 30.09.2011 ;;
;; ;;
;; Added option to enable/disable automatic block rotation. ;;
;; Updated code formatting. ;;
;;------------------------------------------------------------;;
(defun c:ABB ( / *error* _StartUndo _EndUndo acspc block obj pt sel )
(defun *error* ( msg )
(if acdoc (_EndUndo acdoc))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(defun _StartUndo ( doc )
(_EndUndo doc)
(vla-StartUndoMark doc)
)
(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)
(setq acdoc (cond (acdoc) ((vla-get-activedocument (vlax-get-acad-object))))
acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'paperspace 'modelspace))
)
(if
(and
(progn
(while
(progn (setvar 'ERRNO 0) (initget "Browse Rotation")
(princ (strcat "\nAutomatic Block Rotation: " (getenv "LMac\\ABBRotation")))
(setq sel
(entsel
(strcat "\nSelect Block [Browse/Rotation]"
(if (eq "" (setq block (getvar 'INSNAME))) ": " (strcat " <" block "> : "))
)
)
)
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nMissed, Try Again.")
)
( (not sel)
(if (eq "" block) (setq block nil))
)
( (eq "Rotation" sel)
(initget "ON OFF")
(setenv "LMac\\ABBRotation"
(cond
(
(getkword
(strcat "\nAutomatic Block Rotation [ON/OFF] <"
(getenv "LMac\\ABBRotation") ">: "
)
)
)
( (getenv "LMac\\ABBRotation") )
)
)
)
( (eq "Browse" sel)
(setq block (getfiled "Select Block" "" "dwg" 16))
nil
)
( (listp sel)
(if (not (eq "INSERT" (cdr (assoc 0 (entget (car sel))))))
(princ "\nObject Must be a Block.")
(not (setq obj (vla-copy (vlax-ename->vla-object (car sel)))))
)
)
)
)
)
block
)
(setq pt (getpoint "\nSpecify Point for Block: "))
(or obj
(setq obj
(vla-InsertBlock acspc (vlax-3D-point (trans pt 1 0)) block 1. 1. 1.
(angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 (trans '(0. 0. 1.) 1 0 t) t))
)
)
)
)
(progn
(_StartUndo acdoc)
(if block (setvar 'INSNAME (vl-filename-base block)))
(vla-put-InsertionPoint obj (vlax-3D-point (trans pt 1 0)))
(LM:AutoBlockBreak obj (eq "ON" (getenv "LMac\\ABBRotation")))
(_EndUndo acdoc)
)
)
(princ)
)
;;------------=={ Automatic Block Break Existing }==----------;;
;; ;;
;; Prompts user for selection of a block and, if a curve is ;;
;; detected at the block insertion point, the block is ;;
;; rotated to align with the curve. All objects found to ;;
;; intersect with the block are then trimmed to the ;;
;; rectangular block outline. ;;
;; ;;
;; Program works in all views & UCS. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
(defun c:ABBE ( / sel )
(while
(progn
(setvar 'ERRNO 0)
(initget "Rotation")
(princ (strcat "\nAutomatic Block Rotation: " (getenv "LMac\\ABBRotation")))
(setq sel (entsel "\nSelect Block to Trim [Rotation]: "))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nMissed, Try Again.")
)
( (eq "Rotation" sel)
(initget "ON OFF")
(setenv "LMac\\ABBRotation"
(cond
(
(getkword
(strcat "\nAutomatic Block Rotation [ON/OFF] <"
(getenv "LMac\\ABBRotation") ">: "
)
)
)
( (getenv "LMac\\ABBRotation") )
)
)
)
( (eq 'ENAME (type (car sel)))
(if (eq "INSERT" (cdr (assoc 0 (entget (car sel)))))
(LM:AutoBlockBreak (car sel) (eq "ON" (getenv "LMac\\ABBRotation")))
(princ "\nInvalid Object Selected.")
)
t
)
)
)
)
(princ)
)
;;-----------=={ Automatic Block Break Selection }==----------;;
;; ;;
;; Prompts user for selection of a set of blocks and, if a ;;
;; curve is detected at each block insertion point, the ;;
;; block is rotated to align with the curve. All objects ;;
;; found to intersect with the block are then trimmed to the ;;
;; rectangular block outline. ;;
;; ;;
;; Program works in all views & UCS. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
(defun c:ABBS ( / ss i )
(if (setq ss (ssget "_:L" '((0 . "INSERT"))))
(repeat (setq i (sslength ss))
(LM:AutoBlockBreak (ssname ss (setq i (1- i))) (eq "ON" (getenv "LMac\\ABBRotation")))
)
)
(princ)
)
;;----------=={ Automatic Block Break SubFunction }==---------;;
;; ;;
;; Takes a block reference argument and trims surrounding ;;
;; geometry if curve is detected at the insertion point of ;;
;; the block. ;;
;; ;;
;; If a curve is detected, the block is rotated to align ;;
;; with the curve and all objects found to intersect with ;;
;; the block are trimmed to the rectangular block outline. ;;
;; ;;
;; Program works in all views & UCS. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; block - EName or VLA-Object of Block Reference object ;;
;;------------------------------------------------------------;;
(defun LM:AutoBlockBreak
( block rotate / *error* _GetFurthestApart acspc bbx brk cmd crv en ent enx int lst mat nme ply pt ss x )
(defun *error* ( msg )
(if (and ply (not (vlax-erased-p ply))) (vla-delete ply))
(if cmd (setvar 'CMDECHO cmd))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(defun _GetFurthestApart ( lst / mx p1 p2 ds rslt )
(setq mx 0.0)
(while (setq p1 (car lst))
(foreach p2 (setq lst (cdr lst))
(if (< mx (setq ds (distance p1 p2))) (setq mx ds rslt (list p1 p2)))
)
)
rslt
)
(setq cmd (getvar 'CMDECHO))
(setvar 'CMDECHO 0)
(setq acdoc (cond (acdoc) ((vla-get-activedocument (vlax-get-acad-object))))
acblk (cond (acblk) ((vla-get-blocks acdoc)))
acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'paperspace 'modelspace))
)
(if
(and
(setq ent
(cond
( (eq 'ENAME (type block))
block
)
( (eq 'VLA-OBJECT (type block))
(vlax-vla-object->ename block)
)
)
)
(setq enx (entget ent))
(eq "INSERT" (cdr (assoc 0 enx)))
)
(progn
(if rotate
(progn
(setq pt (cdr (assoc 10 enx)))
(if
(setq ss
(ssget "_C"
(polar (trans pt ent 1) (/ pi -4.) 1e-4)
(polar (trans pt ent 1) (/ (* 3. pi) 4.) 1e-4)
'((0 . "~INSERT,ARC,ELLIPSE,CIRCLE,*LINE"))
)
)
(progn (setq crv (ssname ss 0))
(entupd
(cdr
(assoc -1
(entmod
(subst
(cons 50
(LM:MakeReadable
(angle '(0. 0. 0.)
(trans
(vlax-curve-getFirstDeriv crv
(vlax-curve-getParamatPoint crv
(vlax-curve-getClosestPointto crv (trans pt ent 0))
)
)
0 crv
)
)
)
)
(assoc 50 enx) enx
)
)
)
)
)
)
)
)
)
(setq nme (cdr (assoc 2 enx))
mat (RefGeom ent)
)
(setq bbx
(mapcar '(lambda ( x ) (mapcar '+ (mxv (car mat) x) (cadr mat)))
(cond
( (cdr (assoc nme *blockboundingboxes*)) )
( (cdar
(setq *blockboundingboxes*
(cons
(cons nme (LM:BlockDefinitionBoundingBox acblk nme)) *blockboundingboxes*
)
)
)
)
)
)
)
(if
(setq ss
(ssget "_C"
(trans (car bbx) 0 1)
(trans (caddr bbx) 0 1)
'((0 . "~INSERT,ARC,ELLIPSE,CIRCLE,*LINE"))
)
)
(progn
(vla-put-closed (setq ply (vlax-invoke acspc 'add3dpoly (apply 'append bbx))) :vlax-true)
(while (setq en (ssname ss 0))
(if (setq int (LM:GroupByNum (vlax-invoke (vlax-ename->vla-object en) 'IntersectWith ply acExtendThisEntity) 3))
(setq lst (cons (cons en int) lst))
)
(ssdel en ss)
)
(vla-delete ply)
(foreach int lst
(setq brk (_GetFurthestApart (cdr int)))
(command
"_.break" (list (car int) (trans (car brk) 0 1)) "_F"
"_non" (trans (car brk) 0 1)
"_non" (trans (cadr brk) 0 1)
)
)
)
)
)
)
(setvar 'CMDECHO cmd)
(princ)
)
;;-------------=={ Block Definition BoundingBox }==-----------;;
;; ;;
;; Returns a point list describing a rectangular frame ;;
;; bounding all objects in a block definition. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; blocks - The Block Collection in which the block resides ;;
;; block - The name of the block ;;
;;------------------------------------------------------------;;
;; Returns: Point list describing boundingbox of definition ;;
;;------------------------------------------------------------;;
(defun LM:BlockDefinitionBoundingBox ( blocks block / l1 l2 ll ur )
(vlax-for obj (vla-item blocks block)
(if
(and
(vlax-method-applicable-p obj 'getboundingbox)
(not (eq "AcDbAttributeDefinition" (vla-get-objectname obj)))
)
(if
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-getboundingbox (list obj 'll 'ur))
)
)
(setq l1 (cons (vlax-safearray->list ll) l1)
l2 (cons (vlax-safearray->list ur) l2)
)
)
)
)
(if l1
(
(lambda ( boundingbox )
(mapcar
(function
(lambda ( _functionlist )
(mapcar
(function
(lambda ( _function ) ((eval _function) boundingbox))
)
_functionlist
)
)
)
'((caar cadar) (caadr cadar) (caadr cadadr) (caar cadadr))
)
)
(list
(apply 'mapcar (cons 'min l1))
(apply 'mapcar (cons 'max l2))
)
)
)
)
;; RefGeom (gile)
;; Returns a list which first item is a 3x3 transformation matrix (rotation,
;; scales, normal) and second item the object insertion point in its parent
;; (xref, block or space)
;;
;; Argument : an ename
(defun RefGeom ( ename / elst ang norm mat )
(setq elst (entget ename)
ang (cdr (assoc 50 elst))
norm (cdr (assoc 210 elst))
)
(list
(setq mat
(mxm
(mapcar '(lambda ( v ) (trans v 0 norm T))
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
(mxm
(list
(list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
(list 0.0 0.0 1.0)
)
(list
(list (cdr (assoc 41 elst)) 0.0 0.0)
(list 0.0 (cdr (assoc 42 elst)) 0.0)
(list 0.0 0.0 (cdr (assoc 43 elst)))
)
)
)
)
(mapcar '- (trans (cdr (assoc 10 elst)) norm 0)
(mxv mat (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst))))))
)
)
)
;; 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))
;; 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)))
;;-----------------=={ Group by Number }==--------------------;;
;; ;;
;; Groups a list into a list of lists, each of length 'n' ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; l - List to process ;;
;; n - Number of elements by which to group the list ;;
;;------------------------------------------------------------;;
;; Returns: List of lists, each of length 'n' ;;
;;------------------------------------------------------------;;
(defun LM:GroupByNum ( l n / r)
(if l
(cons
(reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r))
(LM:GroupByNum l n)
)
)
)
;;-------------------=={ Make Readable }==--------------------;;
;; ;;
;; Returns an angle corrected for text readability ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; a - angle to process ;;
;;------------------------------------------------------------;;
;; Returns: angle corrected for text readability ;;
;;------------------------------------------------------------;;
(defun LM:MakeReadable ( a )
( (lambda ( a ) (if (and (< (/ pi 2.0) a) (<= a (/ (* 3.0 pi) 2.0))) (+ a pi) a))
(rem (+ a pi pi) (+ pi pi))
)
)
;;------------------------------------------------------------;;
(if (null (getenv "LMac\\ABBRotation"))
(setenv "LMac\\ABBRotation" "ON")
)
;;------------------------------------------------------------;;
(vl-load-com) (princ)
(princ "\n:: AutoBlockBreak.lsp | Version 1.4 | ?Lee Mac 2011 www.lee-mac.com ::")
(princ "\n:: Type \"ABB\" to insert & break or \"ABBE\"/\"ABBS\" to break existing ::")
(princ)
;;------------------------------------------------------------;;
;; End of File ;;
;;------------------------------------------------------------;;

;;----------------=={ Automatic Block Break }==---------------;; 
;;                                                            ;; 
;;  Prompts user for selection of a block, then point for     ;; 
;;  insertion.                                                ;; 
;;                                                            ;; 
;;  If a curve is detected at the selected point, the         ;; 
;;  inserted block is rotated to align with the curve.        ;; 
;;                                                            ;; 
;;  All surrounding objects found to intersect with the block ;; 
;;  are then trimmed to the rectangular block outline.        ;; 
;;                                                            ;; 
;;  Program works in all views & UCS.                         ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ?2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Version 1.0    -    22.11.2010                            ;; 
;;                                                            ;; 
;;  First Release.                                            ;; 
;;------------------------------------------------------------;; 
;;  Version 1.1    -    07.02.2011                            ;; 
;;                                                            ;; 
;;  Entire program rewritten to allow subfunction to be       ;; 
;;  called with block object argument.                        ;; 
;;  Multiple intersecting objects are trimmed.                ;; 
;;------------------------------------------------------------;; 
;;  Version 1.2    -    08.02.2011                            ;; 
;;                                                            ;; 
;;  Changed block insertion to VL InsertBlock method.         ;; 
;;  Added calling function to trim a block in-situ (ABBE).    ;; 
;;------------------------------------------------------------;; 
;;  Version 1.3    -    03.08.2011                            ;; 
;;                                                            ;; 
;;  Altered method to create bounding polyline to exclude     ;; 
;;  attributes when trimming objects surrounding block.       ;; 
;;  Objects surrounding blocks whose insertion point does not ;; 
;;  lie on a curve are now also trimmed.                      ;; 
;;------------------------------------------------------------;; 
;;  Version 1.4    -    30.09.2011                            ;; 
;;                                                            ;; 
;;  Added option to enable/disable automatic block rotation.  ;; 
;;  Updated code formatting.                                  ;; 
;;------------------------------------------------------------;; 
 
(defun c:ABB ( / *error* _StartUndo _EndUndo acspc block obj pt sel ) 
 
    (defun *error* ( msg ) 
        (if acdoc (_EndUndo acdoc)) 
        (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")) 
            (princ (strcat "\nError: " msg)) 
        ) 
        (princ) 
    ) 
 
    (defun _StartUndo ( doc ) 
        (_EndUndo doc) 
        (vla-StartUndoMark doc) 
    ) 
 
    (defun _EndUndo ( doc ) 
        (if (= 8 (logand 8 (getvar 'UNDOCTL))) 
            (vla-EndUndoMark doc) 
        ) 
    ) 
 
    (setq acdoc (cond (acdoc) ((vla-get-activedocument (vlax-get-acad-object)))) 
          acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'paperspace 'modelspace)) 
    ) 
    (if 
        (and 
            (progn 
                (while 
                    (progn (setvar 'ERRNO 0) (initget "Browse Rotation") 
                        (princ (strcat "\nAutomatic Block Rotation: " (getenv "LMac\\ABBRotation"))) 
                        (setq sel 
                            (entsel 
                                (strcat "\nSelect Block [Browse/Rotation]" 
                                    (if (eq "" (setq block (getvar 'INSNAME))) ": " (strcat " <" block "> : ")) 
                                ) 
                            ) 
                        ) 
                        (cond 
                            (   (= 7 (getvar 'ERRNO)) 
                                (princ "\nMissed, Try Again.") 
                            ) 
                            (   (not sel) 
                                (if (eq "" block) (setq block nil)) 
                            ) 
                            (   (eq "Rotation" sel) 
                                (initget "ON OFF") 
                                (setenv "LMac\\ABBRotation" 
                                    (cond 
                                        ( 
                                            (getkword 
                                                (strcat "\nAutomatic Block Rotation [ON/OFF] <" 
                                                    (getenv "LMac\\ABBRotation") ">: " 
                                                ) 
                                            ) 
                                        ) 
                                        (   (getenv "LMac\\ABBRotation")   ) 
                                    ) 
                                ) 
                            ) 
                            (   (eq "Browse" sel) 
                                (setq block (getfiled "Select Block" "" "dwg" 16)) 
                                nil 
                            ) 
                            (   (listp sel) 
                                (if (not (eq "INSERT" (cdr (assoc 0 (entget (car sel)))))) 
                                    (princ "\nObject Must be a Block.") 
                                    (not (setq obj (vla-copy (vlax-ename->vla-object (car sel))))) 
                                ) 
                            ) 
                        ) 
                    ) 
                ) 
                block 
            ) 
            (setq pt (getpoint "\nSpecify Point for Block: ")) 
            (or obj 
                (setq obj 
                    (vla-InsertBlock acspc (vlax-3D-point (trans pt 1 0)) block 1. 1. 1. 
                        (angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 (trans '(0. 0. 1.) 1 0 t) t)) 
                    ) 
                ) 
            ) 
        ) 
        (progn 
            (_StartUndo acdoc) 
            (if block (setvar 'INSNAME (vl-filename-base block))) 
            (vla-put-InsertionPoint obj (vlax-3D-point (trans pt 1 0))) 
            (LM:AutoBlockBreak obj (eq "ON" (getenv "LMac\\ABBRotation"))) 
            (_EndUndo acdoc) 
        ) 
    ) 
    (princ) 
) 
 
;;------------=={ Automatic Block Break Existing }==----------;; 
;;                                                            ;; 
;;  Prompts user for selection of a block and, if a curve is  ;; 
;;  detected at the block insertion point, the block is       ;; 
;;  rotated to align with the curve. All objects found to     ;; 
;;  intersect with the block are then trimmed to the          ;; 
;;  rectangular block outline.                                ;; 
;;                                                            ;; 
;;  Program works in all views & UCS.                         ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ?2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
 
(defun c:ABBE ( / sel ) 
    (while 
        (progn 
            (setvar 'ERRNO 0) 
            (initget "Rotation") 
            (princ (strcat "\nAutomatic Block Rotation: " (getenv "LMac\\ABBRotation"))) 
            (setq sel (entsel "\nSelect Block to Trim [Rotation]: ")) 
            (cond 
                (   (= 7 (getvar 'ERRNO)) 
                    (princ "\nMissed, Try Again.") 
                ) 
                (   (eq "Rotation" sel) 
                    (initget "ON OFF") 
                    (setenv "LMac\\ABBRotation" 
                        (cond 
                            ( 
                                (getkword 
                                    (strcat "\nAutomatic Block Rotation [ON/OFF] <" 
                                        (getenv "LMac\\ABBRotation") ">: " 
                                    ) 
                                ) 
                            ) 
                            (   (getenv "LMac\\ABBRotation")   ) 
                        ) 
                    ) 
                ) 
                (   (eq 'ENAME (type (car sel))) 
                    (if (eq "INSERT" (cdr (assoc 0 (entget (car sel))))) 
                        (LM:AutoBlockBreak (car sel) (eq "ON" (getenv "LMac\\ABBRotation"))) 
                        (princ "\nInvalid Object Selected.") 
                    ) 
                    t 
                ) 
            ) 
        ) 
    ) 
    (princ) 
) 
 
;;-----------=={ Automatic Block Break Selection }==----------;; 
;;                                                            ;; 
;;  Prompts user for selection of a set of blocks and, if a   ;; 
;;  curve is detected at each block insertion point, the      ;; 
;;  block is rotated to align with the curve. All objects     ;; 
;;  found to intersect with the block are then trimmed to the ;; 
;;  rectangular block outline.                                ;; 
;;                                                            ;; 
;;  Program works in all views & UCS.                         ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ?2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
 
(defun c:ABBS ( / ss i ) 
    (if (setq ss (ssget "_:L" '((0 . "INSERT")))) 
        (repeat (setq i (sslength ss)) 
            (LM:AutoBlockBreak (ssname ss (setq i (1- i))) (eq "ON" (getenv "LMac\\ABBRotation"))) 
        ) 
    ) 
    (princ) 
) 
 
;;----------=={ Automatic Block Break SubFunction }==---------;; 
;;                                                            ;; 
;;  Takes a block reference argument and trims surrounding    ;; 
;;  geometry if curve is detected at the insertion point of   ;; 
;;  the block.                                                ;; 
;;                                                            ;; 
;;  If a curve is detected, the block is rotated to align     ;; 
;;  with the curve and all  objects found to intersect with   ;; 
;;  the block are trimmed to the rectangular block outline.   ;; 
;;                                                            ;; 
;;  Program works in all views & UCS.                         ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ?2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  block - EName or VLA-Object of Block Reference object     ;; 
;;------------------------------------------------------------;; 
 
(defun LM:AutoBlockBreak 
 
    ( block rotate / *error* _GetFurthestApart acspc bbx brk cmd crv en ent enx int lst mat nme ply pt ss x ) 
 
    (defun *error* ( msg ) 
        (if (and ply (not (vlax-erased-p ply))) (vla-delete ply)) 
        (if cmd  (setvar 'CMDECHO cmd)) 
        (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")) 
            (princ (strcat "\nError: " msg)) 
        ) 
        (princ) 
    ) 
 
    (defun _GetFurthestApart ( lst / mx p1 p2 ds rslt ) 
        (setq mx 0.0) 
        (while (setq p1 (car lst)) 
            (foreach p2 (setq lst (cdr lst)) 
                (if (< mx (setq ds (distance p1 p2))) (setq mx ds rslt (list p1 p2))) 
            ) 
        ) 
        rslt 
    ) 
 
    (setq cmd (getvar 'CMDECHO)) 
    (setvar 'CMDECHO 0) 
 
    (setq acdoc (cond (acdoc) ((vla-get-activedocument (vlax-get-acad-object)))) 
          acblk (cond (acblk) ((vla-get-blocks acdoc))) 
          acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'paperspace 'modelspace)) 
    ) 
   
    (if 
        (and 
            (setq ent 
                (cond 
                    (   (eq 'ENAME (type block)) 
                        block 
                    ) 
                    (   (eq 'VLA-OBJECT (type block)) 
                        (vlax-vla-object->ename block) 
                    ) 
                ) 
            ) 
            (setq enx (entget ent)) 
            (eq "INSERT" (cdr (assoc 0 enx))) 
        ) 
        (progn 
            (if rotate 
                (progn 
                    (setq pt (cdr (assoc 10 enx))) 
                    (if 
                        (setq ss 
                            (ssget "_C" 
                                (polar (trans pt ent 1) (/       pi -4.) 1e-4) 
                                (polar (trans pt ent 1) (/ (* 3. pi) 4.) 1e-4) 
                               '((0 . "~INSERT,ARC,ELLIPSE,CIRCLE,*LINE")) 
                            ) 
                        ) 
                        (progn (setq crv (ssname ss 0)) 
                            (entupd 
                                (cdr 
                                    (assoc -1 
                                        (entmod 
                                            (subst 
                                                (cons 50 
                                                    (LM:MakeReadable 
                                                        (angle '(0. 0. 0.) 
                                                            (trans 
                                                                (vlax-curve-getFirstDeriv crv 
                                                                    (vlax-curve-getParamatPoint crv 
                                                                        (vlax-curve-getClosestPointto crv (trans pt ent 0)) 
                                                                    ) 
                                                                ) 
                                                                0 crv 
                                                            ) 
                                                        ) 
                                                    ) 
                                                ) 
                                                (assoc 50 enx) enx 
                                            ) 
                                        ) 
                                    ) 
                                ) 
                            ) 
                        ) 
                    ) 
                ) 
            ) 
            (setq nme (cdr (assoc 2 enx)) 
                  mat (RefGeom ent) 
            ) 
            (setq bbx 
                (mapcar '(lambda ( x ) (mapcar '+ (mxv (car mat) x) (cadr mat))) 
                    (cond 
                        (   (cdr (assoc nme *blockboundingboxes*))   ) 
                        (   (cdar 
                                (setq *blockboundingboxes* 
                                    (cons 
                                        (cons nme (LM:BlockDefinitionBoundingBox acblk nme)) *blockboundingboxes* 
                                    ) 
                                ) 
                            ) 
                        ) 
                    ) 
                ) 
            ) 
            (if 
                (setq ss 
                    (ssget "_C" 
                        (trans (car   bbx) 0 1) 
                        (trans (caddr bbx) 0 1) 
                       '((0 . "~INSERT,ARC,ELLIPSE,CIRCLE,*LINE")) 
                    ) 
                ) 
                (progn 
                    (vla-put-closed (setq ply (vlax-invoke acspc 'add3dpoly (apply 'append bbx))) :vlax-true) 
                    (while (setq en (ssname ss 0)) 
                        (if (setq int (LM:GroupByNum (vlax-invoke (vlax-ename->vla-object en) 'IntersectWith ply acExtendThisEntity) 3)) 
                            (setq lst (cons (cons en int) lst)) 
                        ) 
                        (ssdel en ss) 
                    ) 
                    (vla-delete ply) 
                    (foreach int lst 
                        (setq brk (_GetFurthestApart (cdr int))) 
                        (command 
                            "_.break" (list  (car int) (trans (car brk) 0 1)) "_F" 
                               "_non" (trans (car  brk) 0 1) 
                               "_non" (trans (cadr brk) 0 1) 
                        ) 
                    ) 
                ) 
            ) 
        ) 
    ) 
    (setvar 'CMDECHO cmd) 
    (princ) 
) 
 
;;-------------=={ Block Definition BoundingBox }==-----------;; 
;;                                                            ;; 
;;  Returns a point list describing a rectangular frame       ;; 
;;  bounding all objects in a block definition.               ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ?2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  blocks - The Block Collection in which the block resides  ;; 
;;  block  - The name of the block                            ;; 
;;------------------------------------------------------------;; 
;;  Returns: Point list describing boundingbox of definition  ;; 
;;------------------------------------------------------------;; 
 
(defun LM:BlockDefinitionBoundingBox ( blocks block / l1 l2 ll ur ) 
    (vlax-for obj (vla-item blocks block) 
        (if 
            (and 
                (vlax-method-applicable-p obj 'getboundingbox) 
                (not (eq "AcDbAttributeDefinition" (vla-get-objectname obj))) 
            ) 
            (if 
                (not 
                    (vl-catch-all-error-p 
                        (vl-catch-all-apply 'vla-getboundingbox (list obj 'll 'ur)) 
                    ) 
                ) 
                (setq l1 (cons (vlax-safearray->list ll) l1) 
                      l2 (cons (vlax-safearray->list ur) l2) 
                ) 
            ) 
        ) 
    ) 
    (if l1 
        ( 
            (lambda ( boundingbox ) 
                (mapcar 
                    (function 
                        (lambda ( _functionlist ) 
                            (mapcar 
                                (function 
                                    (lambda ( _function ) ((eval _function) boundingbox)) 
                                ) 
                                _functionlist 
                            ) 
                        ) 
                    ) 
                   '((caar cadar) (caadr cadar) (caadr cadadr) (caar cadadr)) 
                ) 
            ) 
            (list 
                (apply 'mapcar (cons 'min l1)) 
                (apply 'mapcar (cons 'max l2)) 
            ) 
        ) 
    ) 
) 
 
;; RefGeom (gile) 
;; Returns a list which first item is a 3x3 transformation matrix (rotation, 
;; scales, normal) and second item the object insertion point in its parent 
;; (xref, block or space) 
;; 
;; Argument : an ename 
 
(defun RefGeom ( ename / elst ang norm mat ) 
    (setq  elst (entget ename) 
          ang  (cdr (assoc 50 elst)) 
          norm (cdr (assoc 210 elst)) 
    ) 
    (list 
        (setq mat 
            (mxm 
                (mapcar '(lambda ( v ) (trans v 0 norm T)) 
                   '( 
                        (1.0 0.0 0.0) 
                        (0.0 1.0 0.0) 
                        (0.0 0.0 1.0) 
                    ) 
                ) 
                (mxm 
                    (list 
                        (list (cos ang) (- (sin ang)) 0.0) 
                        (list (sin ang) (cos ang)     0.0) 
                        (list    0.0       0.0        1.0) 
                    ) 
                    (list 
                        (list (cdr (assoc 41 elst)) 0.0 0.0) 
                        (list 0.0 (cdr (assoc 42 elst)) 0.0) 
                        (list 0.0 0.0 (cdr (assoc 43 elst))) 
                    ) 
                ) 
            ) 
        ) 
        (mapcar '- (trans (cdr (assoc 10 elst)) norm 0) 
            (mxv mat (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst)))))) 
        ) 
    ) 
) 
 
;; 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)) 
 
;; 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))) 
 
;;-----------------=={ Group by Number }==--------------------;; 
;;                                                            ;; 
;;  Groups a list into a list of lists, each of length 'n'    ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ?2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  l - List to process                                       ;; 
;;  n - Number of elements by which to group the list         ;; 
;;------------------------------------------------------------;; 
;;  Returns:  List of lists, each of length 'n'               ;; 
;;------------------------------------------------------------;; 
 
(defun LM:GroupByNum ( l n / r) 
    (if l 
        (cons 
            (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r)) 
            (LM:GroupByNum l n) 
        ) 
    ) 
) 
 
;;-------------------=={ Make Readable }==--------------------;; 
;;                                                            ;; 
;;  Returns an angle corrected for text readability           ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ?2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  a - angle to process                                      ;; 
;;------------------------------------------------------------;; 
;;  Returns:  angle corrected for text readability            ;; 
;;------------------------------------------------------------;; 
 
(defun LM:MakeReadable ( a ) 
    (   (lambda ( a ) (if (and (< (/ pi 2.0) a) (<= a (/ (* 3.0 pi) 2.0))) (+ a pi) a)) 
        (rem (+ a pi pi) (+ pi pi)) 
    ) 
) 
 
;;------------------------------------------------------------;; 
 
(if (null (getenv "LMac\\ABBRotation")) 
    (setenv "LMac\\ABBRotation" "ON") 
) 
 
;;------------------------------------------------------------;; 
 
(vl-load-com) (princ) 
(princ "\n:: AutoBlockBreak.lsp | Version 1.4 | ?Lee Mac 2011 <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a> ::") 
(princ "\n:: Type \"ABB\" to insert & break or \"ABBE\"/\"ABBS\" to break existing ::") 
(princ) 
 
;;------------------------------------------------------------;; 
;;                        End of File                         ;; 
;;------------------------------------------------------------;;

tjuzkj · 发表于 2013-1-2 08:49:38

不错，挺实用

hrbustmqc · 发表于 2015-5-24 21:13:03

11楼的朋友，谢谢，代码已下载。

jkop · 发表于 2023-6-28 18:32:50

3、4、11楼的程序内容都很实用，虽然有功能重叠，都能做为学习的依据，感谢分享。

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