【BoxGroup】获取实体或对象的WCS/UCS最小边界框

kucha007 · 发表于 2024-3-2 10:34

本帖最后由 kucha007 于 2024-3-23 18:08 编辑

;返回实体或对象最小边界框的WCS坐标(左下角和右上角)@Gu_xl
(defun K:GetWCSBox (obj / p1 p2 p3 p4 WCSBox)
(if (eq 'ENAME (type obj))(setq obj (vlax-ename->vla-object obj)))
(vla-GetBoundingBox obj 'p1 'p3)
(setq p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3)
p2 (list (car p1) (cadr p3) (caddr p1))
p4 (list (car p3) (cadr p1) (caddr p1))
)
(if (eq "AcDbSpline" (Vla-Get-ObjectName obj));样条曲线取投影
(progn
(setq WCSBox (mapcar
'(lambda (a b) (vlax-curve-getClosestPointToProjection obj a b t))
(list p1 p2 p3 p4)
'((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
)
)
(list
(apply 'mapcar (cons 'min WCSBox));表中最小
(apply 'mapcar (cons 'max WCSBox));表中最大
)
)
(list p1 p3)
)
)

;返回实体或对象最小边界框的WCS坐标(左下角和右上角)@Gu_xl 
(defun K:GetWCSBox (obj / p1 p2 p3 p4 WCSBox) 
    (if (eq 'ENAME (type obj))(setq obj (vlax-ename->vla-object obj))) 
    (vla-GetBoundingBox obj 'p1 'p3) 
    (setq p1 (vlax-safearray->list p1) 
          p3 (vlax-safearray->list p3) 
          p2 (list (car p1) (cadr p3) (caddr p1)) 
          p4 (list (car p3) (cadr p1) (caddr p1)) 
    ) 
    (if (eq "AcDbSpline" (Vla-Get-ObjectName obj));样条曲线取投影 
        (progn 
          (setq WCSBox (mapcar 
                          '(lambda (a b) (vlax-curve-getClosestPointToProjection obj a b t)) 
                          (list p1 p2 p3 p4) 
                          '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0)) 
                       ) 
          ) 
          (list 
              (apply 'mapcar (cons 'min WCSBox));表中最小 
              (apply 'mapcar (cons 'max WCSBox));表中最大 
          ) 
        ) 
        (list p1 p3) 
    ) 
)

