研究过最大包围框的，请进

328302216

Gu_xl 发表于 2014-5-12 20:05
程序:

[/post]

谢谢固版的源码！我还没有研究过你的源码，只是测试了一下有个小漏洞！那两个圆是不是应该为单独的一个最小包围框才对呢？
找时间仔细看看学习！

易云网络

谢谢固版的源码！

光---暗

我也好想知道原理啊，应该不是对每个图元都进行框选再进行逻辑运算吧，要30帖才能看大神的程序

nfr

非常不错，学习了

革天明

Gu_xl 发表于 2014-5-12 20:05
程序:

[/post]

如果只选择一个图元，则程序不运行，修改了一下，对于单个图元也可以运行
;;框选物体画框 By Gu_xl 明经通道 2014.05.12
(defun c:mBox (/ BOX INTERSECT RECTANG SS N L A L1 FLAG B C)
  (defun box (e / p1 p2 p3 p4 obj)
    (setq obj (vlax-ename->vla-object e))
    (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        (= "SPLINE" (cdr (assoc 0 (entget e))))
      (progn
        (SETQ lst
               (mapcar '(lambda        (a b)
                          (vlax-curve-getClosestPointToProjection e 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 lst))
          (apply 'mapcar (cons 'max lst))
        )
      )
      (list p1 p3)
    )
  )
  (defun intersect (a b)
    (if
      (or
        (and
          (<= (caar a) (caar b) (caadr a))
          (<= (cadar a) (cadar b) (cadadr a))
        )
        (and
          (<= (caar a) (caar b) (caadr a))
          (<= (cadar a) (cadadr b) (cadadr a))
        )
        (and
          (<= (caar a) (caadr b) (caadr a))
          (<= (cadar a) (cadadr b) (cadadr a))
        )
        (and
          (<= (caar a) (caadr b) (caadr a))
          (<= (cadar a) (cadar b) (cadadr a))
        )

      )
       (list
         (apply 'mapcar (cons 'min (append a b)))
         (apply 'mapcar (cons 'max (append a b)))
       )
    )
  )
  (defun rectang (a b)
    (entmake
      (list
        '(0 . "LWPOLYLINE")
        '(100 . "AcDbEntity")
        '(8 . "0")
        '(62 . 1)
        '(100 . "AcDbPolyline")
        '(90 . 4)
        '(70 . 1)
        (cons 10 a)
        (list 10 (car a) (cadr b))
        (cons 10 b)
        (list 10 (car b) (cadr a))
      )
    )
  )
  ;;(setq l '())
  (if (setq ss (ssget))
    (progn
      (repeat (setq n (sslength ss))
        (setq l (cons (box (ssname ss (setq n (1- n)))) l))
      )
      (setq l
             (vl-sort
               l
               '(lambda        (a b)
                  (if (equal (caar a) (caar b) 1e-3)
                    (if        (equal (cadar a) (cadar b) 1e-3)
                      (if (equal (caadr a) (caadr b) 1e-3)
                        (< (cadadr a) (cadadr b))
                        (< (caadr a) (caadr b))
                      )
                      (< (cadar a) (cadar b))
                    )
                    (< (caar a) (caar b))
                  )
                )
             )
      )
      (setq a (car l)
            l (cdr l);;(if(not(cdr l))(car l)(cdr l))
      )
      (if (not l)
        (rectang (car a) (cadr a))
        (while l
          (setq        l1   nil
                flag nil
          )
          (while l
            (setq b (car l)
                  l (cdr l)
            )
            (if        (setq c (intersect a b))
              (setq a c
                    flag t
              )
              (setq l1 (cons b l1))
            )
          )
          (setq l (reverse l1))
          (if (not flag)
            (progn
              (rectang (car a) (cadr a))
              (setq a (car l)
                    l (cdr l)
              )
            )
          )
          (if (not l)
            (rectang (car a) (cadr a))
          )
        )
      );;end if (not l)
    );;end progn      
  );;(setq ss (ssget))
  (princ)
)

鱼与熊掌

问题在几个月前写过代码，有空看看g版的代码

戏男

太历害了 学习了

yiran86

学习那学习那

yiran86

学习那学习那

cuncun_101

学习了