【K:GetEntUCSBox】最小UCS边界框

kucha007

改写自G版的最小边界框。以往获取边界框的函数, 框边缘都平行WCS，没有做转换，用在我这个程序就会出问题了http://bbs.mjtd.com/thread-187517-1-1.html
于是我做了改写，使得框平行于当前坐标系，返回的坐标也是基于当前坐标系。这样UCS下合并边界框啥的就没问题了。

1. ;获取实体最小外接矩形的坐标,矩形边框平行于当前坐标系
   
2. (defun K:GetEntUCSBox (en / K:ConvertTMatrix obj Lst p1 p2 p3 p4)
   
3.   (setq obj (vlax-ename->vla-object en))
   
4.   ;矩阵转换/坐标系转换
   
5.   (defun K:ConvertTMatrix (from to)
   
6.     (append
   
7.       (mapcar
   
8.         (function
   
9.           (lambda (v o)
   
10.             (append (trans v from to t) (list o))
    
11.           )
    
12.         )
    
13.         '((1.0 0.0 0.0)
    
14.           (0.0 1.0 0.0)
    
15.           (0.0 0.0 1.0)
    
16.         )
    
17.         (trans '(0.0 0.0 0.0) to from)
    
18.       )
    
19.       '((0.0 0.0 0.0 1.0))
    
20.     )
    
21.   )
    
22.   (if
    
23.     (and
    
24.       (not (K:CatchApply 'vla-transformby (list obj (vlax-tmatrix (K:ConvertTMatrix 1 0)))));对象转换到WCS
    
25.       (not (K:CatchApply 'vla-GetBoundingBox (list obj 'p1 'p3)))
    
26.       (not (K:CatchApply 'vla-transformby (list obj (vlax-tmatrix (K:ConvertTMatrix 0 1)))));对象转换回UCS
    
27.     )
    
28.     (progn
    
29.       (setq p1 (vlax-safearray->list p1)
    
30.             p3 (vlax-safearray->list p3)
    
31.             p2 (list (car p1) (cadr p3) (caddr p1))
    
32.             p4 (list (car p3) (cadr p1) (caddr p1))
    
33.       )
    
34.       (if (eq "SPLINE" (cdr (assoc 0 (entget en))))
    
35.         (progn
    
36.           (setq Lst
    
37.             (mapcar
    
38.               '(lambda (a b)(vlax-curve-getClosestPointToProjection en a b t))
    
39.               (list p1 p2 p3 p4)
    
40.               '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
    
41.             )
    
42.           )
    
43.           (list
    
44.             (apply 'mapcar (cons 'min Lst))
    
45.             (apply 'mapcar (cons 'max Lst))
    
46.           )
    
47.         )
    
48.         (list p1 p3)
    
49.       )
    
50.     )
    
51.   )
    
52. )
    

;获取实体最小外接矩形的坐标,矩形边框平行于当前坐标系<br /> (defun K:GetEntUCSBox (en / K:ConvertTMatrix obj Lst p1 p2 p3 p4)<br />   (setq obj (vlax-ename->vla-object en))<br />   ;矩阵转换/坐标系转换<br />   (defun K:ConvertTMatrix (from to) <br />     (append <br />       (mapcar <br />         (function <br />           (lambda (v o) <br />             (append (trans v from to t) (list o))<br />           )<br />         )<br />         '((1.0 0.0 0.0)<br />           (0.0 1.0 0.0)<br />           (0.0 0.0 1.0)<br />         )<br />         (trans '(0.0 0.0 0.0) to from)<br />       )<br />       '((0.0 0.0 0.0 1.0))<br />     )<br />   )<br />   (if<br />     (and<br />       (not (K:CatchApply 'vla-transformby (list obj (vlax-tmatrix (K:ConvertTMatrix 1 0)))));对象转换到WCS<br />       (not (K:CatchApply 'vla-GetBoundingBox (list obj 'p1 'p3)))<br />       (not (K:CatchApply 'vla-transformby (list obj (vlax-tmatrix (K:ConvertTMatrix 0 1)))));对象转换回UCS<br />     )<br />     (progn<br />       (setq p1 (vlax-safearray->list p1)<br />             p3 (vlax-safearray->list p3)<br />             p2 (list (car p1) (cadr p3) (caddr p1))<br />             p4 (list (car p3) (cadr p1) (caddr p1))<br />       )<br />       (if (eq "SPLINE" (cdr (assoc 0 (entget en)))) <br />         (progn <br />           (setq Lst <br />             (mapcar <br />               '(lambda (a b)(vlax-curve-getClosestPointToProjection en a b t))<br />               (list p1 p2 p3 p4)<br />               '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))<br />             )<br />           )<br />           (list <br />             (apply 'mapcar (cons 'min Lst))<br />             (apply 'mapcar (cons 'max Lst))<br />           )<br />         )<br />         (list p1 p3)<br />       )<br />     )<br />   )<br /> )<br />

;通用函数

1. ;如果不成功则抓取错误，如果成功就执行程序
   
2. (defun K:CatchApply (fun args / result)
   
3.   (if
   
4.     (not
   
5.       (vl-catch-all-error-p
   
6.         (setq result (vl-catch-all-apply
   
7.                       (if (= 'SYM (type fun)) fun (function fun))
   
8.                       args
   
9.                     )
   
10.         )
    
11.       )
    
12.     )
    
13.     result
    
14.   )
    
15. )
    

;如果不成功则抓取错误，如果成功就执行程序<br /> (defun K:CatchApply (fun args / result) <br />   (if <br />     (not <br />       (vl-catch-all-error-p <br />         (setq result (vl-catch-all-apply <br />                       (if (= 'SYM (type fun)) fun (function fun))<br />                       args<br />                     )<br />         )<br />       )<br />     )<br />     result<br />   )<br /> )<br />

zwq8629

顶上顶上顶上

lxl217114

那批打用上以后，不是可以打印旋转了一定角度的图框了。

kucha007

lxl217114 发表于 2023-6-30 11:57
那批打用上以后，不是可以打印旋转了一定角度的图框了。

是的，不过这个是平行ucs。你说的那种leemac有一个最小边界框，感觉更适合