有没有比这个更好用的程序啊

yangchao2005090 · 发表于 2020-7-3 15:59:24

(defun c:CC3 ( / *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 (/ 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))
;; multiply be 2 or 3?
(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
(command "._zoom" "_window" (car curcoord) (cadr curcoord))
(*error* nil)
) ;end

(defun c:CC3 ( / *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 (
      (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 (/ 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)) 
        ;; multiply be 2 or 3? 
        (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 
  (command "._zoom" "_window" (car curcoord) (cadr curcoord)) 
  (*error* nil) 
) ;end

he378980280 · 发表于 2020-7-15 11:16:21

这个是干什么的

yangchao2005090 · 发表于 2020-7-15 11:58:41

he378980280 发表于 2020-7-15 11:16
这个是干什么的

裁地形图裁地形图

wm123456 · 发表于 2020-7-17 15:29:03

cass不就可以局部存盘吗

paulpipi · 发表于 2020-8-2 14:45:29

999999 · 发表于 2020-8-18 01:33:47

谢谢楼主分享

账号		自动登录	找回密码
密码			注册