请教大咖帮忙，修改外围框程序
本人lisp刚刚了解，请教大咖帮忙，修改外围框程序，框选块，生成单个的外围框，谢谢！;; Minimum Bounding Box-Lee Mac
;; Returns the WCS coordinates describing the minimum bounding rectangle
;; surrounding all objects in a supplied selection set.
;; sel - selection set to process
;; tol - precision of calculation, 0 < tol < 1
;;http://lee-mac.com/minboundingbox.html
(defun LM:minboundingbox ( sel tol / ang box bx1 bx2 cen idx lst obj rtn )
(if (and sel (< 0.0 tol 1.0))
(progn
(repeat (setq idx (sslength sel))
(setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
(if (and (vlax-method-applicable-p obj 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b))))
)
(setq lst (cons (vla-copy obj) lst))
)
)
(if lst
(progn
(setq box (LM:objlstboundingbox lst)
tol (* tol pi)
cen (apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.0)) box))
bx1 (* (- (caadr box) (caar box)) (- (cadadr box) (cadar box)))
rtn (list 0.0 box)
ang 0.0
)
(while (< (setq ang (+ ang tol)) pi)
(foreach obj lst (vlax-invoke obj 'rotate cen tol))
(setq box (LM:objlstboundingbox lst)
bx2 (* (- (caadr box) (caar box)) (- (cadadr box) (cadar box)))
)
(if (< bx2 bx1)
(setq bx1 bx2
rtn (list ang box)
)
)
)
(foreach obj lst (vla-delete obj))
(LM:rotatepoints
(mapcar '(lambda ( a ) (mapcar '(lambda ( b ) (apply b (cdr rtn))) a))
'(
(caar cadar)
(caadrcadar)
(caadr cadadr)
(caarcadadr)
)
)
cen (- (car rtn))
)
)
)
)
)
)
;; Object List Bounding Box-Lee Mac
;; Returns the lower-left and upper-right points of a rectangle bounding a list of objects
(defun LM:objlstboundingbox ( lst / llp ls1 ls2 urp )
(foreach obj lst
(vla-getboundingbox obj 'llp 'urp)
(setq ls1 (cons (vlax-safearray->list llp) ls1)
ls2 (cons (vlax-safearray->list urp) ls2)
)
)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
)
;; Rotate Points-Lee Mac
;; Rotates a list of points about a supplied point by a given angle
(defun LM:rotatepoints ( lst bpt ang / mat vec )
(setq mat
(list
(list (cos ang) (sin (- ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
)
(setq vec (mapcar '- bpt (mxv mat bpt)))
(mapcar '(lambda ( x ) (mapcar '+ (mxv mat x) vec)) lst)
)
;; 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)
)
(defun c:test ( / sel )
(if (setq sel (ssget "_:L"))
(entmake
(append
'(
(000 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(090 . 4)
(070 . 1)
)
(mapcar '(lambda ( p ) (cons 10 p)) (LM:minboundingbox sel 0.01))
)
)
)
(princ)
)
(vl-load-com) (princ)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
上面的源代码地址 http://lee-mac.com/minboundingbox.html 请教大咖，帮忙修改一下，批量的一个一个的绘制外框，万分感谢！！！！！
页:
[1]