hn10183051 发表于 2019-1-7 08:34:17

谁能帮我添加一下 多选物体绘制包围框并标注包围框

谁能帮我把这个代码更改一下，多选物体绘制包围框并标注包围框。{:1_1:}


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

hn10183051 发表于 2019-1-7 08:35:39

这是从Gu_xl的个人空间复制过来的。帮忙添加一下并标注。

hn10183051 发表于 2019-1-7 08:37:41

GU版主你好，多选物体绘制包围框能不能添加一下并标注包围框再提取到EXCEL。

灰石Jeremy 发表于 2019-2-1 15:24:08

没太明白你的意图
页: [1]
查看完整版本: 谁能帮我添加一下 多选物体绘制包围框并标注包围框