获取选择集，图块（动态块）的轮廓线

newer · 发表于 2021-1-17 04:05:43

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(defun c:outline ( / sel )
(if (setq sel (ssget))
(sssetfirst nil (LM:outline sel))
)
(princ)
)
;; Object Outline - Lee Mac
;; Attempts to generate a polyline outlining the selected objects.
;; sel - [sel] Selection Set to outline
(defun LM:outline ( sel / app are box cmd dis enl ent lst obj rtn tmp )
(setq app (vlax-get-acad-object)
box (LM:ssboundingbox sel)
dis (/ (apply 'distance box) 20.0)
lst (mapcar '(lambda ( a o ) (mapcar o a (list dis dis))) box '(- +))
are (apply '* (apply 'mapcar (cons '- (reverse lst))))
dis (* dis 1.5)
ent
(entmakex
(append
'( (000 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(090 . 4)
(070 . 1)
)
(mapcar '(lambda ( x ) (cons 10 (mapcar '(lambda ( y ) ((eval y) lst)) x)))
'( (caar cadar)
(caadr cadar)
(caadr cadadr)
(caar cadadr)
)
)
)
)
)
(apply 'vlax-invoke
(vl-list* app 'zoomwindow
(mapcar '(lambda ( a o ) (mapcar o a (list dis dis 0.0))) box '(- +))
)
)
(setq cmd (getvar 'cmdecho)
enl (entlast)
rtn (ssadd)
)
(while (setq tmp (entnext enl)) (setq enl tmp))
(setvar 'cmdecho 0)
(command
"_.-boundary" "_a" "_b" "_n" sel ent "" "_i" "_y" "_o" "_p" "" "_non"
(trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0))) 0 1) ""
)
(while (< 0 (getvar 'cmdactive)) (command ""))
(entdel ent)
(while (setq enl (entnext enl))
(if (and (vlax-property-available-p (setq obj (vlax-ename->vla-object enl)) 'area)
(equal (vla-get-area obj) are 1e-4)
)
(entdel enl)
(ssadd enl rtn)
)
)
(vla-zoomprevious app)
(setvar 'cmdecho cmd)
rtn
)
;; Selection Set Bounding Box - Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; s - [sel] Selection set for which to return bounding box
(defun LM:ssboundingbox ( s / a b i m n o )
(repeat (setq i (sslength s))
(if
(and
(setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
(vlax-method-applicable-p o 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
)
(setq m (cons (vlax-safearray->list a) m)
n (cons (vlax-safearray->list b) n)
)
)
)
(if (and m n)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
)
)
(vl-load-com) (princ)

(defun c:outline ( / sel ) 
    (if (setq sel (ssget)) 
        (sssetfirst nil (LM:outline sel)) 
    ) 
    (princ) 
) 
 
;; Object Outline  -  Lee Mac 
;; Attempts to generate a polyline outlining the selected objects. 
;; sel - [sel] Selection Set to outline 
 
(defun LM:outline ( sel / app are box cmd dis enl ent lst obj rtn tmp ) 
    (setq app (vlax-get-acad-object) 
          box (LM:ssboundingbox sel) 
          dis (/ (apply 'distance box) 20.0) 
          lst (mapcar '(lambda ( a o ) (mapcar o a (list dis dis))) box '(- +)) 
          are (apply '* (apply 'mapcar (cons '- (reverse lst)))) 
          dis (* dis 1.5) 
          ent 
        (entmakex 
            (append 
               '(   (000 . "LWPOLYLINE") 
                    (100 . "AcDbEntity") 
                    (100 . "AcDbPolyline") 
                    (090 . 4) 
                    (070 . 1) 
                ) 
                (mapcar '(lambda ( x ) (cons 10 (mapcar '(lambda ( y ) ((eval y) lst)) x))) 
                   '(   (caar   cadar) 
                        (caadr  cadar) 
                        (caadr cadadr) 
                        (caar  cadadr) 
                    ) 
                ) 
            ) 
        ) 
    ) 
    (apply 'vlax-invoke 
        (vl-list* app 'zoomwindow 
            (mapcar '(lambda ( a o ) (mapcar o a (list dis dis 0.0))) box '(- +)) 
        ) 
    ) 
    (setq cmd (getvar 'cmdecho) 
          enl (entlast) 
          rtn (ssadd) 
    ) 
    (while (setq tmp (entnext enl)) (setq enl tmp)) 
    (setvar 'cmdecho 0) 
    (command 
        "_.-boundary" "_a" "_b" "_n" sel ent "" "_i" "_y" "_o" "_p" "" "_non" 
        (trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0))) 0 1) "" 
    ) 
    (while (< 0 (getvar 'cmdactive)) (command "")) 
    (entdel ent) 
    (while (setq enl (entnext enl)) 
        (if (and (vlax-property-available-p (setq obj (vlax-ename->vla-object enl)) 'area) 
                 (equal (vla-get-area obj) are 1e-4) 
            ) 
            (entdel enl) 
            (ssadd  enl rtn) 
        ) 
    ) 
    (vla-zoomprevious app) 
    (setvar 'cmdecho cmd) 
    rtn 
) 
 
;; Selection Set Bounding Box  -  Lee Mac 
;; Returns a list of the lower-left and upper-right WCS coordinates of a 
;; rectangular frame bounding all objects in a supplied selection set. 
;; s - [sel] Selection set for which to return bounding box 
 
(defun LM:ssboundingbox ( s / a b i m n o ) 
    (repeat (setq i (sslength s)) 
        (if 
            (and 
                (setq o (vlax-ename->vla-object (ssname s (setq i (1- i))))) 
                (vlax-method-applicable-p o 'getboundingbox) 
                (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b)))) 
            ) 
            (setq m (cons (vlax-safearray->list a) m) 
                  n (cons (vlax-safearray->list b) n) 
            ) 
        ) 
    ) 
    (if (and m n) 
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n)) 
    ) 
) 
 
(vl-load-com) (princ)

另外一个实现代码：

;Lee Mac's Code Modified from: http://www.theswamp.org/index.php?topic=48031.msg530751#msg530751
;; Object Outline - Lee Mac
;; Attempts to generate a polyline outlining the selected objects.
(defun ECO (sel / a b c d e o p s x y)
(command "._isolateobjects" sel "")
(setq b (LM:ssboundingbox sel)
d (/ (apply 'distance b) 20.0)
p (mapcar '(lambda (a o) (mapcar o a (list d d))) b '(- +))
a (apply '* (apply 'mapcar (cons '- (reverse p))))
d (* d 1.5)
e (entmakex
(append
'(
(000 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(090 . 4)
(070 . 1)
)
(mapcar
'(lambda (x) (cons 10 (mapcar '(lambda (y) ((eval y) p)) x)))
'(
(caar cadar)
(caadr cadar)
(caadr cadadr)
(caar cadadr)
)
)
)
)
)
(setq c (getvar 'cmdecho)
x (entlast)
)
(while (setq y (entnext x)) (setq x y))
(setvar 'cmdecho 0)
(command "._-boundary" "_a" "_b" "_n" sel e "" "_i" "_y" "_o" "_p" "" "_non" (trans (car b) 0 1) "")
(while (< 0 (getvar 'cmdactive)) (command ""))
(entdel e)
(command "._unisolateobjects")
)

;Lee Mac's Code Modified from: <a href=\"http://www.theswamp.org/index.php?topic=48031.msg530751#msg530751\" target=\"_blank\">http://www.theswamp.org/index.php?topic=48031.msg530751#msg530751</a> 
;; Object Outline  -  Lee Mac 
;; Attempts to generate a polyline outlining the selected objects. 
(defun ECO (sel / a b c d e o p s x y) 
  (command "._isolateobjects" sel "") 
  (setq b (LM:ssboundingbox sel) 
                  d (/ (apply 'distance b) 20.0) 
                  p (mapcar '(lambda (a o) (mapcar o a (list d d))) b '(- +)) 
                  a (apply '* (apply 'mapcar (cons '- (reverse p)))) 
                  d (* d 1.5) 
                  e (entmakex 
              (append 
                '( 
                  (000 . "LWPOLYLINE") 
                  (100 . "AcDbEntity") 
                  (100 . "AcDbPolyline") 
                  (090 . 4) 
                  (070 . 1) 
                 ) 
                (mapcar 
                  '(lambda (x) (cons 10 (mapcar '(lambda (y) ((eval y) p)) x))) 
                  '( 
                    (caar cadar) 
                    (caadr cadar) 
                    (caadr cadadr) 
                    (caar cadadr) 
                   ) 
                ) 
              ) 
            ) 
  ) 
   (setq c (getvar 'cmdecho) 
          x (entlast) 
    ) 
    (while (setq y (entnext x)) (setq x y)) 
    (setvar 'cmdecho 0) 
  (command "._-boundary" "_a" "_b" "_n" sel e "" "_i" "_y" "_o" "_p" "" "_non" (trans (car b) 0 1) "") 
  (while (< 0 (getvar 'cmdactive)) (command "")) 
  (entdel e) 
    (command "._unisolateobjects") 
 
)

muyufei · 发表于 2021-1-17 15:48:23

好东西，顶了学习一下

dyjwyqz5221 · 发表于 2021-10-16 17:18:49

非常好的帖子，现在正好需要这个，非常感谢！

Humanway · 发表于 2021-10-20 14:19:26

学习一下，这个不错，可以改进一下我的代码了

qxlonmsn · 发表于 2021-11-2 19:06:23

老大的代码就是强

吴外安放 · 发表于 2021-11-3 14:44:44

如果中间有几处断开缺口了，也能否取得外轮廓线

hejie13250 · 发表于 2022-5-18 16:24:53

同6楼，如果中间有几处断开缺口了，也能否取得外轮廓线

dnbcgrass · 发表于 2022-5-18 22:00:38

学习一下，谢谢分享

261789003 · 发表于 2024-3-27 14:38:19

win10 1909 CAD2020.1.2 提示语法错误。。。

账号		自动登录	找回密码
密码			立即注册

[每日一码] 获取选择集，图块（动态块）的轮廓线

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。