;返回实体或对象最小边界框的UCS坐标(左下角和右上角)@Kucha
(defun K:GetUCSBox (obj / K:CvtMatrix UCSBox)
(if (eq 'ENAME (type obj))(setq obj (vlax-ename->vla-object obj)))
;矩阵转换/坐标系转换
(defun K:CvtMatrix (from to)
(append
(mapcar
(function
(lambda (v o)
(append (trans v from to t) (list o))
)
)
'((1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
(trans '(0.0 0.0 0.0) to from)
)
'((0.0 0.0 0.0 1.0))
)
)
(vla-transformby obj (vlax-tmatrix (K:CvtMatrix 1 0)));对象转换到WCS
(setq UCSBox (K:GetWCSBox obj));获取转换后的最小矩形框(WCS)
(vla-transformby obj (vlax-tmatrix (K:CvtMatrix 0 1)));对象转换回UCS
UCSBox
)

;获取选择集所有实体的最小边界框表(WCS/UCS)@Kucha
(defun K:SSAllBoxLst (WCS TgtSS / i en SSBox)
(if TgtSS
(repeat (setq i (sslength TgtSS))
(setq en (ssname TgtSS (setq i (1- i))))
(setq SSBox
(cons
(if WCS (K:GetWCSBox en) (K:GetUCSBox en))
SSBox
)
)
)
)
SSBox
)

;获取选择集的最小边界框(WCS/UCS)@Kucha
(defun K:SSMinBoxLst (WCS TgtSS / i en Box BoxMin BoxMax MinPt MaxPt)
(if TgtSS
(repeat (setq i (sslength TgtSS))
(setq en (ssname TgtSS (setq i (1- i))))
(setq Box (if WCS (K:GetWCSBox en) (K:GetUCSBox en)))
(setq BoxMin (car Box) BoxMax (cadr Box))
(setq MinPt (mapcar 'min BoxMin (cond (MinPt) (BoxMin))))
(setq MaxPt (mapcar 'max BoxMax (cond (MaxPt) (BoxMax))))
)
)
(list MinPt MaxPt)
)

;获取选择集最小边界框表的最小值,即左下角(WCS/UCS)@Kucha
(defun K:SSBoxMinPT (WCS TgtSS / i en BoxMin MinPt)
(if TgtSS
(repeat (setq i (sslength TgtSS))
(setq en (ssname TgtSS (setq i (1- i))))
(setq BoxMin (car (if WCS (K:GetWCSBox en) (K:GetUCSBox en))))
(setq MinPt (mapcar 'min BoxMin (cond (MinPt) (BoxMin))))
)
)
MinPt
)

kucha007 · 发表于 2024-3-3 18:33

本帖最后由 kucha007 于 2024-3-4 13:24 编辑

应用实例：(K:RtnBox4Group 边界框顶点表允许合并的间隙行距)

;矩形分组(矩形分堆),并返回每一个组的包围盒@Tryhi-大海(优化 by Kucha)
(defun K:RtnBox4Group (RecLst Gap SpcTol / K:2RecInters NewLst TmpLst Flag RdoLst BasRec FstRec IntRec a b)
;时间复杂度为n(1)，测试了17万个图元480组仅10秒
;如果矩形相交，则返回两矩形的最大边界框
(defun K:2RecInters (Fst Sec)
(if
(not
(or ;不可能重叠的四种情况
(> (car Fst) (caddr Sec)) ;A的左侧比B的右侧大：X
(> (cadr Fst) (Last Sec)) ;A的下部比B的上部大：Y
(< (caddr Fst) (car Sec)) ;A的右侧比B的左侧小：X
(< (Last Fst) (cadr Sec)) ;A的上部比B的下部小：Y
)
)
(list
(min (car Fst) (car Sec))
(min (cadr Fst) (cadr Sec))
(max (caddr Fst) (caddr Sec))
(max (Last Fst) (Last Sec))
)
)
)
(if (and RecLst (setq Gap (/ Gap 2)))
(progn
(setq RecLst
(mapcar
'(lambda (XX)
(list
(nth 0 (car XX)) (nth 1 (car XX))
(nth 0 (cadr XX)) (nth 1 (cadr XX))
)
)
RecLst
)
);只取XY合并组成新的表,排序时再调整回来
(setq RecLst (mapcar '(lambda (XX) (mapcar '+ XX (list (- Gap) (- Gap) Gap Gap))) RecLst));矩形扩大
(progn ;合并矩形
(setq Flag T RdoLst Nil)
(while Flag
(setq BasRec (car RecLst) NewLst Nil)
(while (setq FstRec (car RecLst)) ;主要耗时点
(setq RecLst (cdr RecLst)) ;更新列表
(if (setq IntRec (K:2RecInters BasRec (setq FstRec (car RecLst))))
(setq BasRec IntRec);RecLst中有和BasRec相交的矩形,更新BasRec
(if
(setq TmpLst (vl-some
'(lambda (a / b)
(if (setq b (K:2RecInters BasRec a))
(list b a)
)
)
NewLst
)
);NewLst中有和BasRec相交的矩形
(progn
(if (not (eq (car TmpLst) (Last TmpLst)))
(setq NewLst (subst (car TmpLst) (Last TmpLst) NewLst))
);相交矩形和表中对应元素不同则替换
(setq BasRec FstRec)
)
(setq NewLst (cons BasRec NewLst)
BasRec FstRec
);收集并更新
)
)
)
(if (eq (length NewLst) (length RdoLst))
(setq Flag Nil)
(setq RdoLst NewLst
RecLst NewLst
)
)
)
)
(setq NewLst (mapcar '(lambda (XX) (mapcar '+ XX (list Gap Gap (- Gap) (- Gap)))) NewLst));矩形缩小
(vl-sort
(mapcar
'(lambda (x)
(list
(list (car x) (cadr x))
(list (caddr x) (cadddr x))
)
)
NewLst
);重新调整LST表的数据结构
'(lambda (a b)
(if (equal (cadr (car a)) (cadr (car b)) SpcTol) ;Y在容差内相等？
(if (equal (car (car a)) (car (car b))) ;X相等
(> (cadr (car a)) (cadr (car b))) ;比较Y
(< (car (car a)) (car (car b))) ;比较X
)
(> (cadr (car a)) (cadr (car b))) ;比较Y
)
)
);重新排序:先上下后左右
)
);矩形分堆得到互不相交的矩形LST
)

;矩形分组(矩形分堆),并返回每一个组的包围盒@Tryhi-大海(优化 by Kucha) 
(defun K:RtnBox4Group (RecLst Gap SpcTol / K:2RecInters NewLst TmpLst Flag RdoLst BasRec FstRec IntRec a b) 
  ;时间复杂度为n(1)，测试了17万个图元480组仅10秒 
   
  ;如果矩形相交，则返回两矩形的最大边界框 
  (defun K:2RecInters (Fst Sec) 
    (if 
      (not 
        (or  ;不可能重叠的四种情况 
          (> (car Fst) (caddr Sec)) ;A的左侧比B的右侧大：X 
          (> (cadr Fst) (Last Sec)) ;A的下部比B的上部大：Y 
          (< (caddr Fst) (car Sec)) ;A的右侧比B的左侧小：X 
          (< (Last Fst) (cadr Sec)) ;A的上部比B的下部小：Y 
        ) 
      ) 
      (list 
        (min (car Fst) (car Sec)) 
        (min (cadr Fst) (cadr Sec)) 
        (max (caddr Fst) (caddr Sec)) 
        (max (Last Fst) (Last Sec)) 
      ) 
    ) 
  ) 
  (if (and RecLst  (setq Gap (/ Gap 2))) 
      (progn 
          (setq RecLst 
              (mapcar 
                '(lambda (XX) 
                    (list 
                        (nth 0 (car XX)) (nth 1 (car XX)) 
                        (nth 0 (cadr XX)) (nth 1 (cadr XX)) 
                    ) 
                ) 
                RecLst 
              ) 
          );只取XY合并组成新的表,排序时再调整回来 
          (setq RecLst (mapcar '(lambda (XX) (mapcar '+ XX (list (- Gap) (- Gap) Gap Gap))) RecLst));矩形扩大 
          (progn ;合并矩形 
            (setq Flag T RdoLst Nil) 
            (while Flag 
              (setq BasRec (car RecLst) NewLst Nil) 
              (while (setq FstRec (car RecLst)) ;主要耗时点 
                (setq RecLst (cdr RecLst)) ;更新列表 
                (if (setq IntRec (K:2RecInters BasRec (setq FstRec (car RecLst)))) 
                  (setq BasRec IntRec);RecLst中有和BasRec相交的矩形,更新BasRec 
                  (if 
                    (setq TmpLst (vl-some 
                              '(lambda (a / b) 
                                  (if (setq b (K:2RecInters BasRec a)) 
                                    (list b a) 
                                  ) 
                                ) 
                              NewLst 
                            ) 
                    );NewLst中有和BasRec相交的矩形 
                    (progn 
                      (if (not (eq (car TmpLst) (Last TmpLst))) 
                          (setq NewLst (subst (car TmpLst) (Last TmpLst) NewLst)) 
                      );相交矩形和表中对应元素不同则替换 
                      (setq BasRec FstRec) 
                    ) 
                    (setq NewLst (cons BasRec NewLst) 
                          BasRec FstRec 
                    );收集并更新 
                  ) 
                ) 
              ) 
              (if (eq (length NewLst) (length RdoLst)) 
                (setq Flag Nil) 
                (setq RdoLst NewLst 
                      RecLst NewLst 
                ) 
              ) 
            ) 
          ) 
          (setq NewLst (mapcar '(lambda (XX) (mapcar '+ XX (list Gap Gap (- Gap) (- Gap)))) NewLst));矩形缩小 
          (vl-sort 
            (mapcar 
              '(lambda (x) 
                    (list 
                      (list (car x) (cadr x)) 
                      (list (caddr x) (cadddr x)) 
                    ) 
                ) 
              NewLst 
            );重新调整LST表的数据结构 
            '(lambda (a b) 
                (if (equal (cadr (car a)) (cadr (car b)) SpcTol)  ;Y在容差内相等？ 
                    (if (equal (car (car a)) (car (car b)))  ;X相等 
                      (> (cadr (car a)) (cadr (car b))) ;比较Y 
                      (< (car (car a)) (car (car b))) ;比较X 
                    ) 
                    (> (cadr (car a)) (cadr (car b))) ;比较Y 
                ) 
              ) 
          );重新排序:先上下后左右 
      ) 
  );矩形分堆得到互不相交的矩形LST 
)

