图形功能(处理存在图形) - 批量交点打断 - 《技术博客》

;;;=======================[ BreakObjects.lsp ]==============================
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;               M A I N   S U B R O U T I N E                   
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun break_with (ss2brk ss2brkwith self / break_obj cmd get_interpts intpts list->3pair lst masterlist onlockedlayer ss ssget->vla-list ssobjs)
  ;; 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 closedobj en enttype maxparam 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 ssredraw)
  (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 ssredraw)
  (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 gettouching 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 gettouching 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)
)
;;;对原程序243-266行代码进行了改进：      
;;==========================================
;;  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)
;  (setq xuanz nil)
;  ;;  get objects to break
;  (prompt "\n选择要打断的直线或多线段，按回车确定: ")
;  (if (and
;                (setq ss1
;                    (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")))
;                    xuanz (ssget "P" '((0 . "LWPOLYLINE") (70 . 1)));取出选中的闭合多段线，一般为矩形或多边形命令创建
;                    flag1 (if (/= ss1 nil) T);判断选择集ss1是否非空
;                )
;                (not (ssredraw ss1 3))
;                (not
;                    (prompt
;                        "\n***  选择作为打断线的直线或多线段，按回车确定:  ***"
;                    )
;                )
;                (setq
;                    ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")))
;                    ssd  (ssredraw ss1 4);新增
;                    flag2 (if (/= ss2 nil) T);判断选择集ss2是否非空
;                )
;                ;(not (ssredraw ss1 4))把该语句放在上面的setq语句群里，避免ss2为nil时本句不被执行的意外情况
;      )
;    (progn
;      (if(/= xuanz nil)
;        (progn
;                    (setq snum -1)
;                    (repeat (SSLENGTH xuanz)
;                        (setq a (entget (ssname xuanz (setq snum (+ 1 snum)))));取出xuanz中的每个闭合多线段
;                        (setq num (cdr (assoc 90 a)))        ;多线段顶点数量
;                        (setq pnum (- (length a) (length (member (assoc 10 a) a))))
;                        ;pnum为多线段第一个顶点坐标子列表所在项数（组码10）
;                        (setq qdlst (PARTLIST1 pnum (+ pnum 4) a))
;                        ;第一个端点列表
;                        (setq tou (PartList1 0 (- (length a) 2) a))
;                        ;原列表去掉最后一个元素后的新列表
;                        (setq zhong (append tou qdlst))
;                        ;新列表插入第一个端点坐标
;                        (setq wei (nth (- (length a) 1) a))
;                        ;保存原列表最后一个元素
;                        (setq a (append zhong (list wei)))
;                        ;加入原列表最后一个元素
;                        (setq a (subst (cons 70 0) (assoc 70 a) a))
;                        ;将闭合多线段改为非闭合多线段
;                        (setq a (subst (cons 90 (+ num 1)) (assoc 90 a) a))
;                        ;修改多线段顶点个数
;                        (entmod a)
;                    )
;                )
;            )
;            (break_with ss1 ss2 nil)                ; ss2break ss2breakwith (flag nil = not to break with self)
;        )
;  )
;    
;  (setvar "CMDECHO" cmd)
;  (command ".undo" "end")
;  (princ)
;)
;
;;截取部分列表子函数
;(defun PartList1 (from to lst / I L)
;  (setq i -1)
;  (foreach x lst
;    (setq i (1+ i))
;    (cond ((and (>= i from) (<= i to)) (setq l (cons x l))))
;  )
;  (REVERSE l)
;)