（求助）选择闭合样条曲线或者闭合多段线，删除内或者外的所有图形

Terence688

（求助）选择闭合样条曲线或者闭合多段线，删除内或者外的所有图形！

Terence688

（求助）选择闭合样条曲线或者闭合多段线，删除内或者外的所有图形

忙出一个未来

(defun CC2 ( / *error* *acad* doc ps osm as om emode pmode offd
                          elev locked typ typlst e d notclosed splinetyp
                          i o intpts lst sc minpt maxpt hidelst dellst
                          offsetename offsetobj trimename trimobj curcoord
                          mark postlst coord reg selfinter ext UCSpkpt
                          UCStrimobjpts WCStrimobjpts delother side
                          ssinside ssall sscross ssoutside ssintersect  
                          solidflag solidans solidlst sskeep sstest testename
                          WCSoffsetobjpts UCSoffsetobjpts
                          CC:GetScreenCoords CC:TraceObject CC:GetInters
                          CC:SpinBar CC:AfterEnt CC:CommandExplode
                          CC:ExpNestedBlock CC:FirstLastPts CC:GetBlock
                          CC:AttributesToText CC:UniformScale
                          CC:SSVLAList CC:Inside CC:UnlockLayers
                          CC:RelockLayers CC:ZoomToPointList Extents)

  (defun *error* (msg)
    (cond
      ((not msg))
      ((wcmatch (strcase msg) "*QUIT*,*CANCEL*"))
      (T (princ (strcat "\nError: " msg)))
    )
    (setvar "pickstyle" ps)
    (setvar "osmode" osm)
    (setvar "autosnap" as)
    (setvar "edgemode" emode)
    (setvar "projmode" pmode)
    (setvar "orthomode" om)
    (setvar "elevation" elev)
    (setvar "offsetdist" offd)
    (setvar "cmdecho" 1)
    (if (and offsetobj (not (vlax-erased-p offsetobj)))
      (vla-delete offsetobj)
    )
    (if testename (entdel testename))
    (foreach x hidelst
      (if (not (vlax-erased-p x))
        (vlax-put x 'Visible acTrue)
      )
    )
    (if (and trimobj (not (vlax-erased-p trimobj)))
      (vla-highlight trimobj acFalse)
    )
    (CC:RelockLayers locked)
    (vla-EndUndoMark doc)
    (princ)
  ) ;end error

  (defun Extents (plist)
     (list
        (apply 'mapcar (cons 'min plist))
        (apply 'mapcar (cons 'max plist))
     )
  ) ;end

  (defun CC:ZoomToPointList (pts)
    (setq pts (Extents pts))
    (vlax-invoke *acad* 'ZoomWindow (car pts) (cadr pts))
    (vlax-invoke *acad* 'ZoomScaled 0.85 acZoomScaledRelative)
  ) ;end

  (defun CC:UnlockLayers (doc / laylst)
    (vlax-for x (vla-get-Layers doc)

      (if
        (and
          (not (vl-string-search "|" (vlax-get x 'Name)))
          (eq :vlax-true (vla-get-lock x))
        )
        (progn
          (setq laylst (cons x laylst))
          (vla-put-lock x :vlax-false)
        )
      )
    )
    laylst
  ) ;end

  (defun CC:RelockLayers (lst)
    (foreach x lst
      (vl-catch-all-apply 'vla-put-lock (list x :vlax-true))
    )
  ) ;end

  (defun CC:GetScreenCoords ( / ViwCen ViwDim ViwSiz VptMin VptMax)
   (setq ViwSiz (/ (getvar "VIEWSIZE") 2.0)
         ViwCen (getvar "VIEWCTR")
         ViwDim (list
                 (* ViwSiz (apply '/ (getvar "SCREENSIZE")))
                 ViwSiz
                )
         VptMin (mapcar '- ViwCen ViwDim)
         VptMax (mapcar '+ ViwCen ViwDim)
   )
   (list VptMin VptMax)
  ) ;end

  (defun CC:Inside (p ptlist / p2 i n #)
   
     (setq p2 (polar p 0.0 (distance (mapcar '+ (getvar "extmin") '(0 0))
                                     (mapcar '+ (getvar "extmax") '(0 0))
                                     )))

     (if (not (equal (car ptlist) (last ptlist) 1e-10))
       (setq ptlist (append ptlist (list (car ptlist))))
     )
     (setq i 0 # 0 n (1- (length ptlist)))
     (while (< i n)
        (if (inters p p2 (nth i ptlist)(nth (1+ i) ptlist))
           (setq # (1+ #))
        )
        (setq i (1+ i))
     )
     (not (zerop (rem # 2)))
  ) ; end CC:Inside


  (defun CC:SSVLAList (ss / obj lst i)
    (setq i 0)
    (if ss
      (repeat (sslength ss)
        (setq obj (vlax-ename->vla-object (ssname ss i))
              lst (cons obj lst)
              i (1+ i)
        )
      )
    )
    (reverse lst)
  ) ;end

  (defun CC:AfterEnt (ent / lst entlst)
    (while (setq ent (entnext ent))
      (setq entlst (entget ent))
      (if
        (and
          (not (wcmatch (cdr (assoc 0 entlst)) "ATTRIB,VERTEX,SEQEND"))
          (eq (cdr (assoc 410 entlst)) (getvar "ctab"))
        )
        (setq lst (cons ent lst))
      )
    )
    (reverse lst)
  ) ;end

  (defun CC:SpinBar (sbar)
    (cond ((= sbar "\\") "|")
          ((= sbar "|") "/")
          ((= sbar "/") "-")
          (t "\\")
    )
  ) ;end

  (defun CC:TraceObject (obj / typlst typ ZZeroList TracePline
                               TraceCE TraceSpline)

    (defun ZZeroList (lst)
      (mapcar '(lambda (p) (list (car p) (cadr p) 0.0)) lst)
    )


    (defun TracePline (obj / param endparam anginc tparam pt blg
                             ptlst delta inc arcparam flag)

      (setq param (vlax-curve-getStartParam obj)
            endparam (vlax-curve-getEndParam obj)
            ;anginc (* pi (/ 7.5 180.0))
            anginc (* pi (/ 2.5 180.0))
      )

      (while (<= param endparam)
        (setq pt (vlax-curve-getPointAtParam obj param))
        
        (if (not (equal pt (car ptlst) 1e-12))
          (setq ptlst (cons pt ptlst))
        )

        (if
          (and
            (/= param endparam)
            (setq blg (abs (vlax-invoke obj 'GetBulge param)))
            (/= 0 blg)
          )
          (progn
            (setq delta (* 4 (atan blg))
                  inc (/ 1.0 (1+ (fix (/ delta anginc))))
                  arcparam (+ param inc)
            )
            (while (< arcparam (1+ param))
              (setq pt (vlax-curve-getPointAtParam obj arcparam)
                    ptlst (cons pt ptlst)
                    arcparam (+ inc arcparam)
              )
            )
          )
        )
        (setq param (1+ param))
      ) ;while

      (if (> (length ptlst) 1)
        (progn
          (setq ptlst (vl-remove nil ptlst))
          (ZZeroList (reverse ptlst))
        )
      )
    ) ;end

   
    (defun TraceCE (obj / startparam endparam anginc
                           delta div inc pt ptlst)

      (setq startparam (vlax-curve-getStartParam obj)
            endparam (vlax-curve-getEndParam obj)

            anginc (* pi (/ 2.5 180.0))   
      )

      (if (equal endparam (* pi 2) 1e-6)
        (setq delta endparam)
  
        (setq delta (abs (- endparam startparam)))
      )


      (setq div (1+ (fix (/ delta anginc)))
            inc (/ delta div)
      )

      (while
        (or
          (< startparam endparam)
          (equal startparam endparam 1e-12)

        )
        (setq pt (vlax-curve-getPointAtParam obj startparam)
              ptlst (cons pt ptlst)
              startparam (+ inc startparam)
        )
      )
      (ZZeroList (reverse ptlst))
    ) ;end

    (defun TraceSpline (obj / startparam endparam ncpts inc param
                              fd ptlst pt1 pt2 ang1 ang2 a)
      (setq startparam (vlax-curve-getStartParam obj)
            endparam (vlax-curve-getEndParam obj)
            ncpts (vlax-get obj 'NumberOfControlPoints)
            inc (/ (- endparam startparam) (* ncpts 6))
            param (+ inc startparam)
            fd (vlax-curve-getfirstderiv obj param)
            ptlst (cons (vlax-curve-getStartPoint obj) ptlst)
      )

      (while (< param endparam)
        (setq pt1 (vlax-curve-getPointAtParam obj param)
              ang1 (angle pt1 (mapcar '+ pt1 fd))
              param (+ param inc)
              pt2 (vlax-curve-getPointAtParam obj param)
              fd (vlax-curve-getfirstderiv obj param)
              ang2 (angle pt2 (mapcar '+ pt2 fd))
              a (abs (@delta ang1 ang2))
        )
        (if (> a 0.00436332)
          (setq ptlst (cons pt1 ptlst))
        )
      )

      (if
        (not
          (equal
            (setq pt1 (vlax-curve-getEndPoint obj)) (car ptlst) 1e-8))
        (setq ptlst (cons pt1 ptlst))
      )
      (ZZeroList (reverse ptlst))
    ) ;end


    (setq typlst '("AcDb2dPolyline" "AcDbPolyline" "AcDbSpline"
                   "AcDbCircle" "AcDbEllipse")
    )
    (or
      (eq (type obj) 'VLA-OBJECT)
      (setq obj (vlax-ename->vla-object obj))
    )

    (setq typ (vlax-get obj 'ObjectName))

    (if (vl-position typ typlst)
      (cond
         ((or (eq typ "AcDb2dPolyline") (eq typ "AcDbPolyline"))
           (cond
             ((or
                (not (vlax-property-available-p obj 'Type))
                (= 0 (vlax-get obj 'Type))
               )
               (TracePline obj)
             )
           )
         )
         ((or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
           (TraceCE obj)
         )
         ((eq typ "AcDbSpline")
           (TraceSpline obj)
         )
      )
    )
  ) ;end CC:TraceObject

  (defun CC:GetInters (firstobj nextobj mode / coord ptlst)
    (if (= (type firstobj) 'ENAME)
      (setq firstobj (vlax-ename->vla-object firstobj)))
    (if (= (type nextobj) 'ENAME)
      (setq nextobj (vlax-ename->vla-object nextobj)))
    (if
      (not
        (vl-catch-all-error-p
          (setq coord (vl-catch-all-apply 'vlax-invoke
            (list firstobj 'IntersectWith nextobj mode)))
        )
      )
      (repeat (/ (length coord) 3)
        (setq ptlst (cons (list (car coord) (cadr coord) (caddr coord)) ptlst))
        (setq coord (cdddr coord))
      )
    )
    (reverse ptlst)
  ) ;end

  (defun CC:CommandExplode (obj / lay mark attlst name exlst newattlst)
    (setq mark (entlast))
    (if
      (and
        (not (vlax-erased-p obj))
        (eq "AcDbBlockReference" (vlax-get obj 'ObjectName))
      )
      (progn
        (setq lay (vlax-get obj 'Layer)
              attlst (vlax-invoke obj 'GetAttributes)
        )
        (vl-cmdf "._explode" (vlax-vla-object->ename obj))

        (command)
        (if
          (and
            (not (eq mark (entlast)))
            (setq exlst (CC:SSVLAList (ssget "_p")))
          )
          (progn
            (setq newattlst (CC:AttributesToText attlst))
            (foreach x exlst
              (if (eq "AcDbAttributeDefinition" (vlax-get x 'ObjectName))
                (vla-delete x)
              )
            )
            (setq exlst (vl-remove-if 'vlax-erased-p exlst))
            (if newattlst (setq exlst (append exlst newattlst)))

            (foreach x exlst
              (if (eq "0" (vlax-get x 'Layer))
                (vlax-put x 'Layer lay)
              )
              (if (zerop (vlax-get x 'Color))
                (vlax-put x 'Color 256)
              )
            )
          )
        )
      )
    ) ;if


    (foreach x exlst
      (if
        (and
          (not (vlax-erased-p x))
          (eq "AcDbBlockReference" (vlax-get x 'ObjectName))
        )
        (CC:ExpNestedBlock x)
      )
    )
  ) ;end CC:CommandExplode

  (defun CC:ExpNestedBlock (obj / lay lst attlst)

    (princ
      (strcat "\rProcessing blocks... "
        (setq *sbar (CC:SpinBar *sbar)) "\t")
    )
    (if
      (and
        obj
        (not (vlax-erased-p obj))
      )
      (cond
        ((not (CC:UniformScale obj))
          (CC:CommandExplode obj)
        )   
        (T
          (setq lay (vlax-get obj 'Layer))
          (if (eq "AcDbBlockReference" (vlax-get obj 'ObjectName))
            (setq attlst (CC:AttributesToText (vlax-invoke obj 'GetAttributes)))
          )

          (setq lst (vl-catch-all-apply 'vlax-invoke (list obj 'Explode)))
          (if attlst (setq lst (append lst attlst)))
          (if (listp lst)
            (foreach x lst

              (vla-update x) ;testing
              (if (eq "AcDbBlockReference" (vlax-get x 'ObjectName))
                (CC:ExpNestedBlock x)
                (progn
                  (if
                    (and
                      (not (vlax-erased-p x))
                      (eq "0" (vlax-get x 'Layer))
                    )
                    (vlax-put x 'Layer lay)
                  )

                  (if
                    (and
                      (not (vlax-erased-p x))
                      (zerop (vlax-get x 'Color))
                    )
                    (vlax-put x 'Color 256)
                  )
                  (if
                    (and
                      (not (vlax-erased-p x))
                      (eq "AcDbAttributeDefinition" (vlax-get x 'ObjectName))
                    )
                    (vla-delete x)
                  )
                )
              )
            )
          )
          (vla-delete obj)
        )
      ) ;cond
    ) ;if
  ) ;end


  (defun CC:FirstLastPts (obj / p1 p2)
    (setq p1 (vlax-curve-getPointAtParam obj (vlax-curve-getStartParam obj)))
    (setq p2 (vlax-curve-getPointAtParam obj (vlax-curve-getEndParam obj)))
    (equal p1 p2 1e-10)
  )

  (defun CC:GetBlock ()
    (vlax-get (vla-get-ActiveLayout doc) 'Block)
  ) ;end

  (defun CC:AttributesToText (attlst / elst res)
    (foreach x attlst
      (setq elst (entget (vlax-vla-object->ename x)))
      (if
        (entmake
          (list
            '(0 . "TEXT")
            (cons 1 (vlax-get x 'TextString))
            (cons 7 (vlax-get x 'StyleName))
            (cons 8 (vlax-get x 'Layer))
            (cons 10 (vlax-get x 'InsertionPoint))
            (cons 11 (vlax-get x 'TextAlignmentPoint))
            (cons 40 (vlax-get x 'Height))
            (cons 41 (vlax-get x 'ScaleFactor))
            (cons 50 (vlax-get x 'Rotation))
            (cons 51 (vlax-get x 'ObliqueAngle))
            (cons 62 (vlax-get x 'Color))
            (cons 67 (cdr (assoc 67 elst)))
            (cons 71 (cdr (assoc 71 elst)))
            (cons 72 (cdr (assoc 72 elst)))
            (cons 73 (cdr (assoc 73 elst)))
            (cons 410 (cdr (assoc 410 elst)))
          )
        ) ;make
        (setq res (cons (vlax-ename->vla-object (entlast)) res))
      )
    )
    res
  ) ;end

  (defun CC:UniformScale (obj / x y z)
    (and
      (or
        (= (type obj) 'VLA-object)
        (if (= (type obj) 'ENAME)
          (setq obj (vlax-ename->vla-object obj))
        )
      )
      (or
        (wcmatch (vlax-get obj 'ObjectName) "*Dimension")
        (and
          (= "AcDbBlockReference" (vlax-get obj 'ObjectName))
          (setq x (vlax-get obj 'XScaleFactor))
          (setq y (vlax-get obj 'YScaleFactor))
          (setq z (vlax-get obj 'ZScaleFactor))
          (and

            (equal (abs x) (abs y) 1e-8)
            (equal (abs y) (abs z) 1e-8)
          )
        )
      )
    )
  ) ;end

  (defun SortInterPoints (obj pts / lst)
    (if
      (vl-catch-all-error-p
        (vl-catch-all-apply 'vlax-curve-getEndParam (list obj))
      )
      pts
      (progn
        (setq lst (mapcar '(lambda (y) (vlax-curve-getParamAtPoint obj y)) pts)
              lst (mapcar '(lambda (y z) (list y z)) lst pts)
              lst (vl-sort lst '(lambda (a b) (< (car a) (car b))))
        )
        (mapcar 'cadr lst)
      )
    )
  ) ;end


  (vl-load-com)
  (setq *acad* (vlax-get-acad-object)
        doc (vla-get-ActiveDocument *acad*)
  )
  (vla-StartUndoMark doc)

  (setq locked (CC:UnlockLayers doc))

  (setq ps (getvar "pickstyle"))
  (setvar "pickstyle" 0)
  (setvar "cmdecho" 0)
  (setq elev (getvar "elevation"))

  (setvar "elevation" 0.0)
  (setq osm (getvar "osmode"))
  (setvar "osmode" 0)

  (setq as (getvar "autosnap"))
  (setvar "autosnap" 0)
  (setq om (getvar "orthomode"))
  (setvar "orthomode" 0)

  (setq emode (getvar "edgemode"))
  (setvar "edgemode" 0)
  (setq pmode (getvar "projmode"))
  (setvar "projmode" 0)
  (setq offd (getvar "offsetdist"))

  (sssetfirst)
  
  (setq typlst '("AcDbCircle" "AcDbPolyline" "AcDb2dPolyline"
                 "AcDbEllipse" "AcDbSpline"))

  (setvar "errno" 0)

  (while
    (or
      (not (setq e (car (entsel
        "\nSelect circle or closed polyline, ellipse or spline for trimming edge: "))))
      (not (setq trimobj (vlax-ename->vla-object e)))
      (not (vl-position (setq typ (vlax-get trimobj 'ObjectName)) typlst))
      (and
        (not (CC:FirstLastPts trimobj))
        (setq notclosed T)
      )
      (and
        (wcmatch typ "*Polyline")
        (vlax-property-available-p trimobj 'Type)
        (not (zerop (vlax-get trimobj 'Type)))
        (setq splinetyp T)
      )
      (and
        (wcmatch typ "*Polyline,AcDbSpline")
        (vl-catch-all-error-p
          (setq reg
            (vl-catch-all-apply 'vlax-invoke
              (list (CC:GetBlock) 'AddRegion (list trimobj))
            )
          )
        )
        (setq selfinter T)
      )
    )
    (cond
      ((= 52 (getvar "errno"))
        (exit)
      )
      ((not e)
        (princ "\n Missed pick. ")
      )
      (selfinter
        (princ "\n Selected object intersects itself, try again. ")
        (setq selfinter nil)
      )
      (notclosed
        (princ "\n Selected object is not closed, try again. ")
        (setq notclosed nil)
      )
      (splinetyp
        (princ "\n Polyline spline selected, try again. ")
        (setq splinetyp nil)
      )
      (typ
        (princ (strcat "\n " (substr typ 5) " selected, try again. "))
        (setq typ nil)
      )
    )
  )

  (if
    (and
      reg
      (not (vl-catch-all-error-p reg))
    )
    (vla-delete (car reg))
  )

  (setq trimename (vlax-vla-object->ename trimobj))

  (setq curcoord (CC:GetScreenCoords))

  (vla-highlight trimobj acTrue)

  (initget 1)
  (setq UCSpkpt (getpoint "\nPick point on side to trim: "))
  (setq WCStrimobjpts (CC:TraceObject trimobj))
  (setq UCStrimobjpts
    (mapcar '(lambda (x) (trans x 0 1)) WCStrimobjpts)
  )
  (if (CC:Inside UCSpkpt UCStrimobjpts)
    (setq side "inside")
    (setq side "outside")
  )

  (setq ext (Extents WCStrimobjpts))
  (setq d (distance (car ext) (cadr ext)))
  (setq d (/ d 1500.0))
  
  (if (= 2 (getvar "lunits"))
    (setq d (/ d 12.0))
  )

  (setq mark (entlast))
  
  (vl-cmdf "._offset" d (vlax-vla-object->ename trimobj) UCSpkpt "_exit")

  (setq offsetename (entlast))

  (if (/= 1 (length (setq dellst (CC:AfterEnt mark))))
    (progn
      (princ "\nProblem detected with selected object. Try another. Exiting... ")

      (foreach x dellst (entdel x))
      (exit)
    )
  )

  (setq offsetobj (vlax-ename->vla-object offsetename))
  (vlax-put offsetobj 'Visible 0)
  (setq hidelst (cons offsetobj hidelst))

  (initget "Yes No")
  (setq delother (getkword (strcat "\nErase all objects " side "? [Yes/No] <N>: ")))
  (if (not delother) (setq delother "No"))

  (vlax-invoke *acad* 'ZoomExtents)
  (setq sc (CC:GetScreenCoords))

  (setq minpt (car sc))
  (setq maxpt (cadr sc))

  (vlax-put trimobj 'Visible 0)
  (setq hidelst (cons trimobj hidelst))

  (setq sscross (ssget "_cp" UCStrimobjpts '((0 . "INSERT"))))
  (if (not (setq ssinside (ssget "_wp" UCStrimobjpts '((0 . "INSERT")))))
    (setq ssinside (ssadd))
  )

  (setq i 0)
  (if sscross
    (repeat (sslength sscross)
      (setq e (ssname sscross i))
      (if
        (and
          (not (ssmemb e ssinside))
          (setq o (vlax-ename->vla-object e))
          (not (vlax-erased-p o))
          (vlax-property-available-p o 'Path)
        )
        (progn

                (CC:CommandExplode o)
          (if (not (vlax-erased-p o))
            (progn
              (vlax-put o 'Visible 0)
              (setq hidelst (cons o hidelst))
            )
          )
        )
        ;else
        (CC:ExpNestedBlock o)
      )
      (setq i (1+ i))
    )
  )

  (setq i 0 sscross nil ssinside nil)
  (setq sscross (ssget "_cp" UCStrimobjpts '((0 . "HATCH"))))
  (if (not (setq ssinside (ssget "_wp" UCStrimobjpts '((0 . "HATCH")))))
    (setq ssinside (ssadd))
  )

  (if sscross
    (repeat (sslength sscross)
      (setq e (ssname sscross i))
      (if
        (and
          (not (ssmemb e ssinside))
          (setq o (vlax-ename->vla-object e))
          (eq "AcDbHatch" (vlax-get o 'ObjectName))
          (eq "SOLID" (vlax-get o 'PatternName))
        )
        (setq solidflag T
              solidlst (cons e solidlst)
        )
      )
      (setq i (1+ i))
    )
  ) ;if

  (if solidflag
    (progn
      (initget "Yes No")
      (setq solidans (getkword "\nConvert solid hatch to lines? [Yes/No] <N>: "))
      (if (eq "Yes" solidans)
        (foreach x solidlst
         
          (command "._-hatchedit" x
             "_properties" "ANSI31" (* d 8) 0.0)
     
          (vlax-put (vlax-ename->vla-object x) 'AssociativeHatch 0)
          (command "._explode" x)
        )
      )
    )
  )


  (setq i 0 sscross nil ssinside nil)
  (setq sscross (ssget "_cp" UCStrimobjpts '((0 . "HATCH,REGION"))))
  (if (not (setq ssinside (ssget "_wp" UCStrimobjpts '((0 . "HATCH,REGION")))))
    (setq ssinside (ssadd))
  )

  (if sscross
    (repeat (sslength sscross)
      (setq e (ssname sscross i))
      (if
        (and
          (not (ssmemb e ssinside))
          (not (vl-position e solidlst))
        )
        (progn
        
          (setq o (vlax-ename->vla-object e))
          (if (vlax-property-available-p o 'AssociativeHatch)
            (vlax-put o 'AssociativeHatch 0)
          )
          (command "._explode" e)
        )
      )
      (setq i (1+ i))
    )
  )

  (setq sscross nil ssinside nil)

  (setq ssall (ssget "_c" minpt maxpt))
  
  (if (not (setq ssinside (ssget "_wp" UCStrimobjpts)))
    (setq ssinside (ssadd))
  )
  
  (if (not (setq sscross (ssget "_cp" UCStrimobjpts))) ;var added
    (setq sscross (ssadd))
  )

    (setq i 0)
  (setq ssoutside (ssadd))
  (repeat (sslength ssall)
    (setq e (ssname ssall i))
    (if (not (ssmemb e sscross))
      (ssadd e ssoutside)
    )
    (setq i (1+ i))
  )

  
  (setq i 0)
  (setq ssintersect (ssadd))
  (repeat (sslength sscross)
    (setq e (ssname sscross i))
    (if
      (and
        (not (ssmemb e ssinside))
        (not (vl-position e solidlst))

        (CC:GetInters e trimobj acExtendNone)
      
      )
      (ssadd e ssintersect)
      (ssadd e ssinside)
    )
    (setq i (1+ i))
  )

  (if (eq "Yes" delother)
    (cond
      ((eq side "inside")
        (ssdel trimename ssinside) ;check
        (command "._erase" ssinside "")
      )
      ((eq side "outside")
        (ssdel trimename ssoutside) ;check
        (command "._erase" ssoutside "")
      )
    )
  )


  (setq lst (CC:SSVLAList ssintersect))

  (setq lst
    (vl-remove-if
      '(lambda (x)
        (setq typ (vlax-get x 'ObjectName))
        (or
          (eq "AcDbText" typ)
          (eq "AcDbMText" typ)
          (eq "AcDbLeader" typ)
          (wcmatch typ "*Dimension")
          (eq "AcDbHatch" typ)  
          (eq "AcDbSolid" typ)
          (eq "AcDbTrace" typ)
          (eq "AcDbMLeader" typ)
        
          (eq trimobj x)
        )
      )
      lst
    )
  )

  (CC:ZoomToPointList WCStrimobjpts)


  
  (foreach x lst
   
    (if (not (vlax-erased-p x))
      (progn
        (setq typ (vlax-get x 'ObjectName))
        (cond
          ((and
            (eq "AcDbPolyline" typ)
            (= -1 (vlax-get x 'Closed))
           )
            (vlax-put x 'Closed 0)
            (setq coord (vlax-get x 'Coordinates))
            (vlax-put x 'Coordinates
              (append coord (list (car coord) (cadr coord)))
            )
            (vla-update x)
          )
          ((and
            (eq "AcDb2dPolyline" typ)
            (= -1 (vlax-get x 'Closed))
           )
            (vlax-put x 'Closed 0)
            (setq coord (vlax-get x 'Coordinates))
            (vlax-put x 'Coordinates
              (append coord (list (car coord) (cadr coord) (caddr coord)))
            )
            (vla-update x)
          )
        )
      )
    )

    (if (setq intpts (CC:GetInters offsetobj x acExtendNone))
      (progn
        
        (if (> (length intpts) 2)
          (setq intpts (SortInterPoints x intpts))
        )
        (foreach p intpts
          (setq mark (entlast))
          (if
            (and
              (not (vl-catch-all-error-p
                (vl-catch-all-apply 'vlax-curve-getParamAtPoint (list x p)))
              )
              (vlax-curve-getParamAtPoint x p)
            )
            (vl-cmdf "._trim" trimename ""
              (list (vlax-vla-object->ename x) (trans p 0 1)) "")
          )
          (if (not (eq mark (entlast)))
            (setq postlst (cons (entlast) postlst))
          )
        )
      )
    )
  )

  (while postlst
    (setq intpts nil)
    (foreach x postlst
      (if (setq intpts (CC:GetInters offsetobj x acExtendNone))
        (progn
          (if (> (length intpts) 2)
            (setq intpts (SortInterPoints x intpts))
          )
          (foreach p intpts
            (setq mark nil)
            (setq mark (entlast))
            (if
              (and
                (not (vl-catch-all-error-p
                  (vl-catch-all-apply 'vlax-curve-getParamAtPoint (list x p)))
                )
                (vlax-curve-getParamAtPoint x p)
              )
              (vl-cmdf "._trim" trimename "" (list x (trans p 0 1)) "")
            )
            (setq postlst (vl-remove x postlst))
            (if (not (eq mark (entlast)))
              (setq postlst (cons (entlast) postlst))
            )
          )
          (setq postlst (vl-remove x postlst))
        )
        (setq postlst (vl-remove x postlst))
      )
    )
  )


  (if
    (and
      (eq "Yes" delother)
      trimobj
      offsetobj
      (not (CC:GetInters offsetobj trimobj acExtendNone))
    )
    (cond
      ((and
         (eq side "inside")
         (setq WCSoffsetobjpts (CC:TraceObject offsetobj))
         (setq UCSoffsetobjpts
           (mapcar '(lambda (x) (trans x 0 1)) WCSoffsetobjpts)
         )
       )
        (if (setq sstest (ssget "_cp" UCSoffsetobjpts))
          (command "._erase" sstest "")
        )
      )
      ((eq side "outside")
        (setq mark (entlast))
     
        (vl-cmdf "._offset" (* d 3) offsetename UCSpkpt "_exit")
        (if
          (and
            (not (eq mark (setq testename (entlast))))
            (not (CC:GetInters testename trimobj acExtendNone))
            (setq WCSoffsetobjpts (CC:TraceObject testename))
            (setq UCSoffsetobjpts
              (mapcar '(lambda (x) (trans x 0 1)) WCSoffsetobjpts)
            )
          )
          (progn
            (setq sskeep (ssget "_wp" UCSoffsetobjpts))
            (vlax-invoke *acad* 'ZoomExtents)
            (setq sc (CC:GetScreenCoords)
                  minpt (car sc)
                  maxpt (cadr sc)
                  sstest (ssget "_c" minpt maxpt)
                  i 0
            )
            (if
              (and
                sskeep
                sstest
                (> (sslength sstest) (sslength sskeep))
              )
              (repeat (sslength sstest)
                (setq e (ssname sstest i))
                (if (not (ssmemb e sskeep))
                  (entdel e)
                )
                (setq i (1+ i))
              )
            )
          )
        )
      )
    ) ;cond
  ) ;if
  (if (setq sscross nil sscross   (ssget "_cp" UCStrimobjpts))

    (command "_select" sscross "")
    )

  (command "._zoom" "_window" (car curcoord) (cadr curcoord))
  (*error* nil)
) ;end

;------------------------------------
;shortcut
(defun c:CC3 () (CC2))
;------------------------------------

Terence688

忙出一个未来 发表于 2023-10-10 10:22
(defun CC2 ( / *error* *acad* doc ps osm as om emode pmode offd
                          elev l ...

大佬，您给的是修剪功能吧

Terence688

用这个测试图不行了

正能量的一诺

是这个效果吗？https://mp.weixin.qq.com/s/RVeuTQt6OPr-seBDOstY8A