尘缘一生 · 发表于 2024-3-2 19:16

;返回实体或对象最小边界框的WCS坐标(左下角和右上角)@Gu_xl
(defun K:GetWCSBox (obj / p1 p2 p3 p4 WCSBox)
(if (eq 'ENAME (type obj)) (setq obj (vlax-ename->vla-object obj)))
(vla-GetBoundingBox obj 'p1 'p3)
(setq p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3)
p2 (list (car p1) (cadr p3) (caddr p1))
p4 (list (car p3) (cadr p1) (caddr p1))
)
(if (eq "AcDbSpline" (Vla-Get-ObjectName obj));样条曲线取投影
(progn
(setq WCSBox (mapcar
'(lambda (a b) (vlax-curve-getClosestPointToProjection obj a b t))
(list p1 p2 p3 p4)
'((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
)
)
(list
(apply 'mapcar (cons 'min WCSBox));表中最小
(apply 'mapcar (cons 'max WCSBox));表中最大
)
)
(list p1 p3)
)
)
;返回实体或对象最小边界框的UCS坐标(左下角和右上角)@Kucha
(defun K:GetUCSBox (obj / K:CvtMatrix UCSBox)
(if (eq 'ENAME (type obj)) (setq obj (vlax-ename->vla-object obj)))
;矩阵转换/坐标系转换
(defun K:CvtMatrix (from to)
(append
(mapcar
(function
(lambda (v o)
(append (trans v from to t) (list o))
)
)
'((1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
(trans '(0.0 0.0 0.0) to from)
)
'((0.0 0.0 0.0 1.0))
)
)
(vla-transformby obj (vlax-tmatrix (K:CvtMatrix 1 0)));对象转换到WCS
(setq UCSBox (K:GetWCSBox obj));获取转换后的最小矩形框(WCS)
(vla-transformby obj (vlax-tmatrix (K:CvtMatrix 0 1)));对象转换回UCS
UCSBox
)
;获取选择集所有实体的最小边界框表(WCS/UCS)@Kucha
(defun K:SSAllBoxLst (WCS TgtSS / i en SSBox)
(if TgtSS
(repeat (setq i (sslength TgtSS))
(setq en (ssname TgtSS (setq i (1- i))))
(setq SSBox
(cons
(if WCS (K:GetWCSBox en) (K:GetUCSBox en))
SSBox
)
)
)
)
SSBox
)
;获取选择集最小边界框表的最小值,即左下角(WCS/UCS)@Kucha
(defun K:SSBoxMinPT (WCS TgtSS / i en BoxMin MinPt)
(if TgtSS
(repeat (setq i (sslength TgtSS))
(setq en (ssname TgtSS (setq i (1- i))))
(setq BoxMin (car (if WCS (K:GetWCSBox en) (K:GetUCSBox en))))
(setq MinPt (mapcar 'min BoxMin (cond (MinPt) (BoxMin))))
)
)
MinPt
)

;返回实体或对象最小边界框的WCS坐标(左下角和右上角)@Gu_xl 
(defun K:GetWCSBox (obj / p1 p2 p3 p4 WCSBox) 
  (if (eq 'ENAME (type obj)) (setq obj (vlax-ename->vla-object obj))) 
  (vla-GetBoundingBox obj 'p1 'p3) 
  (setq p1 (vlax-safearray->list p1) 
    p3 (vlax-safearray->list p3) 
    p2 (list (car p1) (cadr p3) (caddr p1)) 
    p4 (list (car p3) (cadr p1) (caddr p1)) 
  ) 
  (if (eq "AcDbSpline" (Vla-Get-ObjectName obj));样条曲线取投影 
    (progn 
      (setq WCSBox (mapcar 
                     '(lambda (a b) (vlax-curve-getClosestPointToProjection obj a b t)) 
                     (list p1 p2 p3 p4) 
                     '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0)) 
                   ) 
      ) 
      (list 
         (apply 'mapcar (cons 'min WCSBox));表中最小 
         (apply 'mapcar (cons 'max WCSBox));表中最大 
      ) 
    ) 
    (list p1 p3) 
  ) 
) 
;返回实体或对象最小边界框的UCS坐标(左下角和右上角)@Kucha 
(defun K:GetUCSBox (obj / K:CvtMatrix UCSBox) 
  (if (eq 'ENAME (type obj)) (setq obj (vlax-ename->vla-object obj))) 
  ;矩阵转换/坐标系转换 
  (defun K:CvtMatrix (from to) 
    (append 
       (mapcar 
          (function 
            (lambda (v o) 
              (append (trans v from to t) (list o)) 
            ) 
          ) 
          '((1.0 0.0 0.0) 
             (0.0 1.0 0.0) 
             (0.0 0.0 1.0) 
           ) 
          (trans '(0.0 0.0 0.0) to from) 
         ) 
       '((0.0 0.0 0.0 1.0)) 
    ) 
  ) 
  (vla-transformby obj (vlax-tmatrix (K:CvtMatrix 1 0)));对象转换到WCS 
  (setq UCSBox (K:GetWCSBox obj));获取转换后的最小矩形框(WCS) 
  (vla-transformby obj (vlax-tmatrix (K:CvtMatrix 0 1)));对象转换回UCS 
  UCSBox 
) 
;获取选择集所有实体的最小边界框表(WCS/UCS)@Kucha 
(defun K:SSAllBoxLst (WCS TgtSS / i en SSBox) 
  (if TgtSS 
    (repeat (setq i (sslength TgtSS)) 
      (setq en (ssname TgtSS (setq i (1- i)))) 
      (setq SSBox 
        (cons 
          (if WCS (K:GetWCSBox en) (K:GetUCSBox en)) 
          SSBox 
        ) 
      ) 
    ) 
  ) 
  SSBox 
) 
;获取选择集最小边界框表的最小值,即左下角(WCS/UCS)@Kucha 
(defun K:SSBoxMinPT (WCS TgtSS / i en BoxMin MinPt) 
  (if TgtSS 
    (repeat (setq i (sslength TgtSS)) 
      (setq en (ssname TgtSS (setq i (1- i)))) 
      (setq BoxMin (car (if WCS (K:GetWCSBox en) (K:GetUCSBox en)))) 
      (setq MinPt (mapcar 'min BoxMin (cond (MinPt) (BoxMin)))) 
    ) 
  ) 
  MinPt 
)

tigcat · 发表于 2024-3-2 19:16

这个就是你在ucs下得到的包围盒角点与在wcs下是一致的,同时楼主改进后可以得到选择集的包围盒.不过,这个函数猜测可能会存在缺陷,原因是基础函数用到curve系列函数,该函数在大坐标时,可能出现问题.

tigcat · 发表于 2024-3-2 12:05

这个挺好的,很多时候用的着

muai2010 · 发表于 2024-3-2 16:34

不错，要是能给个应用实例就好了

紫苏炒黄瓜 · 发表于 2024-3-2 18:59

支持支持

kucha007 · 发表于 2024-3-3 11:53

tigcat 发表于 2024-3-2 19:16
这个就是你在ucs下得到的包围盒角点与在wcs下是一致的,同时楼主改进后可以得到选择集的包围盒.不过,这个函 ...

现在是能用比好用重要哈哈哈，大坐标没探索太深

kucha007 · 发表于 2024-3-3 11:55

尘缘一生发表于 2024-3-2 19:16

有什么改动吗？

tigcat · 发表于 2024-3-3 14:50

kucha007 发表于 2024-3-3 11:53
现在是能用比好用重要哈哈哈，大坐标没探索太深

楼主说的不错

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

【BoxGroup】获取实体或对象的WCS/UCS最小边界框

评分