倾家荡产请哪位大师能搞个多边形合并让大家学习

品茗新秀

倾家荡产所有请哪位大师能搞个多边形合并让大家学习

kwok

这里在论坛里找的，可以并集，差集，交集.

2. ;;复合线合并
   
3. (defun c:yad_plcomb(/ dxf chgent os qa entold kg s1 s2 n ss1 ss2 ent)
   
4.   (defun dxf(en val)
   
5.     (if (/= (type en) 'list) (setq en (entget en)))
   
6.     (cdr (assoc val en))
   
7.   )
   
8.   (defun chgent(ent n new / en)
   
9.     (setq en (entget ent))
   
10.     (if (assoc n en)
    
11.       (setq en (subst (cons n new) (assoc n en) en))
    
12.       (setq en (append en (list (cons n new))))
    
13.     )
    
14.     (entmod en)
    
15.   )
    
16.   (command "_.undo" "_be")
    
17.   (setq os (getvar "osmode")
    
18.         qa (getvar "qaflags")
    
19.   )
    
20.   (setvar "osmode" 0)
    
21.   (setvar "cmdecho" 0)
    
22.   (setq entold (entlast))
    
23.   (initget "1 2 3")
    
24.   (setq kg (getkword "\n选择合并方式[1 并集/2 差集/3 交集]：<1>"))
    
25.   (if (not kg) (setq kg "1"))
    
26.   (prompt "\n请选择复合线：")
    
27.   (if (setq s1 (ssget '((0 . "LWPOLYLINE"))))
    
28.     (progn
    
29.       (if (= kg "2")
    
30.         (progn
    
31.           (prompt "\n请选择要减去的复合线：")
    
32.           (setq s2 (ssget '((0 . "LWPOLYLINE"))))
    
33.         )
    
34.       )
    
35.       (if (not (and (= kg "2") (not s2)))
    
36.         (progn
    
37.           (setq n -1 ss1 (ssadd))
    
38.           (repeat (sslength s1)
    
39.             (setq ent (ssname s1 (setq n (1+ n))))
    
40.             (if (= (dxf ent 70) 0) (chgent ent 70 1))
    
41.             (command "_.region" ent "")
    
42.             (ssadd (entlast) ss1)
    
43.           )
    
44.         )
    
45.       )
    
46.       (if s2
    
47.         (progn
    
48.           (setq n -1 ss2 (ssadd))
    
49.           (repeat (sslength s2)
    
50.             (setq ent (ssname s2 (setq n (1+ n))))
    
51.             (if (= (dxf ent 70) 0) (chgent ent 70 1))
    
52.             (command "_.region" ent "")
    
53.             (ssadd (entlast) ss2)
    
54.           )
    
55.         )
    
56.       )
    
57.       (if (= kg "2")
    
58.         (if ss2 (command "_.subtract" ss1 "" ss2 ""))
    
59.         (command (if (= kg "1") "_.union" "_.intersect") ss1 "")
    
60.       )
    
61.       (setq ent (entlast))
    
62.       (if (and ent (= (dxf ent 0) "REGION") (not (equal ent entold)))
    
63.         (progn
    
64.           (command "_.explode" ent)
    
65.           (setq ss1 (ssget "p"))
    
66.           (if (= (dxf (ssname ss1 0) 0) "REGION")
    
67.             (progn
    
68.               (setvar "qaflags" 1)
    
69.               (command "_.explode" ss1 "")
    
70.               (setq ss1 (ssget "p"))
    
71.             )
    
72.           )
    
73.           (setq n -1)
    
74.           (while (setq ent (ssname ss1 (setq n (1+ n))))
    
75.             (if (entget ent)
    
76.               (command "_.pedit" ent "j" ss1 "" "")
    
77.             )
    
78.           )
    
79.         )
    
80.       )
    
81.     )
    
82.   )
    
83.   (setvar "osmode" os)
    
84.   (setvar "qaflags" qa)
    
85.   (command "_.undo" "_e")
    
86.   (princ)
    
87. )
    
88. (prompt "\n***复合线合并yad_plcomb***  YAD建筑")
    
89. (princ)

;;复合线合并<br /> (defun c:yad_plcomb(/ dxf chgent os qa entold kg s1 s2 n ss1 ss2 ent)<br />   (defun dxf(en val)<br />     (if (/= (type en) 'list) (setq en (entget en)))<br />     (cdr (assoc val en))<br />   )<br />   (defun chgent(ent n new / en)<br />     (setq en (entget ent))<br />     (if (assoc n en)<br />       (setq en (subst (cons n new) (assoc n en) en))<br />       (setq en (append en (list (cons n new))))<br />     )<br />     (entmod en)<br />   )<br />   (command "_.undo" "_be")<br />   (setq os (getvar "osmode")<br />         qa (getvar "qaflags")<br />   )<br />   (setvar "osmode" 0)<br />   (setvar "cmdecho" 0)<br />   (setq entold (entlast))<br />   (initget "1 2 3")<br />   (setq kg (getkword "\n选择合并方式[1 并集/2 差集/3 交集]：<1>"))<br />   (if (not kg) (setq kg "1"))<br />   (prompt "\n请选择复合线：")<br />   (if (setq s1 (ssget '((0 . "LWPOLYLINE"))))<br />     (progn<br />       (if (= kg "2")<br />         (progn<br />           (prompt "\n请选择要减去的复合线：")<br />           (setq s2 (ssget '((0 . "LWPOLYLINE"))))<br />         )<br />       )<br />       (if (not (and (= kg "2") (not s2)))<br />         (progn<br />           (setq n -1 ss1 (ssadd))<br />           (repeat (sslength s1)<br />             (setq ent (ssname s1 (setq n (1+ n))))<br />             (if (= (dxf ent 70) 0) (chgent ent 70 1))<br />             (command "_.region" ent "")<br />             (ssadd (entlast) ss1)<br />           )<br />         )<br />       )<br />       (if s2<br />         (progn<br />           (setq n -1 ss2 (ssadd))<br />           (repeat (sslength s2)<br />             (setq ent (ssname s2 (setq n (1+ n))))<br />             (if (= (dxf ent 70) 0) (chgent ent 70 1))<br />             (command "_.region" ent "")<br />             (ssadd (entlast) ss2)<br />           )<br />         )<br />       )<br />       (if (= kg "2")<br />         (if ss2 (command "_.subtract" ss1 "" ss2 ""))<br />         (command (if (= kg "1") "_.union" "_.intersect") ss1 "")<br />       )<br />       (setq ent (entlast))<br />       (if (and ent (= (dxf ent 0) "REGION") (not (equal ent entold)))<br />         (progn<br />           (command "_.explode" ent)<br />           (setq ss1 (ssget "p"))<br />           (if (= (dxf (ssname ss1 0) 0) "REGION")<br />             (progn<br />               (setvar "qaflags" 1)<br />               (command "_.explode" ss1 "")<br />               (setq ss1 (ssget "p"))<br />             )<br />           )<br />           (setq n -1)<br />           (while (setq ent (ssname ss1 (setq n (1+ n))))<br />             (if (entget ent)<br />               (command "_.pedit" ent "j" ss1 "" "")<br />             )<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (setvar "osmode" os)<br />   (setvar "qaflags" qa)<br />   (command "_.undo" "_e")<br />   (princ)<br /> )<br /> (prompt "\n***复合线合并yad_plcomb***  YAD建筑")<br /> (princ)

cable2004

命令：merge

扶风

楼上的功能待完善啊，有些动作效果不理想

香田里浪人

;;;;;边界轮廓线
;;最后转成pline线

(defun C:bjlk (/       *error* blk     obj     MinPt   MaxPt   hiden
              pt      pl      unnamed_block   isRus   tmp_blk adoc
              blks    lays    lay     oname   sel     csp     loc
              sc      ec      ret     DS      osm     iNSpT
             )

  (defun *error* (msg)
    (princ msg)
    (mapcar '(lambda (x) (vla-put-visible x :vlax-true)) hiden)
    (vla-endundomark adoc)
    (if (and tmp_blk
             (not (vlax-erased-p tmp_blk))
             (vlax-write-enabled-p tmp_blk)
        ) ;_ end of and
      (vla-erase tmp_blk)
    ) ;_ end of if
    (if osm
      (setvar "OSMODE" osm)
    ) ;_ end of if
    (foreach x loc (vla-put-lock x :vlax-true))
  ) ;_ end of defun
  (vl-load-com)
  (setvar "CMDECHO" 0)
  (setq osm (getvar "OSMODE"))
  (if (zerop (getvar "WORLDUCS"))
    (progn (vl-cmdf "_.UCS" "") (vl-cmdf "_.Plan" ""))
  ) ;_ end of if
  (setq isRus (= (getvar "SysCodePage") "ANSI_1251"))
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
        blks (vla-get-blocks adoc)
        lays (vla-get-layers adoc)
  ) ;_ end of setq
  (vla-startundomark adoc)
  (if isRus
    (princ "\n选择做一个轮廓的对象")
    (princ "\n选择做一个轮廓的对象")
  ) ;_ end of if
  (vlax-for lay lays
    (if (= (vla-get-lock lay) :vlax-true)
      (progn (vla-put-lock lay :vlax-false)
             (setq loc (cons lay loc))
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of vlax-for
  (if (setq sel (ssget))
    (progn
      (setq sel (ssnamex sel))
;;;    (setq iNSpT(apply 'mapcar (cons 'min
;;;     (mapcar 'cadr (apply 'append (mapcar '(lambda(x)(vl-remove-if-not 'listp x)) sel))))))
      (setq iNSpT '(0 0 0))
      (setq sel (mapcar 'vlax-ename->vla-object
                        (vl-remove-if 'listp (mapcar 'cadr sel))
                ) ;_ end of mapcar
      ) ;_ end of setq
      (setq csp (vla-objectidtoobject adoc (vla-get-ownerid (car sel))))
  ;;; (setq unnamed_block (vla-add (vla-get-blocks adoc)(vlax-3d-point '(0. 0. 0.)) "*U"))
      (setq unnamed_block
             (vla-add (vla-get-blocks adoc)
                      (vlax-3d-point inspt)
                      "*U"
             ) ;_ end of vla-add
      ) ;_ end of setq
      (foreach x sel
        (setq oname (strcase (vla-get-objectname x)))
        (cond ((member oname
                       '("ACDBVIEWPORT"
                         "ACDBATTRIBUTEDEFINITION"
                         "ACDBMTEXT"
                         "ACDBTEXT"
                        )
               ) ;_ end of member
               nil
              )
              ((= oname "ACDBBLOCKREFERENCE")
               (vla-insertblock
                 unnamed_block
                 (vla-get-insertionpoint x)
                 (vla-get-name x)
                 (vla-get-xscalefactor x)
                 (vla-get-yscalefactor x)
                 (vla-get-zscalefactor x)
                 (vla-get-rotation x)
               ) ;_ end of vla-InsertBlock
               (setq blk (cons x blk))
              )
              (t (setq obj (cons x obj)))
        ) ;_ end of cond
      ) ;_foreach
      (setq lay (vla-item lays (getvar "CLAYER")))
      (if (= (vla-get-lock lay) :vlax-true)
        (progn (vla-put-lock lay :vlax-false)
               (setq loc (cons lay loc))
        ) ;_ end of progn
      ) ;_ end of if
      (if obj
        (progn (vla-copyobjects
                 (vla-get-activedocument (vlax-get-acad-object))
                 (vlax-make-variant
                   (vlax-safearray-fill
                     (vlax-make-safearray
                       vlax-vbobject
                       (cons 0 (1- (length obj)))
                     ) ;_ end of vlax-make-safearray
                     obj
                   ) ;_ end of vlax-safearray-fill
                 ) ;_ end of vlax-make-variant
                 unnamed_block
               ) ;_ end of vla-copyobjects
        ) ;_ end of progn
      ) ;_ end of if
      (setq obj (append obj blk))
      (if obj
        (progn
          (setq tmp_blk (vla-insertblock
                          csp
                          (vlax-3d-point inspt)
                          (vla-get-name unnamed_block)
                          1.0
                          1.0
                          1.0
                          0.0
                        ) ;_ end of vla-insertblock
          ) ;_ end of setq
          (vla-getboundingbox tmp_blk 'MinPt 'MaxPt)
          (setq MinPt (vlax-safearray->list MinPt)
                MaxPt (vlax-safearray->list MaxPt)
                DS    (max (distance MinPt (list (car MinPt) (cadr MaxPt)))
                           (distance MinPt (list (car MaxPt) (cadr MinPt)))
                      ) ;_ end of max
                DS    (* 0.2 DS)                  ;1/5
                DS    (max DS 10)
                MinPt (mapcar '- MinPt (list DS DS))
                MaxPt (mapcar '+ MaxPt (list DS DS))
          ) ;_ end of setq
          (lib:Zoom2Lst (list MinPt MaxPt))
          (setq sset (ssget "_C" MinPt MaxPt))
          (if sset
            (progn
              (setvar "OSMODE" 0)
              (setq hiden (mapcar 'vlax-ename->vla-object
                                  (vl-remove-if
                                    'listp
                                    (mapcar 'cadr (ssnamex sset))
                                  ) ;_ end of vl-remove-if
                          ) ;_ end of mapcar
                    hiden (vl-remove tmp_blk hiden)
              ) ;_ end of setq
              (mapcar '(lambda (x) (vla-put-visible x :vlax-false))
                      hiden
              ) ;_ end of mapcar
              (setq pt (mapcar '+ MinPt (list (* 0.5 DS) (* 0.5 DS))))
              (vl-cmdf "_.RECTANG" (trans MinPt 0 1) (trans MaxPt 0 1))
              (setq pl (vlax-ename->vla-object (entlast)))
              (setq sc (entlast))
              (if
                (vl-catch-all-error-p
                  (vl-catch-all-apply
                    '(lambda ()
                       (vl-cmdf "_-BOUNDARY" (trans pt 0 1) "")
                       (while (> (getvar "CMDACTIVE") 0) (command ""))
                     ) ;_ end of lambda
                  ) ;_ end of VL-CATCH-ALL-APPLY
                ) ;_ end of VL-CATCH-ALL-ERROR-P
                 (if isRus
                   (princ "\n这不是构造的轮廓")
                   (princ "\n这不是构造的轮廓")
                 ) ;_ end of if
              ) ;_ end of if
              (setq ec sc)
              (while (setq ec (entnext ec))
                (setq ret (cons (vlax-ename->vla-object ec) ret))
                )
                (setq ret (vl-remove pl ret))
              (mapcar '(lambda (x) (vla-erase x) (vlax-release-object x))
                      (list pl tmp_blk)
              ) ;_ end of mapcar
              (setq pl nil
                    tmp_blk nil
              ) ;_ end of setq
              (setq
                ret (mapcar '(lambda (x / mipt)
                               (vla-getboundingbox x 'MiPt nil)
                               (setq MiPt (vlax-safearray->list MiPt))
                               (list MiPt x)
                             ) ;_ end of lambda
                            ret
                    ) ;_ end of mapcar
              ) ;_ end of setq
              (setq ret (vl-sort ret
                                 '(lambda (e1 e2)
                                    (< (distance MinPt (car e1))
                                       (distance MinPt (car e2))
                                    ) ;_ end of <
                                  ) ;_ end of lambda
                        ) ;_ end of vl-sort
              ) ;_ end of setq
              (setq pl  (nth 1 ret)
                    ret (vl-remove pl ret)
              ) ;_ end of setq
              (mapcar 'vla-erase (mapcar 'cadr ret))
              (mapcar '(lambda (x) (vla-put-visible x :vlax-true))
                      hiden
              ) ;_ end of mapcar
              (foreach x loc (vla-put-lock x :vlax-true))
              (if pl
                (progn
                  (initget "Yes No")
                  (if
                    (= (getkword (if isRus
                                   "\n删除对象？ [Yes/No] <No> : "
                                   "\n删除对象？ [Yes/No] <No> : "
                                 ) ;_ end of if
                       ) ;_ end of getkword
                       "Yes"
                    ) ;_ end of =
                     (mapcar '(lambda (x)
                                (if (vlax-write-enabled-p x)
                                  (vla-erase x)
                                ) ;_ end of if
                              ) ;_ end of lambda
                             obj
                     ) ;_ end of mapcar
                  ) ;_ end of if
                ) ;_ end of progn
                (if isRus
                  (princ "\n这不是构造的轮廓")
                  (princ "\n这不是构造的轮廓")
                ) ;_ end of if
              ) ;_ end of if
            ) ;_ end of progn
          ) ;_ end of if
        ) ;_ end of progn
      ) ;_ end of if
      (vl-catch-all-apply
        '(lambda ()
           (mapcar 'vlax-release-object
                   (list unnamed_block tmp_blk csp blks lays)
           ) ;_ end of mapcar
         ) ;_ end of lambda
      ) ;_ end of VL-CATCH-ALL-APPLY
    ) ;_ end of progn
  ) ;_if not
  (foreach x loc (vla-put-lock x :vlax-true))
  (setvar "OSMODE" osm)
  (vla-endundomark adoc)
  (vlax-release-object adoc)
  (princ)
) ;_ end of defun
;;; ========== HELPER FUNCTION ==========================================
(defun lib:IsPtInView (pt / VCTR Y_Len SSZ X_Pix Y_Pix X_Len Lc Uc)
  (setq pt (trans pt 0 1))
  (setq VCTR  (getvar "VIEWCTR")
        Y_Len (getvar "VIEWSIZE")
        SSZ   (getvar "SCREENSIZE")
        X_Pix (car SSZ)
        Y_Pix (cadr SSZ)
        X_Len (* (/ X_Pix Y_Pix) Y_Len)
        Lc    (polar VCTR (dtr 180.0) (* 0.5 X_Len))
        Uc    (polar Lc 0.0 X_Len)
        Lc    (polar Lc (dtr 270.0) (* 0.5 Y_Len))
        Uc    (polar Uc (dtr 90.0) (* 0.5 Y_Len))
  ) ;_ end of setq
  (if (and (> (car pt) (car Lc))
           (< (car pt) (car Uc))
           (> (cadr pt) (cadr Lc))
           (< (cadr pt) (cadr Uc))
      ) ;_ end of and
    t
    nil
  ) ;_ end of if
) ;_ end of defun

(defun DTR (a) (* pi (/ a 180.0)))

(defun lib:pt_extents (vlist / tmp)

  (setq
    tmp (mapcar
          '(lambda (x) (vl-remove-if 'null x))
          (mapcar
            '(lambda (what) (mapcar '(lambda (x) (nth what x)) vlist))
            '(0 1 2)
          ) ;_ end of mapcar
        ) ;_ end of mapcar
  ) ;_setq

  (list (mapcar '(lambda (x) (apply 'min x)) tmp)
        (mapcar '(lambda (x) (apply 'max x)) tmp)
  ) ;_ end of list
) ;_defun

(defun lib:Zoom2Lst (vlist / bl tr Lst OS)

  (setq Lst (lib:pt_extents vlist)
        bl  (car Lst)
        tr  (cadr Lst)
  ) ;_ end of setq
  (if (not (and (lib:IsPtInView bl) (lib:IsPtInView tr)))
    (progn (setq OS (getvar "OSMODE"))
           (setvar "OSMODE" 0)
           (command "_.Zoom"
                    "_Window"
                    (trans bl 0 1)
                    (trans tr 0 1)
                    "_.Zoom"
                    "0.95x"
           ) ;_ end of command
           (setvar "OSMODE" OS)
           t
    ) ;_ end of progn
    NIL
  ) ;_ end of if
) ;_ end of defun

扶风

香田里浪人 发表于 2014-2-15 15:05
;;;;;边界轮廓线
;;最后转成pline线

太强大了，就是这个

print1985

这哪里需要做程序啊 cad自己就能干
自己研究下bpoly命令吧
在多边形外面随意画个矩形做边界 用bpoly命令点击矩形和多边形之间的范围 cad会自动创建多边形边界

lpl

呵呵，bo直接搞定

xyp1964

2. ;; 需要e派工具箱(XCAD)的支持：[url]http://yunpan.cn/QXQKsW9gAPmpF[/url];; 多边形合并
   
3. (defun c:tt ()
   
4.   (xyp-CMDLA0)
   
5.   (if (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "层10102"))))
   
6.     (progn
   
7.       (xyp-MkLaCo "层10102" 1)
   
8.       (setq s0 (entlast)
   
9.             lst        (xyp-Region-Bpoly ss)
   
10.       )
    
11.       (xyp-erase (list ss (car lst)))
    
12.       (command "union" (cadr lst) "")
    
13.       (xyp-ExplodeQf (entlast))
    
14.       (xyp-ExplodeQf (xyp-SSelEntnext s0))
    
15.       (xyp-PeditJoin (xyp-SSelEntnext s0) 0)
    
16.     )
    
17.   )
    
18.   (xyp-CMDLA1)
    
19. )

;; 需要e派工具箱(XCAD)的支持：[url]http://yunpan.cn/QXQKsW9gAPmpF[/url];; 多边形合并<br /> (defun c:tt ()<br />   (xyp-CMDLA0)<br />   (if (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "层10102"))))<br />     (progn<br />       (xyp-MkLaCo "层10102" 1)<br />       (setq s0 (entlast)<br />             lst        (xyp-Region-Bpoly ss)<br />       )<br />       (xyp-erase (list ss (car lst)))<br />       (command "union" (cadr lst) "")<br />       (xyp-ExplodeQf (entlast))<br />       (xyp-ExplodeQf (xyp-SSelEntnext s0))<br />       (xyp-PeditJoin (xyp-SSelEntnext s0) 0)<br />     )<br />   )<br />   (xyp-CMDLA1)<br /> )

清风明月名字

谢谢楼主的分享！太好用了！收藏备用。