明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 940|回复: 3

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

[复制链接]
发表于 2019-1-7 08:34 | 显示全部楼层 |阅读模式
谁能帮我把这个代码更改一下,多选物体绘制包围框并标注包围框。


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

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
 楼主| 发表于 2019-1-7 08:35 | 显示全部楼层
这是从Gu_xl的个人空间复制过来的。帮忙添加一下并标注。
 楼主| 发表于 2019-1-7 08:37 | 显示全部楼层
GU版主你好,多选物体绘制包围框能不能添加一下并标注包围框再提取到EXCEL。
发表于 2019-2-1 15:24 | 显示全部楼层
没太明白你的意图
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 14:21 , Processed in 0.305445 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表