非常好的例子
;;----------------=={ 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 "
(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 <"
(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 : "))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nMissed, Try Again.")
)
( (eq "Rotation" sel)
(initget "ON OFF")
(setenv "LMac\\ABBRotation"
(cond
(
(getkword
(strcat "\nAutomatic Block Rotation <"
(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 allobjects 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 (carbrk) 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 )
(setqelst (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 ;;
;;------------------------------------------------------------;;
不错，挺实用 11楼的朋友，谢谢，代码已下载。 3、4、11楼的程序内容都很实用，虽然有功能重叠，都能做为学习的依据，感谢分享。
页:
1
[2]