poly168 发表于 2019-6-3 20:59:29

合并边界

本帖最后由 poly168 于 2019-7-3 16:16 编辑


http://bbs.mjtd.com/forum.php?mod=image&aid=104580&size=300x300&key=19cf4c9e8ffba720&nocache=yes&type=fixnone

源程序如下：

(defun c:outlinee (/ *error* idx sel)
(defun *error* (msg)
    (LM:endundo (LM:acdoc))
    (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
      (princ (strcat "\nError: " msg))
    )
    (princ)
)
(loop
(while (setq sel (ssget))
    (progn
      (LM:startundo (LM:acdoc))
      (LM:outline sel)
      (repeat (setq idx (sslength sel))
(entdel (ssname sel (setq idx (1- idx))))
      )
      (LM:endundo (LM:acdoc))      
    )
)
)
(princ )
)
(defun LM:outline (sel / app are box cmd dis enl ent lst obj rtn tmp)
(if (setq box (LM:ssboundingbox sel))
    (progn
      (setq app (vlax-get-acad-object)
   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
    )
)
)
(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)
    )
)
)
(defun LM:startundo (doc)
(LM:endundo doc)
(vla-startundomark doc)
)
(defun LM:endundo (doc)
(while (= 8 (logand 8 (getvar 'undoctl)))
    (vla-endundomark doc)
)
)

(defun LM:acdoc nil
(eval (list 'defun
       'LM:acdoc
       'nil
       (vla-get-activedocument (vlax-get-acad-object))
)
)
(LM:acdoc)
)
(vl-load-com)
(princ)


20060510412 发表于 2021-3-22 10:24:59

多谢楼主，这两天刚好需要这个程序。

世井 发表于 2021-4-29 09:40:53

漂亮！！！

999999 发表于 2021-5-26 00:11:13

顶起，顶起，谢谢楼主无私的分享

cyfdean 发表于 2023-12-25 14:35:31

多谢楼主，这两天刚好需要这个程序。

sjl_fyl 发表于 2024-1-24 18:58:39

{:1_1:}谢谢

xpeagle 发表于 2024-1-25 10:59:50

试试，多谢分享啦，这个也好用，赞一个

ZYX2129 发表于 2024-1-25 19:48:11

谢谢楼主无私的分享

zhangrunze 发表于 2024-3-19 14:11:23

感谢分享~
要是带选项，选择是否删除原有对象就完美了~

cfc 发表于 2024-5-22 11:05:47

感谢楼主，PDF转的CAD全都是碎的，正好可以试试这个神器
页: [1]
查看完整版本: 合并边界