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

hn10183051

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

(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)
)

newer

请不要在每日插件论坛 发布 和 最终插件 无关的 内容，帮你移动了。

marting

代码有什么问题？ 楼主想修改啥？

yangjian001

做一个热心并受欢迎的人

hn10183051

这个代码是多选物体绘制包围框，能不能添加一下并标注包围框再提取到EXCEL

hn10183051

marting 发表于 2019-1-7 09:26
代码有什么问题？ 楼主想修改啥？

这个代码是多选物体绘制包围框，能不能添加一下并标注包围框再提取到EXCEL

Lisphk

hn10183051 发表于 2019-1-7 11:47
这个代码是多选物体绘制包围框，能不能添加一下并标注包围框再提取到EXCEL

你把 标注的结果 截图，和EXCEL里面的结果 截图贴上来，看看

hn10183051

Lisphk 发表于 2019-1-7 11:52
你把 标注的结果 截图，和EXCEL里面的结果 截图贴上来，看看

第1个图片是物品展开图，第2个是我发的那个插件包围框想添加标注。第3个是提出数据到EXCEL.

hn10183051

marting 发表于 2019-1-7 09:26
代码有什么问题？ 楼主想修改啥？

这个代码是多选物体绘制包围框，能不能添加一下并标注包围框再提取到EXCEL

hn10183051

前辈们帮帮忙，工作需要，我现在是几个插件一起用才能实现。