[已经解决]获取对象包围盒、最小包围盒-----(也适于UCS)
本帖最后由 自贡黄明儒 于 2013-10-8 14:55 编辑第三版===================================================================
**** Hidden Message *****
第二版===================================================================
;;[功能] 图元当前坐标系下包围盒,4角点坐标
;|
4 = 左上；3 = 右上
1 = 左下；2 = 右下
|;
;;Flag : T时，返回最小包围盒角点；nil时，返回包围盒角点
;;说明 1 使用前加载须加载highflybird的程序Matrix-Lib.LSP
;; 2 作者保留本程序的一切权利，但你可以自由拷贝与复制、修改本程序用于非商业目的。
;; 3 自贡黄明儒 2013年9月27日
**** Hidden Message *****
第一版===================================================================
;;看了highflybird的矩阵和trans，实在没有悟透，请高手们出手，如何获取UCS下旋转过的对象的四个角点，在此首先表示感谢！！
;;主要是想用于求最小包围盒，以便对任何对象画中心线
;;[功能] 图元当前坐标系下包围盒,4角点坐标
;|
4 = 左上；3 = 右上
1 = 左下；2 = 右下
|;
;;Flag : T时，返回最小包围盒角点；nil时，返回包围盒角点
;;说明 1 使用前加载须加载highflybird的程序Matrix-Lib.LSP
;; 2 本程序是在G版的帮助和烧糊了一锅稀饭的代价下，试验出来的
;; 3 本程序是在highflybird选择集最小包围盒基础上发展而来
;; 4 不足之处是用了command,有待改善
;; 5 自贡黄明儒 2013年9月19日 中秋节
;; 6 使用者须保留以上信息
;;示例(HH:Ent4pt (car (entsel)) T),返回UCS坐标系下坐标
(defun HH:Ent4pt (ent Flag / ENT LST MATLSTMATRIXMAXPT MINPT
OBJ ORIGINREVMATUCSFLAG WCSORGX XDIR YDIR ZDIR
)
;;1 矩阵的变换与逆变换
(defun GetMatrix (lst org Revflag / I J MAT)
(setq mat (vlax-make-safearray vlax-vbDouble '(0 . 3) '(0 . 3)))
(setq i 0)
(repeat 3
(vlax-safearray-put-element mat i 3 (nth i org)) ;平移变换
(setq j 0)
(repeat 3
(if RevFlag
(vlax-safearray-put-element mat i j (nth j (nth i lst))) ;角度逆变换
(vlax-safearray-put-element mat i j (nth i (nth j lst))) ;角度的变换
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(vlax-safearray-put-element mat 3 3 1)
mat ;返回矩阵
)
;;2 本程序主程序
(cond ((= (type ent) 'ENAME)
(setq obj (vlax-ename->vla-object ent))
)
((= (type ent) 'VLA-OBJECT) (setq obj ent))
(T (exit))
)
(and Flag (command "_.UCS" "NEW" "Object" ent))
;;先判断UCS是否与WCS相同。如是则取得UCS的X方向，
;;Y方向，Z方向，UCS原点及WCS的原点相对UCS的坐标点
;;然后得到UCS变换矩阵和到WCS的逆变换矩阵
(setq UcsFlag (getvar "WORLDUCS"))
(if (= UcsFlag 0) ;UCS与WCS不同
(setq UcsFlag T ;设置标志位为true
xdir (getvar "UCSXDIR") ;X方向矢量
ydir (getvar "UCSYDIR") ;Y方向矢量
zdir (MAT:vxv xdir ydir) ;X和Y的方向矢量的叉积
origin(getvar "UCSORG") ;原点
WcsOrg(trans '(0 0 0) 0 1) ;WCS的原点相对UCS的坐标
matLst(list xdir ydir zdir) ;旋转的变换矩阵表
matrix(GetMatrix matLst origin nil) ;从WCS到UCS(ocs)的变换矩阵
revMat(GetMatrix matLst WcsOrg T) ;从UCS(ocs)到WCS的变换矩阵
)
(setq UcsFlag nil) ;否则不予变换
)
;;在UCS下先变换物体到WCS下，取得物体的包围框，然后把物体变换回到UCS，并把矩形也变换回去
(and UcsFlag (vla-TransformBy obj revMat)) ;反变换到WCS
(vla-GetBoundingBox obj 'minPt 'maxPt) ;得到包围框
(setq minPt (vlax-safearray->list minPt))
;;(setq minPt (trans minPt ent 1))
(setq maxPt (vlax-safearray->list maxPt))
(and UcsFlag (vla-TransformBy obj matrix)) ;变换回到UCS
(and Flag (command "_.UCS" "p"))
(and UcsFlag (setq matrix (vlax-safearray->list matrix)))
(setq lst (list minPt
(list (car maxPt) (cadr minpt) (caddr minPt))
maxPt
(list (car minpt) (cadr maxPt) (caddr minPt))
)
) ;ocs坐标?
(and UcsFlag
(setq lst (mapcar '(lambda (x) (mat:mxp matrix x)) lst)) ;wcs坐标
(setq lst (mapcar '(lambda (x) (trans x ent 1)) lst)) ;ucs坐标
)
lst
)
;;下面的代码可以验证
;;148.1 [功能] 根据点表画多段线
(defun draw-pline1 (pts)
(command "_PLINE")
(mapcar 'command pts)
(command "c")
)
;;(draw-pline(HH:Ent4pt (car (entsel)) T))
;;(draw-pline(HH:Ent4pt (car (entsel)) nil))
;;----------------=={ Minimum Bounding Box }==----------------;;
;; ;;
;;Returns the coordinates of the minimum bounding rectangle ;;
;;surrounding objects in a supplied selection set ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;ss - selection set to process ;;
;;pr - precision of calculation, 0 < pr < 1 ;;
;;------------------------------------------------------------;;
;;Returns: coordinates of minimum rectangle framing objects ;;
;;------------------------------------------------------------;;
(defun LM:MinBoundingBox ( ss pr / an ba bb bm cn cv i l mb )
(if ss
(progn
(setq bb
(LM:ListBoundingBox
(repeat (setq i (sslength ss))
(setq l (cons (vla-copy (vlax-ename->vla-object (ssname ss (setq i (1- i))))) l))
)
)
)
(setq pr (* pr pi)
cn (apply 'mapcar (cons (function (lambda ( a b ) (/ (+ a b) 2.0))) bb))
cv (vlax-3D-point cn)
bm (* (- (caadr bb) (caar bb)) (- (cadadr bb) (cadar bb)))
mb (cons 0.0 bb)
an 0
)
(while (< (setq an (+ an pr)) pi)
(foreach x l (vla-rotate x cv pr))
(setq bb (LM:ListBoundingBox l)
ba (* (- (caadr bb) (caar bb)) (- (cadadr bb) (cadar bb)))
)
(if (< ba bm) (setq bm ba mb (cons an bb)))
)
(foreach x l (vla-delete x))
(LM:RotatePointsByMatrix
(mapcar
(function
(lambda ( a )
(mapcar (function (lambda ( b ) ((eval b) (cdr mb)))) a)
)
)
'((caar cadar) (caadr cadar) (caadr cadadr) (caar cadadr))
)
cn (- (car mb))
)
)
)
)
;;------------------=={ List BoundingBox }==------------------;;
;; ;;
;;Returns the coordinates of a rectangle framing all ;;
;;objects in a supplied list ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;lst - list of VLA-Objects to process ;;
;;------------------------------------------------------------;;
;;Returns:coordinates of rectangle framing objects ;;
;;------------------------------------------------------------;;
(defun LM:ListBoundingBox ( lst / l1 l2 ll ur )
(foreach obj lst
(vla-getboundingbox obj 'll 'ur)
(setq l1 (cons (vlax-safearray->list ll) l1)
l2 (cons (vlax-safearray->list ur) l2)
)
)
(mapcar
(function (lambda ( a b ) (apply 'mapcar (cons a b))))
'(min max) (list l1 l2)
)
)
;;--------------=={ Rotate Points by Matrix }==---------------;;
;; ;;
;;Performs a Rotation transformation on a list of points ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ? 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;l - list of points to be rotated ;;
;;p - base point for rotation (in CS of Point List) ;;
;;a - angle of rotation ;;
;;------------------------------------------------------------;;
(defun LM:RotatePointsByMatrix ( l p a / m )
(setq m
(list
(list (cos a) (sin (- a)) 0.0)
(list (sin a) (cos a) 0.0)
(list 0.0 0.0 1.0)
)
)
(setq p (mapcar '- p (mxv m p)))
(mapcar (function (lambda ( x ) (mapcar '+ (mxv m x) p))) l)
)
;; 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 ( / s )
(if (setq s (ssget "_:L"))
(entmakex
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 4)
(cons 70 1)
)
(mapcar '(lambda ( p ) (cons 10 p)) (LM:MinBoundingBox s 0.01))
)
)
)
(princ)
) 最近在做批量转PDF ,被这个包围盒折腾蒙了，请教一下，这个同用trans pt 0 2 区别是什么，我用这个方法，程序调试也通过了，谢谢指点
;;返回Text、 MText的左下角点 右下角点 右上角点 左上角点
(defun getTextBox (EN / ENX L B R N W H J O)
(cond
((= 'VLA-OBJECT (type en))
(setq enx (entget (vlax-vla-object->ename en)))
)
((= 'ename (type en)) (setq enx (entget en)))
((= 'list (type en)) (setq enx en))
)
(setq l
(cond
((= "TEXT" (cdr (assoc 0 enx)))
(setq b (cdr (assoc 10 enx))
r (cdr (assoc 50 enx))
l (textbox enx)
n (cdr (assoc 210 enx))
)
(list
(list (caar l) (cadar l))
(list (caadr l) (cadar l))
(list (caadr l) (cadadr l))
(list (caar l) (cadadr l))
)
)
((= "MTEXT" (cdr (assoc 0 enx)))
(setq n (cdr (assoc 210 enx))
b (trans (cdr (assoc 10 enx)) 0 n)
r (angle '(0.0 0.0 0.0) (trans (cdr (assoc 11 enx)) 0 n))
w (cdr (assoc 42 enx))
h (cdr (assoc 43 enx))
j (cdr (assoc 71 enx))
o (list
(cond
((member j '(2 5 8)) (/ w -2.0))
((member j '(3 6 9)) (- w))
(0.0)
)
(cond
((member j '(1 2 3)) (- h))
((member j '(4 5 6)) (/ h -2.0))
(0.0)
)
)
)
(list
(list (car o) (cadr o))
(list (+ (car o) w) (cadr o))
(list (+ (car o) w) (+ (cadr o) h))
(list (car o) (+ (cadr o) h))
)
)
)
)
(setq l
((lambda (m)
(mapcar
'(lambda (p)
(mapcar '+
(mapcar '(lambda (r) (apply '+ (mapcar '* r p))) m)
b
)
)
l
)
)
(list
(list (cos r) (sin (- r)) 0.0)
(list (sin r) (cos r) 0.0)
'(0.0 0.0 1.0)
)
)
)
(mapcar '(lambda (x) (trans x n 0)) l)
) Gu_xl 发表于 2013-9-17 16:24 static/image/common/back.gif
非常感谢信G版，这么快就搞定了。请问对矩形，块有效吗？ 自贡黄明儒 发表于 2013-9-17 16:27 static/image/common/back.gif
非常感谢信G版，这么快就搞定了。请问对矩形，块有效吗？
只针对文字！ 自贡黄明儒 发表于 2013-9-17 16:27 static/image/common/back.gif
非常感谢信G版，这么快就搞定了。请问对矩形，块有效吗？
其他实体的可搜索高飞鸟的凸包、最小包围盒等帖子， Gu_xl 发表于 2013-9-17 16:34 static/image/common/back.gif
其他实体的可搜索高飞鸟的凸包、最小包围盒等帖子，
高飞鸟的最小包围盒，他是画了一个矩形，最后用一句(vla-TransformBy (vlax-ename->vla-object (entlast)) matrix),如果再获取矩形的四角角点，但好象不太好
;;下面这段代码是用Highflybird的包围盒改的。
(defun c:w1 (/ ENT I MATLST MATRIX OBJ ORIGIN REVMAT SEL UCSFLAG WCSORG XDIR YDIR
ZDIR)
;;矩阵的变换与逆变换
(defun GetMatrix (lst org Revflag / mat i j)
(setq mat (vlax-make-safearray vlax-vbDouble '(0 . 3) '(0 . 3)))
;初始化一个4X4的矩阵
(setq i 0)
(repeat 3
(vlax-safearray-put-element mat i 3 (nth i org)) ;平移变换
(setq j 0)
(repeat 3
(if RevFlag
(vlax-safearray-put-element mat i j (nth j (nth i lst))) ;角度逆变换
(vlax-safearray-put-element mat i j (nth i (nth j lst))) ;角度的变换
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(vlax-safearray-put-element mat 3 3 1)
mat ;返回矩阵
)
;;构造矩形
(defun Make-Rectange (pt1 pt2)
(entmake
(list
'(0 . "LWPOLYLINE") ;轻多段线
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4) ;四个顶点
'(70 . 1) ;闭合
(cons 38 (caddr pt1)) ;高程
(cons 10 (list (car pt1) (cadr pt1))) ;左下角
(cons 10 (list (car pt2) (cadr pt1))) ;右下角
(cons 10 (list (car pt2) (cadr pt2))) ;右上角
(cons 10 (list (car pt1) (cadr pt2))) ;左上角
(cons 210 '(0 0 1)) ;法线方向
)
)
)
;;在UCS下先变换物体到WCS下，取得每个物体的包围框，
;;求出包围框集合的最小XY，最大XY，并用矩形框画出来
;;然后把物体变换回到UCS，并把矩形也变换回去
(if (setq ent (car (entsel)))
;;选择物体
(progn
(setq minPt (vlax-make-safearray vlax-vbdouble '(0 . 2))) ;左下角点
(setq maxPt (vlax-make-safearray vlax-vbdouble '(0 . 2))) ;右上角点
(command "_.UCS" "NEW" "Object" ent)
;;先判断UCS是否与WCS相同。如是则取得UCS的X方向，
;;Y方向，Z方向，UCS原点及WCS的原点相对UCS的坐标点
;;然后得到UCS变换矩阵和到WCS的逆变换矩阵
(setq UcsFlag (getvar "WORLDUCS"))
(if (= UcsFlag 0) ;UCS是否与WCS相同
(setq UcsFlag T ;设置标志位为true
xdir (getvar "UCSXDIR") ;X方向矢量
ydir (getvar "UCSYDIR") ;Y方向矢量
zdir (MAT:vxv xdir ydir) ;X和Y的方向矢量的叉积
origin(getvar "UCSORG") ;原点
WcsOrg(trans '(0 0 0) 0 1) ;WCS的原点相对UCS的坐标
matLst(list xdir ydir zdir) ;旋转的变换矩阵表
matrix(GetMatrix matLst origin nil) ;从WCS到UCS的变换矩阵
revMat(GetMatrix matLst WcsOrg T) ;从UCS到WCS的变换矩阵
)
(setq UcsFlag nil) ;否则不予变换
)
(setq obj (vlax-ename->vla-object ent)) ;obj对象
(and UcsFlag (vla-TransformBy obj revMat));反变换到WCS
(vla-GetBoundingBox obj 'minpt 'maxpt) ;得到包围框
(setq minPt (vlax-safearray->list minPt))
(setq maxPt (vlax-safearray->list maxPt))
(and UcsFlag (vla-TransformBy obj matrix));变换回到UCS
(command "_.UCS" "P")
(and
(make-Rectange minPt maxPt) ;构造边框
UcsFlag ;如果UCS的话
(vla-TransformBy (vlax-ename->vla-object (entlast)) matrix)
)
)
)
(princ)
)
本帖最后由 自贡黄明儒 于 2013-9-17 16:47 编辑
我是想直接取得对象的四个角点，而且是通用的。
确又搞不定 自贡黄明儒 发表于 2013-9-17 16:46 static/image/common/back.gif
我是想直接取得对象的四个角点，而且是通用的。
确又搞不定
呵呵，高飞鸟的矩阵运算必须要学会呦！ 本帖最后由 namezg 于 2013-9-18 21:04 编辑
最近刚写的
;包围盒转四角点列表wcs
;box--包围盒wcs
(defun zg-BoundingBox->List (box / pt1 pt2 pt3 pt4)
(setq pt1 (car box))
(setq pt3 (cadr box))
(setq pt2 (list (car pt3) (cadr pt1) (caddr pt1)))
(setq pt4 (list (car pt1) (cadr pt3) (caddr pt1)))
(list pt1 pt2 pt3 pt4)
)
;功能：从一个坐标系统到另一个坐标系统的变换矩阵
;参数：from -- 源坐标系统 整数代码 0 世界坐标系（WCS） 1 用户坐标系（当前 UCS）
; to -- 目标坐标系统 整数代码0 世界坐标系（WCS） 1 用户坐标系（当前 UCS）
;返回值：(list 源坐标系统->目标坐标系统的变换矩阵 目标坐标系统->源坐标系统的变换矩阵)
(defun zg-matrix-trans (from to / RMat Disp InvRMat InvDisp)
(setq RMat
(mapcar
'(lambda (v) (trans v from to t))
'((1. 0. 0.) (0. 1. 0.) (0. 0. 1.))
)
)
(setq Disp (trans '(0. 0. 0.) to from))
(setq InvRMat (apply 'mapcar (cons 'list RMat)))
(setq InvDisp (trans '(0. 0. 0.) from to))
(mapcar
'(lambda (x)
(append
(mapcar 'append (car x) (mapcar 'list (cadr x)))
'((0. 0. 0. 1.))
)
)
(list (list RMat Disp) (list InvRMat InvDisp))
)
)
;已知一点和点的三维转换矩阵，获得新的点坐标
;pt -- 三维点坐标
;mat -- 三维转换矩阵(caddr (nentsel))或(caddr (nentselp))
(defun mxp (mat pt / vector num matp new_pt)
(if (= (length pt) 2)
(setq pt (append pt '(0.0)))
)
(setq vector (append pt '(1.0)))
(if mat
(progn
(setq num (length (car mat)))
(cond
;(caddr (nentsel))
((= num 3)
(setq matp (apply 'mapcar (cons 'list mat)))
)
;(caddr (nentselp))
((= num 4)
(setq matp (reverse (cdr (reverse mat))))
)
)
(setq new_pt (mapcar '(lambda (x) (apply '+ (mapcar '* x vector))) matp))
)
)
)
;功能：获得单一对象在UCS坐标系中的包围盒四个角点的WCS坐标
;ename--图元名
(defun zg-GetObjectUCSBoundingBox (ename / ll rr box wcsptlst MatpLlist UCS2WCSMatp obj WCS2UCSMatp ptlst)
(if (car (atoms-family 1 '("vl-load-com")))
(vl-load-com)
)
(if (= (getvar "worlducs") 1)
;WCS与UCS相同
(if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-GetBoundingBox (list (vlax-ename->vla-object ename) 'll 'rr))))
(progn
(setq box (list (vlax-safearray->list ll) (vlax-safearray->list rr)))
(setq wcsptlst (zg-BoundingBox->List box))
)
)
;WCS与UCS不同
(progn
(setq MatpLlist (zg-matrix-trans 1 0))
(setq UCS2WCSMatp (car MatpLlist))
(setq WCS2UCSMatp (cadr MatpLlist))
(setq obj (vlax-ename->vla-object ename))
(vla-TransformBy obj (vlax-tmatrix UCS2WCSMatp));UCS->WCS
(if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-GetBoundingBox (list obj 'll 'rr))))
(setq box (list (vlax-safearray->list ll) (vlax-safearray->list rr)))
)
(vla-TransformBy obj (vlax-tmatrix WCS2UCSMatp));WCS->UCS
(if box
(progn
(setq ptlst (zg-BoundingBox->List box))
(setq wcsptlst (mapcar '(lambda (pt) (mxp WCS2UCSMatp pt)) ptlst))
)
)
)
)
wcsptlst
)
本帖最后由 namezg 于 2013-9-18 08:01 编辑
mxp函数忘发了.现在在外面.回头补上.
已补全了。