[LISP程序]：交叉线的断开

ygy20xx

画流程图的时候，经常需要断开交叉的线段，以下是我找到的lisp，供大家参考：
[php]
; =============================================================================
; Filename    :   BreakGapsAtEdge.lsp
; Datum       :   28.10.04
; Author      :   jme
; Copyright   :   MENZI ENGINEERING GmbH, Switzerland
; Revision  1 :   28.10.04 jme - Check added on Offset method (offset can fail)
; Revision  2 :   __.__.__ ___ -
; -----------------------------------------------------------------------------
; Known bugs:
; - None
; -----------------------------------------------------------------------------
; Description:
; Multiple break at edge function.
; -----------------------------------------------------------------------------
; Global variables:
; Me:Gps
; -----------------------------------------------------------------------------
; Internal LISP-functions:
; MeGetClosestPoints MeGetInters
; -----------------------------------------------------------------------------
; External LISP-functions:
;
; -----------------------------------------------------------------------------
; Version notes:
; AutoCAD:        Version:        Language:        AddIns:
; 15+                1.01                English                ...
; -----------------------------------------------------------------------------
;
; == Message on loading =======================================================
;
(princ "\nBreakGapsAtEdge v1.01")
;
; == Main =====================================================================
;
(defun C:BreakGapsAtEdge ( / AcaDoc BrkEnt BrkObj BrkSet EdgObj EdgSet FltLst
                             FstObj NxtObj OldCmd OldOsm PntLst RefObj TmpObj)
(if (< (atof (getvar "ACADVER")) 15.0)
  (alert "BreakGapsAtEdge requires AutoCAD 2000 or higher. ")
  (progn
   (vl-load-com)
   (initget 6)
   (setq AcaDoc (vla-get-ActiveDocument (vlax-get-acad-object))
         Me:Gps (cond (Me:Gps) (1.0))
         Me:Gps (cond
                 ((getdist (strcat "\nGap size <" (rtos Me:Gps) ">: ")))
                 (Me:Gps)
                )
         FltLst '(
                  (0 . "ARC,ELLIPSE,LINE,LWPOLYLINE,POLYLINE,SPLINE")
                  (-4 . "<NOT")
                   (-4 . "<OR")
                    (-4 . "&=") (70 . 16)  ;3DMesh
                    (-4 . "&=") (70 . 64)  ;PolyFace
                   (-4 . "OR>")
                  (-4 . "NOT>")
                 )
   )
   (cond
    ((or
      (not (princ "\nSelect cutting edge..."))
      (not (setq EdgSet (ssget "_:S:E:L" FltLst)))
      (redraw (ssname EdgSet 0) 3)
     )
    )
    ((or
      (not (princ "\nSelect objects to break..."))
      (not (setq BrkSet (ssget "_:L" FltLst)))
     )
    )
    (T
     (vla-StartUndoMark AcaDoc)
     (setq OldOsm (getvar "OSMODE")
           OldCmd (getvar "CMDECHO")
           EdgObj (vlax-ename->vla-object (ssname EdgSet 0))
     )
     (if (and
          (not
           (vl-catch-all-error-p
            (setq FstObj (vl-catch-all-apply
                          'vlax-invoke (list EdgObj 'Offset (/ Me:Gps 2.0))
                         )
            )
           )
          )
          (not
           (vl-catch-all-error-p
            (setq NxtObj (vl-catch-all-apply
                          'vlax-invoke (list EdgObj 'Offset (- (/ Me:Gps 2.0)))
                         )
            )
           )
          )
         )
      (progn
       (setq FstObj (car FstObj)
             NxtObj (car NxtObj)
             RefObj NxtObj
       )
       (vla-put-Visible FstObj :vlax-false)
       (vla-put-Visible NxtObj :vlax-false)
       (setvar "CMDECHO" 0)
       (setvar "OSMODE" 0)
       (while (setq BrkEnt (ssname BrkSet 0))
        (setq BrkObj (vlax-ename->vla-object BrkEnt))
        (if (and
             (not (equal EdgObj BrkObj))
             (setq PntLst (append
                           (MeGetInters FstObj BrkObj acExtendNone)
                           (MeGetInters NxtObj BrkObj acExtendNone)
                          )
             )
             (> (length PntLst) 1)
             (apply 'and (setq PntLst (MeGetClosestPoints PntLst)))
             (not (command "_.BREAK" BrkEnt (car PntLst) (cadr PntLst)))
            )
         (if (and
              (setq TmpObj (vlax-ename->vla-object (entlast)))
              (not (equal RefObj TmpObj))
              (MeGetInters EdgObj TmpObj acExtendNone)
             )
          (setq RefObj TmpObj
                BrkSet (ssadd (vlax-vla-object->ename TmpObj) BrkSet)
          )
         )
         (ssdel BrkEnt BrkSet)
        )
        (if (not (MeGetInters EdgObj BrkObj acExtendNone))
         (ssdel BrkEnt BrkSet)
        )
       )
      )
      (alert "Error on offsetting cutting edge. ")
     )
     (if (= (type FstObj) 'VLA-OBJECT) (vla-Delete FstObj))
     (if (= (type NxtObj) 'VLA-OBJECT) (vla-Delete NxtObj))
     (if EdgSet (redraw (ssname EdgSet 0) 4))
     (setvar "CMDECHO" OldCmd)
     (setvar "OSMODE" OldOsm)
     (vla-EndUndoMark AcaDoc)
    )
   )
  )
)
(princ)
)
;
; == Subs =====================================================================
;
; == Function MeGetClosestPoints
; Returns the most closed points from a point list.
; Arguments [Typ]:
;   Lst = Point list [LIST]
; Return [Typ]:
;   > List of both most closed points [LIST]
; Notes:
;   None
;
(defun MeGetClosestPoints (Lst / FstPnt LasDst NxtPnt)
(setq LasDst 10E24)
(foreach Fst Lst
  (foreach Nxt Lst
   (if (and
        (< (distance Fst Nxt) LasDst)
        (not (equal Fst Nxt 1E-8))
       )
    (setq FstPnt Fst
          NxtPnt Nxt
          LasDst (distance Fst Nxt)
    )
   )
  )
)
(list FstPnt NxtPnt)
)
;
; -- Function MeGetInters
; Returns all intersection points between two objects.
; Arguments [Typ]:
;   Fst = First object [VLA-OBJECT]
;   Nxt = Second object [VLA-OBJECT]
;   Mde = Intersection mode [INT]
;         Constants:
;         - acExtendNone           Does not extend either object.
;         - acExtendThisEntity     Extends the Fst object.
;         - acExtendOtherEntity    Extends the Nxt object.
;         - acExtendBoth           Extends both objects.
; Return [Typ]:
;   > List of points '((1.0 1.0 0.0)... [LIST]
;   > False if no intersection found
; Notes:
;   - None
;
(defun MeGetInters (Fst Nxt Mde / IntLst PntLst)
(setq IntLst (vlax-invoke Fst 'IntersectWith Nxt Mde))
(if IntLst
  (progn
   (repeat (/ (length IntLst) 3)
    (setq PntLst (cons
                  (list (car IntLst) (cadr IntLst) (caddr IntLst))
                  PntLst
                 )
          IntLst (cdddr IntLst)
    )
   )
   (reverse PntLst)
  )
)
)
;
; == Copyright - Note (May be never deleted) ==================================
;
(princ "\n-------------------------------------------")
(princ "\n &#169;2004 MENZI ENGINEERING GmbH, Switzerland ")
(princ "\n-------------------------------------------")
(princ "\nType BreakGapsAtEdge in the command line to start the programm...")
(princ)
;
; == End BreakGapsAtEdge ======================================================
[/php]

heifeng

这个我现在也经常碰到,就是想到论坛来看看有没有这方面的资料,谢谢,等我现金够了,我来下载.

WHGF

几乎所有的线都可断开，程序设计的不错。类似于GIS系统中的自动剪断线功能。

露水2

在r14上不能用的能有14的吗

ybbhiuiu

能在什么版本上用啊！！！

PFD8667

我在CAD2006使用不行啊!

limingqian

ABD中有一个经典的LSP程序，可以解决这个问题。

wl1221

2006不好用啊

oyxx_1023

可不可以改进一下,变成:选第一条线,然后断开所有与这条线相交的线.
那就更HAPPY了.

xotoo

最初由 oyxx_1023 发布
[B]可不可以改进一下,变成:选第一条线,然后断开所有与这条线相交的线.
那就更HAPPY了. [/B]

我也想要这样一个程序……