批量交点打断

fkyourmather

各位有批量交点打断！！各自塞下 总有个你觉得很好

守仁格竹GM

Free-Lancer 发表于 2013-4-19 11:04
贴一个复杂的
(defun c:Ea:ssbrk (/                 THINKING      removedups
                   ybl-pts-sortoncurve               ybl-m ...

{:soso_e113:} 这个是目前见到的打断中 运行最快 得到结果最好的一个 对于使用lisp而言

炫翔

遍历各个交点，删除对象，批量生成图元

fkyourmather

炫翔 发表于 2013-4-19 10:06

                               
登录/注册后可看大图

遍历各个交点，删除对象，批量生成图元

老大如果附上源码就更好了

炫翔

我分享个别人的，供参考！

[pcode=lisp,true];;;=======================[ BreakObjects.lsp ]==============================
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;               M A I N   S U B R O U T I N E                  
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun break_with (ss2brk ss2brkwith self / cmd intpts lst masterlist ss ssobjs
                   onlockedlayer ssget->vla-list list->3pair
                   get_interpts break_obj
                  )
  ;; ss2brk     selection set to break
  ;; ss2brkwith selection set to use as break points
  ;; self       when true will allow an object to break itself
  ;;            note that plined will break at each vertex
  (vl-load-com)

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;                S U B   F U N C T I O N S                     
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  (defun onlockedlayer (ename / entlst)
    (setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
    (= 4 (logand 4 (cdr (assoc 70 entlst))))
  )
  
  (defun ssget->vla-list (ss / i ename lst)
    (setq i -1)
    (while (setq ename (ssname ss (setq i (1+ i))))
      (setq lst (cons (vlax-ename->vla-object ename) lst))
    )
    lst
  )
  (defun list->3pair (old / new)
    (while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
                 old (cdddr old))
    )
    (reverse new)
  )
  
;;==============================================================
;;  return a list of intersect points
;;==============================================================
(defun get_interpts (obj1 obj2 / iplist)
  (if (not (vl-catch-all-error-p
             (setq iplist (vl-catch-all-apply
                            'vlax-safearray->list
                            (list
                              (vlax-variant-value
                                (vla-intersectwith obj1 obj2 acextendnone)
                              ))))))
    iplist
  )
)

;;==============================================================
;;  Break entity at break points in list
;;==============================================================
(defun break_obj (ent brkptlst / brkobjlst en enttype maxparam closedobj
        minparam obj obj2break p1param p2 p2param
   )
  (setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
  )
  (foreach brkpt brkptlst        ;  get last entity created via break
           ; in case multiple breaks
    (if brkobjlst
      (progn          ;  if pt not on object x, switch
           ; objects
(if (not (numberp (vl-catch-all-apply 'vlax-curve-getdistatpoint
           (list obj2break brkpt)
     )
   )
     )
   (foreach obj brkobjlst       ; find the one that pt is on
     (if (numberp (vl-catch-all-apply 'vlax-curve-getdistatpoint
          (list obj brkpt)
    )
  )
       (setq obj2break obj)     ; switch objects
     )
   )
)
      )
    )           ;  handle any objects that can not
           ; be used with the break command
           ;  using one point, gap of 0.000001
           ; is used
    (cond
      ((and
  (= "SPLINE" enttype)        ; only closed splines
  (vlax-curve-isclosed obj2break)
       )
(setq p1param (vlax-curve-getparamatpoint obj2break brkpt)
       p2 (vlax-curve-getpointatparam obj2break (+ p1param 0.000001))
)
(command "._break" obj2break "_non" (trans brkpt 0 1) "_non"
   (trans p2 0 1)
)
      )
      ((= "CIRCLE" enttype)        ; break the circle
(setq p1param (vlax-curve-getparamatpoint obj2break brkpt)
       p2 (vlax-curve-getpointatparam obj2break (+ p1param 0.000001))
)
(command "._break" obj2break "_non" (trans brkpt 0 1) "_non"
   (trans p2 0 1)
)
(setq enttype "ARC")
      )
      ((and
  (= "ELLIPSE" enttype)        ; only closed ellipse
  (vlax-curve-isclosed obj2break)
       )          ;  break the ellipse, code borrowed
           ; from joe burke  6/6/2005
(setq p1param (vlax-curve-getparamatpoint obj2break brkpt)
       p2param (+ p1param 0.000001)
       minparam (min
    p1param
    p2param
         )
       maxparam (max
    p1param
    p2param
         )
       obj (vlax-ename->vla-object obj2break)
)
(vlax-put obj 'startparameter maxparam)
(vlax-put obj 'endparameter (+ minparam (* pi 2)))
      )           ; ==================================
      (t          ;   objects that can be broken
(setq closedobj (vlax-curve-isclosed obj2break))
(command "._break" obj2break "_non" (trans brkpt 0 1) "_non"
   (trans brkpt 0 1)
)
(if (not closedobj)        ; new object was created
   (setq brkobjlst (cons (entlast) brkobjlst))
)
      )
    )
  )
)
  
  ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  ;;                   S T A R T   H E R E                        
  ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    (if (and ss2brk ss2brkwith)
    (progn
      ;;  CREATE a list of entity & it's break points
      (foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk
        (if (not (onlockedlayer (vlax-vla-object->ename obj)))
          (progn
            (setq lst nil)
            ;; check for break pts with other objects in ss2brkwith
            (foreach intobj (ssget->vla-list ss2brkwith)
              (if (and (or self (not (equal obj intobj)))
                       (setq intpts (get_interpts obj intobj))
                  )
                (setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
              )
            )
            (if lst
              (setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
            )
          )
        )
      )
      ;;  masterlist = ((ent brkpts)(ent brkpts)...)
      (if masterlist
        (foreach obj2brk masterlist
          (break_obj (car obj2brk) (cdr obj2brk))
        )
      )
      )
  )
;;==============================================================
)
(princ)

;;==========================================
;;        Break all objects selected        
;;==========================================
(defun c:breakall (/ cmd ss)
  (command ".undo" "begin")
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  ;;  get objects to break
  (prompt "\nSelect All objects to break & press enter: ")
  (if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
     (Break_with ss ss nil) ; ss2break ss2breakwith (flag nil = not to break with self)
  )
  (setvar "CMDECHO" cmd)
  (command ".undo" "end")
  (princ)
)

;;==========================================
;;  Break a single object with many objects
;;==========================================
(defun c:BreakObject (/ cmd ss1 ss2)
  (command ".undo" "begin")
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  ;;  get objects to break
  (prompt "\nSelect single object to break: ")
  (if (and (setq ss1 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
           (not (redraw (ssname ss1 0) 3))
           (not (prompt "\n***  Select object(s) to break with & press enter:  ***"))
           (setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
           (not (redraw (ssname ss1 0) 4)))
     (Break_with ss1 ss2 nil) ; ss2break ss2breakwith (flag nil = not to break with self)
  )
  (setvar "CMDECHO" cmd)
  (command ".undo" "end")
  (princ)
)
;;==========================================
;;  Break many objects with a single object
;;==========================================
(defun c:breakwobjects (/ cmd ss1 ss2)
  (defun ssredraw (ss mode / i num)
    (setq i -1)
    (while (setq ename (ssname ss (setq i (1+ i))))
      (redraw (ssname ss i) mode)
    )
  )
  (command ".undo" "begin")
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  ;;  get objects to break
  (prompt "\nSelect object(s) to break & press enter: ")
  (if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
           (not (ssredraw ss1 3))
           (not (prompt "\n***  Select single object to break with:  ***"))
           (setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
           (not (ssredraw ss1 4))
      )
    (break_with ss1 ss2 nil) ; ss2break ss2breakwith (flag nil = not to break with self)
  )
  (setvar "CMDECHO" cmd)
  (command ".undo" "end")
  (princ)
)
;;==========================================
;;  Break many objects with many object     
;;==========================================
(defun c:BreakWith (/ cmd ss1 ss2)
  (defun ssredraw (ss mode / i num)
    (setq i -1)
    (while (setq ename (ssname ss (setq i (1+ i))))
      (redraw (ssname ss i) mode)
    )
  )
  (command ".undo" "begin")
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  ;;  get objects to break
  (prompt "\nSelect object(s) to break & press enter: ")
  (if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
           (not (ssredraw ss1 3))
           (not (prompt "\n***  Select object(s) to break with & press enter:  ***"))
           (setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
           (not (ssredraw ss1 4))
      )
    (break_with ss1 ss2 nil) ; ss2break ss2breakwith (flag nil = not to break with self)
  )
  (setvar "CMDECHO" cmd)
  (command ".undo" "end")
  (princ)
)

;;=============================================
;;  Break many objects with a selected objects
;;  Selected Objects create ss to be broken   
;;=============================================
(defun c:BreakTouching (/ cmd ss1 ss2)
  
  ;;  get all objects touching entities in the sscross
  ;;  limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
  (defun gettouching (sscros / ss lst lstb lstc objl)
    (and
      (setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
            objl (mapcar 'vlax-ename->vla-object lstb)
      )
      (setq
        ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
                             (cons 410 (getvar "ctab"))))
      )
      (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (setq lst (mapcar 'vlax-ename->vla-object lst))
      (mapcar
        '(lambda (x)
           (mapcar
             '(lambda (y)
                (if (not
                      (vl-catch-all-error-p
                        (vl-catch-all-apply
                          '(lambda ()
                             (vlax-safearray->list
                               (vlax-variant-value
                                 (vla-intersectwith y x acextendnone)
                               ))))))
                  (setq lstc (cons (vlax-vla-object->ename x) lstc))
                )
              ) objl)
         ) lst)
    )
    lstc
  )
  (command ".undo" "begin")
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq ss1 (ssadd))
  ;;  get objects to break
  (if (and (not (prompt "\nSelect object(s) to break with & press enter: "))
           (setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
           (mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
      )
    (break_with ss1 ss2 nil) ; ss2break ss2breakwith (flag nil = not to break with self)
  )
  (setvar "CMDECHO" cmd)
  (command ".undo" "end")
  (princ)
)

;;==========================================================
;;  Break selected objects with any objects that touch it  
;;==========================================================

(defun c:BreakSelected (/ cmd ss1 ss2)
  
  ;;  get all objects touching entities in the sscross
  ;;  limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
  (defun gettouching (sscros / ss lst lstb lstc objl)
    (and
      (setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
            objl (mapcar 'vlax-ename->vla-object lstb)
      )
      (setq
        ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
                             (cons 410 (getvar "ctab"))))
      )
      (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (setq lst (mapcar 'vlax-ename->vla-object lst))
      (mapcar
        '(lambda (x)
           (mapcar
             '(lambda (y)
                (if (not
                      (vl-catch-all-error-p
                        (vl-catch-all-apply
                          '(lambda ()
                             (vlax-safearray->list
                               (vlax-variant-value
                                 (vla-intersectwith y x acextendnone)
                               ))))))
                  (setq lstc (cons (vlax-vla-object->ename x) lstc))
                )
              ) objl)
         ) lst)
    )
    lstc
  )
  (command ".undo" "begin")
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq ss1 (ssadd))
  ;;  get objects to break
  (if (and (not (prompt "\nSelect object(s) to break with & press enter: "))
           (setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
           (mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
      )
    (break_with ss2 ss1 nil) ; ss2break ss2breakwith (flag nil = not to break with self)
  )
  (setvar "CMDECHO" cmd)
  (command ".undo" "end")
  (princ)
)
[/pcode]

fkyourmather

炫翔 发表于 2013-4-19 10:21

                               
登录/注册后可看大图

我分享个别人的，供参考！

;;;=======================[ BreakObjects.lsp ]========================== ...

非常好用的大家踊跃的出来啊

Free-Lancer

贴一个复杂的
[pcode=lisp,true](defun c:Ea:ssbrk (/                 THINKING      removedups
                   ybl-pts-sortoncurve               ybl-mklwpline
                   ybl-mkellipse ybl-mkline    ybl-mkarc
                   ybl-circletoarc               sstolist
                   lll                 ss               cset
                   eDoc                 n               oldos
                   t1                 sl
                  )
  (defun THINKING (prmpt)
    (setq n (1+ n))
    (princ (strcat "\r"
                   (nth (rem n 4) '("|" "/" "-" "\\"))
                   prmpt
           )
    )
  )
  (defun removedups (lst / p pl)
    (while lst
      (setq p (car lst))
      (if (not (equal p (car pl)))
        (setq pl (cons p pl))
      )
      (setq lst (cdr lst))
    )
    (reverse pl)
  )
  ;;端点判断
  (defun ispoint (lst p1 p2)
    (and (= (length pts) 2)
         (or (and (equal (car pts) sp 1e-9)
                  (equal (cadr pts) ep 1e-9)
             )
             (and (equal (car pts) ep 1e-9)
                  (equal (cadr pts) sp 1e-9)
             )
         )
    )
  )
  ;;Break 去除端点
  (defun removepoint (lst p1 p2)
    (if        (equal (car lst) p1 1e-9)
      (setq lst (cdr lst))
    )
    (if        (equal (last lst) p2 1e-9)
      (setq lst (reverse (cdr (reverse lst))))
    )
    lst
  )
  ;;交点沿曲线排升序
  (defun ybl-pts-sortoncurve (e pts / pl sp ep el typ)
    (if        (and (setq sp (vlax-curve-getstartpoint e)
                   ep (vlax-curve-getendpoint e)
             )
             (ispoint pts sp ep)
        ) ;_ startpoint and endpoint
      (setq pts nil)
      ;;circle ellipse 不一定需要 startpoint endpoint
      (progn
        (if (not (vlax-curve-isclosed e))
          (setq pts (cons sp (cons ep pts)))
        )
        (setq
          pts
           (removedups
             (vl-sort
               (mapcar '(lambda        (x)
                          (list        (vlax-curve-getparamatpoint
                                  e
                                  (vlax-curve-getclosestpointto e x)
                                )
                                x
                          )
                        )
                       pts
               )
               '(lambda (e1 e2) (< (car e1) (car e2)))
             )
           )
        )
      )
    ) ;_ remove startpoint
    pts
  )
  ;;断开 spline pline，闭合 spline 不能打断
  (defun ybl-brkspline (lst / e pts p0 pam)
    (setq e   (car lst)
          pts (reverse (mapcar 'cadr
                               (ybl-pts-sortoncurve
                                 e
                                 (cdr lst)
                               )
                       )
              ) ;_ 逆序)
    )
    (if        pts
      (if (and (vlax-curve-isclosed e) ;_ closed
               (> (length pts) 1)
          ) ;_两个以上交点才断开
        (progn
          (setq        p0  (car pts)
                pts (cdr pts)
                pam (vlax-curve-getparamatpoint
                      e
                      (vlax-curve-getclosestpointto e p0)
                    )
          )
          (vl-cmdf ".break"
                   e
                   "_non"
                   p0
                   "_non"
                   (vlax-curve-getpointatparam e (+ pam 0.0000001))
          ) ;_两个交点以上先断开一个小口
          (setq pts (removepoint pts sp ep))
          (if pts
            (foreach p pts
              (vl-cmdf ".break" e p p)
            )
          )
        )
        (progn ;_ opened          
          (setq        pts (removepoint
                      pts
                      (vlax-curve-getstartpoint e)
                      (vlax-curve-getendpoint e)
                    )
          )
          (if pts
            (foreach p pts
              (vl-cmdf ".break" e p p)
            )
          )
        )
      )
    )
  )
  (defun ybl-mklwpline (lst  /          e    el   pts         c70  h0   h1        pl
                        vn   i          vp   vvp  v         nnp  tf   p1        b
                        vn   vertexinfo            l         a    bugle        e
                        ew   few  forp fsw  spam sw   x
                       )
    (setq e   (car lst)
          el  (entget e '("*"))
          c70 (cdr (assoc 70 el))
    )
    (if        (or (= (logand c70 4) 4) ;_Fit
            (= (logand c70 2) 2) ;_spline
        )
      (progn
        (setq pts (mapcar 'cadr (ybl-pts-sortoncurve e (cdr lst)))
              pts (removepoint
                    pts
                    (vlax-curve-getstartpoint e)
                    (vlax-curve-getendpoint e)
                  )
        )
        (if pts
          (progn
            (vl-cmdf ".break" e (car pts) (car pts))
            (foreach p (cdr pts)
              (vl-cmdf
                ".break"
                (entlast)
                (setq p1 (vlax-curve-getclosestpointto (entlast) p))
                p1
              ) ;_ 对拟和 pline 断开后均为新实体,原实体消失
            )
          )
        )
      )
      ;;Lwpolyline 非样条化Polyline 3Dpolyline 用 entmake
      (progn
        (setq pts (ybl-pts-sortoncurve e (cdr lst))
              pts (removepoint
                    (mapcar 'cadr pts)
                    (vlax-curve-getstartpoint e)
                    (vlax-curve-getendpoint e)
                  ) ;_去除起点、终点
        )
        (if pts
          (progn
            (if        (= (cdr (assoc 0 el)) "LWPOLYLINE") ;_lwpolyline
              (progn
                (setq pts (mapcar
                            '(lambda (x)
                               (list (vlax-curve-getparamatpoint
                                       e
                                       (vlax-curve-getclosestpointto e x)
                                     )
                                     (list 10 (car x) (cadr x))
                               )
                             )
                            pts
                          ) ;_((param (10 x1 y1)) ....
                      h0  (list        '(0 . "LWPOLYLINE")
                                '(100 . "AcDbEntity")
                                (assoc 8 el)
                                '(100 . "AcDbPolyline")
                          )
                      h1  (vl-remove 'nil
                                     (list '(70 . 0) ;_断开的肯定是非闭合了
                                           (assoc 43 el)
                                           (assoc 38 el)
                                           (assoc 39 el)
                                     )
                          )
                      pl  (member (assoc 10 el) el)
                      vn  (cdr (assoc 90 el))
                      i          0.
                )
                (repeat        vn
                  (setq        vp (cons (list i
                                       (car pl)
                                       (cadr pl)
                                       (caddr pl)
                                       (cadddr pl)
                                 )
                                 vp
                           )
                        pl (cddddr pl)
                        i  (1+ i)
                  )
                ) ;_顶点信息表((param vertex startwidth endwidth bugle) ...)
                (setq vp         (reverse vp) ;_(removedups (reverse vp))
                      vertexinfo vp
                )
                (if (vlax-curve-isclosed e)
                  (setq
                    vp (append
                         vp
                         (list
                           (cons (vlax-curve-getendparam e) (cdar vp))
                         )
                       )
                  )
                )
                (setq vp (append pts vp) ;_合并点表
                      vp (vl-sort vp
                                  '(lambda (e1 e2) (< (car e1) (car e2)))
                         )
                )
                ;;分组，子表长度为 2 的是交点
                (while vp
                  (setq        v  (car vp)
                        vp (cdr vp)
                  )
                  (if vvp
                    (progn
                      (setq
                        vvp
                         (cons (append (list v) (car vvp)) (cdr vvp))
                      )
                      (if (= (length v) 2) ;_ inters
                        (progn
                          (setq vvp (cons (list v) vvp))
                          (if (= (length (car vp)) 1)
                            (setq vp (cdr vp))
                          )
                        )
                      )
                    )
                    (setq vvp (cons (list v) vvp))
                  )
                )
                (setq vvp (vl-remove-if
                            '(lambda (x) (= (length x) 1))
                            (reverse (mapcar 'reverse vvp))
                          )
                ) ;_方向和原线一致
                ;;对交点增加弧度,首尾宽度
                ;;弧度只和当前段有关
                ;;|起始为交点的时候修改起始宽度
                (foreach l vvp
                  (setq vn (length l)) ;_新线段的顶点数
                                        ; ;|
                  (setq a (car l))
                  (if (= (length a) 2) ;_交点
                    (progn
                      (setq spam (fix (car a))
                            forp (assoc spam vertexinfo) ;_(index point startwidth endwidth bugle)
                            fsw         (nth 2 forp)
                            few         (nth 3 forp)
                            tf         (< (cdr (last forp)) 0.)
                      )
                      (if (equal (cdr fsw) (cdr few))
                        (setq sw fsw
                              ew few
                        ) ;_等宽
                        (progn
                          (setq        sw (cons 40
                                         (+ (* (- (car a) spam) ;_前顶点StartWidth
                                               (- (cdr few) (cdr fsw))
                                            ) ;_前顶点Endwidth
                                            (cdr fsw)
                                         )
                                   ) ;_末端宽度成比例
                          )
                          (setq        ew (cons 41
                                         (+ (* (- (car (cadr l)) spam)
                                               (- (cdr few) (cdr fsw))
                                            ) ;_前顶点Endwidth
                                            (cdr fsw)
                                         )
                                   ) ;_末端宽度成比例
                          )
                        )
                      )
                      ;;bugle
                      ;;肯定是中间段，Bugle要计算
                      (setq bugle (/ (distance
                                       (vlax-curve-getpointatparam
                                         e
                                         (/ (+ (car a) (caadr l)) 2.)
                                       )
                                       (ybl-midp (cdadr a)
                                                 (cdr (cadadr l))
                                                 t
                                       )
                                     )
                                     (/        (distance (cdadr a)
                                                  (cdr (cadadr l))
                                        )
                                        2.
                                     )
                                  )
                      )
                      (if tf
                        (setq bugle (- bugle))
                      )
                      (setq l (cons (list (car a) ;_ param
                                          (cadr a) ;_ point
                                          sw ;_startwidth
                                          ew ;_endwidth
                                          (cons 42 bugle) ;_bugle
                                    )
                                    (cdr l)
                              )
                      )
                    )
                  )
                  ;;|末尾是交点的时候要修改前一点的结束宽度
                  (if (= (length (last l)) 2) ;_交点
                    (progn
                      (setq spam (fix (car a))
                            forp (cadr (reverse l))
                                        ; spam vertexinfo) ;_(index point startwidth endwidth bugle)
                            fsw         (nth 2 forp)
                            few         (nth 3 forp)
                      )
                      (if (equal (cdr fsw) (cdr few))
                        (setq sw fsw
                              ew few
                        ) ;_等宽
                        (setq sw fsw
                              ew (cons 41
                                       (+ (* (- (car (last l)) spam) ;_前顶点StartWidth
                                             (- (cdr few) (cdr fsw)) ;_前顶点Endwidth
                                          )
                                          (cdr fsw)
                                       )
                                 ) ;_末端宽度成比例
                        )
                      )
                      ;;bugle
                      ;;肯定是中间段，Bugle要计算
                      (setq bugle
                             (/        (distance
                                  (vlax-curve-getpointatparam
                                    e
                                    (/ (+ (car (last l))
                                          (car (cadr (reverse l)))
                                       )
                                       2.
                                    )
                                  )
                                  (ybl-midp (cdadr (last l))
                                            (cdadr (cadr (reverse l)))
                                            t
                                  )
                                )
                                (/ (distance (cdadr (last l))
                                             (cdadr (cadr (reverse l)))
                                   )
                                   2.
                                )
                             )
                      )
                      (if (< (cdr (assoc 42 (reverse l))) 0.)
                        (setq bugle (- bugle))
                      )
                      (setq l (subst (list (car forp) ;_ param
                                           (cadr forp) ;_ point
                                           sw ;_startwidth
                                           ew ;_endwidth
                                           (cons 42 bugle) ;_bugle
                                     )
                                     (assoc spam l)
                                     l
                              )
                      )
                    )
                  )
                  (entmake
                    (append h0
                            (list (cons 90 vn))
                            h1
                            (apply 'append (mapcar 'cdr l))
                                        ;vp ;_ 210
                    )
                  )
                )
              )
              ;;polyline
              (progn
                (setq pts (mapcar 'cadr (ybl-pts-sortoncurve e (cdr lst)))
                      pts (removepoint
                            pts
                            (vlax-curve-getstartpoint e)
                            (vlax-curve-getendpoint e)
                          )
                )
                (if pts
                  (progn
                    (vl-cmdf ".break" e (car pts) (car pts))
                    (foreach p (cdr pts)
                      (vl-cmdf
                        ".break"
                        (entlast)
                        (setq p1
                               (vlax-curve-getclosestpointto (entlast) p)
                        )
                        p1
                      ) ;_ 对拟和 pline 断开后均为新实体,原实体消失
                    )
                    (entdel e)
                  )
                )
              )
            )
            (entdel e)
          )
        )
      )
    )
  )
  ;;Ellipse 分段
  (defun ybl-mkellipse (lst / e el pams pcen an)
    (setq e    (car lst)
          pams (mapcar 'car (ybl-pts-sortoncurve e (cdr lst)))
    )
    (if        pams
      (progn
        (setq el   (entget e '("*"))
              pcen (cdr (assoc 10 el))
              an   (angle pcen (vlax-curve-getstartpoint e))
        )
        (if (vlax-curve-isclosed e)
          (setq pams (append pams (list (+ (car pams) pi pi))))
        )
        (if (> (length pams) 2)
          (progn
            (mapcar
              '(lambda (x y)
                 (entmake (append el (list (cons 41 x) (cons 42 y))))
               )
              (cdr pams)
              (cddr pams)
            )
            (entmod
              (append el
                      (list (cons 41 (car pams)) (cons 42 (cadr pams)))
              )
            )
          )
        )
      )
    )
  )
  ;;Line 分段
  (defun ybl-mkline (lst / sp ep ln el pts)
    (setq ln  (car lst)
          sp  (vlax-curve-getstartpoint ln)
          ep  (vlax-curve-getendpoint ln)
          pts (removedups
                (vl-sort
                  (cons ep (cons sp (cdr lst)))
                  '(lambda (e1 e2)
                     (if (equal (cadr e1) (cadr e2) 1e-9)
                       (< (car e1) (car e2))
                       (< (cadr e1) (cadr e2))
                     )
                   )
                )
              )
    )
    (if        (> (length pts) 2)
      (progn
        (setq el (entget ln '("*")))
        (mapcar        '(lambda (x y / l)
                   (entmake (append el (list (cons 10 x) (cons 11 y))))
                 )
                (cdr pts)
                (cddr pts)
        )
        (entmod
          (append el (list (cons 10 (car pts)) (cons 11 (cadr pts))))
        )
      )
    )
  )
  ;;分段 Arc
  (defun ybl-mkarc (lst / arc pamlst el)
    (setq arc         (car lst)
          pamlst (mapcar 'car (ybl-pts-sortoncurve arc (cdr lst)))
    )
    (if        (> (length pamlst) 2)
      (progn
        (setq el (entget arc))
        (mapcar        '(lambda (x y / l)
                   (entmake (append el (list (cons 50 x) (cons 51 y))))
                 )
                (cdr pamlst)
                (cddr pamlst)
        )
        (entmod
          (append el
                  (list (cons 50 (car pamlst)) (cons 51 (cadr pamlst)))
          )
        )
      )
    )
  )
  ;;圆转化为 Arc
  (defun ybl-circletoarc (lst / e el pam rs lyr th pcen)
    (setq e   (car lst)
          pam (mapcar 'car (ybl-pts-sortoncurve e (cdr lst)))
    )
    (if        (> (length pam) 1)
      (progn
        (setq el   (entget e '("*"))
              rs   (assoc 40 el)
              lyr  (assoc 8 el)
              pcen (assoc 10 el)
              th   (if (setq th (assoc 39 el))
                     th
                     (setq th '(39 . 0.))
                   )
        )
        (mapcar        '(lambda (x y / l)
                   (setq l (list '(0 . "ARC")
                                 '(100 . "AcDbEntity")
                                 '(100 . "AcDbArc")
                                 pcen
                                 lyr
                                 th
                                 rs
                                 (cons 50 x)
                                 (cons 51 y)
                                 '(210 0. 0. 1.)
                           )
                   )
                   (entmake l)
                 )
                pam
                (append (cdr pam) (list (+ (car pam) pi pi)))
        )
        (entdel e)
      )
    )
  )
  ;;选择集转化为列表
  ;;实体列表、实体类型+句柄列表、Object列表
  ;;三者是一一对应关系
  (defun sstolist (ss / ssl i el typl eel typ c70 key)
    (setq ssl (sslength ss)
          i   -1
    )
    (thinking
      (strcat "\r共 " (itoa ssl) " 个实体排序中，请稍候.....")
    )
    (if        (> ssl 800)
      (progn
        (initget "Y N")
        (setq key
               (getkword
                 "\n本次处理将耗费较多的时间! 建议分区域处理, 是否继续[Y/N]<N>: "
               )
        )
        (if (= key "N")
          (exit)
        )
      )
    )
    (repeat ssl
      (setq e        (ssname ss (setq i (1+ i)))
            typ        (cdr (assoc 0 (setq l (entget e))))
      )
      (if (/= typ "POLYLINE")
        (setq el (cons e el))
        (progn
          (setq c70 (cdr (assoc 70 l)))
          (if (and (zerop (logand c70 16))
                   (zerop (logand c70 32))
                   (zerop (logand c70 64))
              )
            (setq el (cons e el))
          )
        )
      )
    ) ;_速度最快
    (vlax-for obj (vla-get-activeselectionset
                    (vla-get-activedocument (vlax-get-acad-object))
                  )
      (if (not (wcmatch (vla-get-objectname obj) "*Mesh"))
        (setq eel (cons obj eel))
      )
    ) ;_ 比 vlax-ename->vla-object 快
    (setq
      typl (mapcar '(lambda (x / l)
                      (setq l (entget x))
                      (strcat (cdr (assoc 0 l)) (cdr (assoc 5 l)))
                    )
                   el
           )
    ) ;_ 表出来，取出类型+句柄
    (list el typl eel)
  )
  ;;曲线集交点，将交点分配到实体上
  (defun ybl-ss-inters (ss   /          ll   el   obj         o1   ol   o2        pts
                        ptl  typl typ  e1   yl         zl   e2   typ1        nn
                        cs   lst
                       )
    (setq ll   (sstolist ss)
          el   (car ll) ;_ entity
          obj  (last ll) ;_ object list
          typl (cadr ll) ;_ type
          lll  typl
          nn   1
    )
    (mapcar '(lambda (x) (set (read x) nil)) lll)
    (while obj
      (thinking
        (strcat        "\r共 "
                (itoa sl)
                " 个实体, 第 "
                (itoa nn)
                " 求交点，请稍候....."
        )
      )
      (setq o1         (car obj) ;_ object 1
            obj         (cdr obj)
            typ         (car typl)
            typl (cdr typl)
            e1         (car el)
            el         (cdr el)
            zl         el
            ol         obj
            yl         typl
            nn         (1+ nn)
      )
      (while ol
        (setq o2   (car ol) ;_ object 2
              ol   (cdr ol)
              typ1 (car yl)
              yl   (cdr yl)
              e2   (car zl)
              zl   (cdr zl)
        )
        (if (setq pts (safearray-value
                        (variant-value
                          (vla-intersectwith o1 o2 acextendnone)
                        )
                      )
            )
          (progn
            (setq ptl (ybl-lst-split pts 3))
            (if        (eval (read typ))
              (set (read typ) (append ptl (eval (read typ))))
              (set (read typ) (append ptl (list e1)))
            )
            (if        (eval (read typ1))
              (set (read typ1) (append ptl (eval (read typ1))))
              (set (read typ1) (append ptl (list e2)))
            )
          )
        )
      )
    )
    (if        lll
      (progn
        (setq cs 1)
        ;;断开曲线
        (foreach a (vl-sort lll '<)
          (princ (strcat "\r处理实体 "
                         (itoa sl)
                         " 中第 "
                         (itoa cs)
                         " 个曲线"
                 )
          )
          (setq        cs  (1+ cs)
                lst (reverse (eval (read a)))
          )
          (if lst
            (cond
              ((wcmatch a "ARC*")
               (ybl-mkarc (reverse (eval (read a))))
              )
              ((wcmatch a "CIRCLE*")
               (ybl-circletoarc (reverse (eval (read a))))
              )
              ((wcmatch a "ELLIPSE*")
               (ybl-mkellipse (reverse (eval (read a))))
              )
              ((wcmatch a "LINE*")
               (ybl-mkline (reverse (eval (read a))))
              )
              ((wcmatch a "*POLYLINE*")
               (ybl-mklwpline (reverse (eval (read a))))
              )
              (t (ybl-brkspline (reverse (eval (read a)))))
            )
          )
        )
      )
    )
  )
  ;;Main
  ;;kLine kArc kCircle kPline kSpline
  (if (not (vl-catch-all-error-p
             (setq cset
                    (vl-catch-all-apply
                      'vla-item
                      (list
                        (vla-get-selectionsets
                          (setq
                            eDoc (vla-get-activedocument (vlax-get-acad-object))
                          )
                        )
                        "CURRENT"
                      )
                    )
             )
           )
      )
    (vla-delete cset)
  )
  (vla-startundomark eDoc)
  (setq oldos (getvar "osmode"))
  (setvar "osmode" 0)
  (princ
    "\n选择Line,ellipse,arc,circle,spline,lwpolyline,polyline....."
  )
  (vl-catch-all-apply
    '(lambda (/ ss)
       (if (setq ss
                  (ssget ":L"
                         '((0 . "ellipse,line,*polyline,arc,circle,spline"))
                  )
           ) ;_选择时过滤
         (progn
           (setq t1 (ybl-getutime)
                 sl (sslength ss)
                 n  0
           )
           (ybl-ss-inters ss)
         )
       )
     )
    nil
  )
  (mapcar '(lambda (x) (set (read x) nil)) lll)
  (setq lll nil)
  (setvar "osmode" oldos)
  (vla-endundomark eDoc)
  (if t1
    (progn (princ "\rOk, 共耗时")
           (princ (- (ybl-getutime) t1))
           (princ "秒.                       ")
    )
  )
  (princ)
)
[/pcode]

牢固

批量交点打断，除了Spline曲线外，其他曲线最好都不要用Break命令，以提高效率！

XDSoft

牢固 发表于 2013-4-19 12:03

                               
登录/注册后可看大图

批量交点打断，除了Spline曲线外，其他曲线最好都不要用Break命令，以提高效率！

嗯嗯，不只这个程序，能尽量不用command就尽量不用。

牢固

XDSoft 发表于 2013-4-19 12:51

                               
登录/注册后可看大图

嗯嗯，不只这个程序，能尽量不用command就尽量不用。

对于不涉及程序运行效率的时候，其实用哪种方法都无所谓，只要代码简单、能实现目的就OK了！我们的终极目的是提高绘图效率！

Free-Lancer

6# 楼的代码好像仅Spline用了Break, 其他的都是Entmake新实体

cuyongping

谢谢提供！正需要了！

SmartStar

Free-Lancer 发表于 2013-4-19 11:04

                               
登录/注册后可看大图

贴一个复杂的
(defun c:Ea:ssbrk (/                 THINKING      removedups
                   ybl-pts-sortoncurve               ybl-m ...

试用了一下，没有成功。好象缺少子函数。

Free-Lancer

SmartStar 发表于 2013-5-7 12:38

                               
登录/注册后可看大图

试用了一下，没有成功。好象缺少子函数。

那些函数很简单，看名字也能在论坛搜索到

GTJ116600

呵呵，又是批量交点打断，好呀

taner

Free-Lancer 发表于 2013-4-19 11:04
贴一个复杂的
(defun c:Ea:ssbrk (/                 THINKING      removedups
                   ybl-pts-sortoncurve               ybl-m ...

当年找EA这个程序没找到，想模仿一个也没成功，今天终于见到了！