有请Gu_xl版主和各位高手进来看看

Jack_PC

       今天在论坛看到Gu_xl版主写的"多选物体画框"的程序，由于LISP还不熟练，程序有些地方没有看懂，希望Gu_xl版主或能够看懂的各位高手在这里讲一讲这个程序实现的原理.

;;框选物体画框 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))
      )
    )
  )
  (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)
      )
      (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))
  )
      )
    )
  )
  (princ)
)

Jack_PC

期待中...

insufficient

我也正在看这个源码，想要实现非极轴画框