aplatir une coupe issu d'un logiciel 3D avec Z=0

[ricodemexico]

Bonjour,

 

j'ai un petit problème.

 

Je travaille sur des coupes q'un charpentier m'envoie. Je pense qu'il travaille à partir de CADWORK.

Les coupes qu'il m'envoie ont l'apparence d'une 2D mais n'en sont pas des vrais. Il y a des objets Face3D.

 

J'ai surtout un problème avec

- les points d'accroche sur les face 3D (que je n'arrive pas à décomposer).

- l'utilisation un lisp qui d'habitude passait tout en Z=0. Mais là, ça fait disparaître des objet des polylignes.

 

 

Voilà, si quelqu'un peut m'aider, ça serait super !! ;)

 

Ci-dessous le lisp que j'utilise depuis des années :

 

 

 

 

 

 

;Passe le Z à 0 de tous les objets selectionnes.

;

(defun c:lig(/ i j k os ent p10 p11 at)

(setq i -1 j 0 k 0 js (ssget) os (getvar "osmode"))

(setvar "cmdecho" 1)(setvar "attdia" 0)(setvar "osmode" 0)

;*********************************************

(repeat (sslength js)

(setq i (+ i 1) ent (entget (ssname js i)))

(princ "\r")(princ i)(princ " entites traitees; ")(princ (- (sslength js) i))(princ " restent a traiter.")

(setq p10 (cdr (assoc 10 ent)) p11 (cdr (assoc 11 ent)))

(setq p10 (list 10 (car p10)(cadr p10) 0.0) p11 (list 11 (car p11)(cadr p11) 0.0))

(setq ent (subst p10 (assoc 10 ent) ent))

(setq ent (subst p11 (assoc 11 ent) ent))

(cond

;-----------------------------------------------------

( (= (cdr (assoc 0 ent)) "LWPOLYLINE")

(setq ent (subst (cons 38 0.0) (assoc 38 ent) ent))

);fin lwploy

;-----------------------------------------------------

((and (= (cdr (assoc 0 ent)) "INSERT") (= (cdr (assoc 66 ent)) 1) )

(setq at (entget (entnext (cdr (assoc -1 ent)))))

(while (= "ATTRIB" (cdr (assoc 0 at )) )

(setq p10 (cdr (assoc 10 at)) p11 (cdr (assoc 11 at)))

(setq p10 (list 10 (car p10)(cadr p10) 0.0) p11 (list 11 (car p11)(cadr p11) 0.0))

(setq at (subst p10 (assoc 10 at) at))

(setq at (subst p11 (assoc 11 at) at))

(entmod at)

(setq at (entget (entnext (cdr (assoc -1 at)))))

);fin while

); fin attrib

;----------------------------------------------------

);fin cond

(entmod ent)

);fin repeat

;*********************************************

(setvar "cmdecho" 1)(setvar "attdia" 1)(setvar "osmode" os)(princ)

);fin prg

(princ "\nTapez LIG pour lancer la commande")(princ)

 

 

 

 

Merci

[ricodemexico]

en voulant envoyer un élément du plan du charpentier, j'ai essayé mon lisp directement dans son fichier et les polilygnes ne disparaissent pas.

 

En revanche, quand je le copie/colle dans mon fichier du projet, ça merde.

 

Quand je le copie/colle dans mon un nouveau fichier issus du gabarit, ça marche.

 

 

Qu'est-il arrivé à mon fichier projet.

je joins un wbloc de mon fichier projet sur lequel figure le problème.

Si j'applique mon lisp sur la polyligne, elle disparaît.

[ricodemexico]

zut , j'ai pas la permission de déposer le fichier :/

[-Olivier-]

Bonjour ricodemexico,

 

Le forum bloc les fichiers dwg (oui je sais, c'est un comble :D ) il suffit de zipper le fichier pour contourner le blocage.

 

Olivier

[ricodemexico]

Bonjour Olivier,

 

merci pour l'info. :)

 

voici donc le fichier.

nouveau fichier bloc.zip

[ricodemexico]

Dernier truc que je trouve super bizare :

 

Quand je fait un "copier avec point de base" / "coller" d'une coupe:

 

- du plan du charpente vers un nouveau fichier issus de mon gabarit, pas de problème, tout semble ok

 

- du plan du charpente vers mon fichier projet, il y a un changement d'échelle du dessin qui s'effectue. :blink:

 

 

Que pasa Boudiou !

[jalna]

Deux fois la même chose le prog et dessous

[jalna]

Salut

Moi j'utilise ce lisp SUPERFLATTEN si cela peut t'aider je l'ai essayé avec ton fichier et ça fonctionne...

 

(vl-load-com)

(defun c:SuperFlatten ( / *error* doc cnt ss expm locklst blocks layouts views 
                     mspace mspacecnt lst blknamelst patlst hpa templayout 
                     blkdef inoutlst actlayout notflatlst expblklst 
                     expblkcnt renameflag newname newnamelst notrenamedlst 
                     optans presufstr templst orig ucsfol renameans

                     TestZNormal TestXYNormal ZZeroPoint ZZeroCoord 
                     ProcessList SF:MakeLWPolyline GetBlock PointList 
                     RotateToNormal TwoPointObj ApplyProps FlatMText FlatText 
                     FlatPointObj FlatLine FlatACE FlatCircle FlatArc 
                     FlatPline FlatSpline FlatDimension FlatXref FlatShape 
                     FlatHatch FlatSolidOrTrace FlatRayOrXline 
                     FlatWipeoutOrRaster FlatMline FlatTable FlatTolerance 
                     FlatRegion FlatPolyFaceMesh FlatCoordinates 
                     AttributesToText ExpBlockMethod CommandExplode 
                     ModBlockScale SF:TraceObject CheckRename PrefixSuffix 
                     Spinbar LstACADPAT UnlockLayers RelockLayers 
                     SSVLAList SSAfterEnt Round GetNestedNames ClosestPoint 
                     FarthestPoint Farthest2Points AveragePts ValidItem)

                     ;; Global variables: *expans* *overkillans*

 (defun *error* (msg)
   (cond
     ((not msg))
     ((wcmatch (strcase msg) "*QUIT*,*CANCEL*")
       (if blknamelst
         (princ "\n ** CANCELED - UNDO RECOMMENED ** \n")
       )
     )
     (T (princ (strcat "\nError: " msg)))
   )
   (foreach x expblklst (vlax-put x 'Explodable acFalse))    
   (vl-catch-all-apply 'vla-delete (list templayout))
   (RelockLayers locklst)
   (setvar "hpassoc" hpa)
   (setvar "explmode" expm)
   (setvar "ucsfollow" ucsfol)
   (setvar "cmdecho" 1)
   (vla-EndUndoMark doc)
   (princ)
 ) ;end error

 ;;;;;;; START SuperFlatten SUB-FUNCTIONS ;;;;;;;

 ;; Return T if normal is (0.0 0.0 1.0) or (0.0 0.0 -1.0) with fuzz.
 ;; Argument: an ename or vla-object.
 (defun TestZNormal (obj / n)
   (if (= (type obj) 'VLA-object)
     (setq n (vlax-get obj 'Normal))
     (setq n (cdr (assoc 210 (entget obj))))
   )
   (or
     (equal n '(0.0 0.0 1.0) 1e-8)
     (equal n '(0.0 0.0 -1.0) 1e-8)
   )
 ) ;end

 ;; Argument: an ename or vla-object.
 (defun TestXYNormal (obj / n)
   (if (= (type obj) 'VLA-object)
     (setq n (vlax-get obj 'Normal))
     (setq n (cdr (assoc 210 (entget obj))))
   )
   (or
     ;; object drawn in front view
     (equal n '(0.0 -1.0 0.0) 1e-8)
     ;; back
     (equal n '(0.0 1.0 0.0) 1e-8)
     ;; left
     (equal n '(-1.0 0.0 0.0) 1e-8)
     ;; right
     (equal n '(1.0 0.0 0.0) 1e-8)
   )
 ) ;end

 ;Argument: a single 3D point list.
 (defun ZZeroPoint (lst)
   (list (car lst) (cadr lst) 0.0)
 ) ;end

 ;; Argument: a flat 3D coordinate list.
 ;; (setq l '(414.576 572.128 0.0 494.558 637.135 20.0 562.58 575.117 30.0))
 ;; Returns:
 ;; (414.576 572.128 0.0 494.558 637.135 0.0 562.58 575.117 0.0)
 (defun ZZeroCoord (coord / lst)
   (repeat (/ (length coord) 3)
     (setq lst (cons (car coord) lst)
           lst (cons (cadr coord) lst)
           lst (cons 0.0 lst)
           coord (cdddr coord)
     )
   )
   (reverse lst)
 ) ;end

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

 ;; Called in the ProcessList sub-function.
 ;; Author unknown.
 (defun Spinbar (sbar) 
   (cond ((= sbar "\\") "|")
         ((= sbar "|") "/")
         ((= sbar "/") "-")
         (t "\\")
   )
 ) ;end

 ;; Arguments: an existing value and a test value.
 ;; The order of the arguments passed doesn't matter.
 ;; It determines whether a block definition should be renamed
 ;; or not by setting the renameflag variable.
 (defun CheckRename (exval testval)
   (if (and renameans presufstr)
     (or 
       (equal exval testval 1e-6)
       (setq renameflag T)
     )
   )
 ) ;end

 ;; Check for item in a collection by Doug Broad.
 (defun ValidItem (collection item / res)
   (vl-catch-all-apply
     '(lambda ()
       (setq res (vla-item collection item))))
   res
 )

 ;; Argument: either "prefix" or "suffix" string.
 ;; Called from program options.
 ;; snvalid returns nil when passed a string with 
 ;; leading or trailing spaces.
 (defun PrefixSuffix (argstr / str StripSpaces)

   ;Remove leading and trailing spaces for snvalid check.
   (defun StripSpaces (str)
     (vl-string-right-trim " " (vl-string-left-trim " " str))
   )

   (setq str (getstring T (strcat "\nBlock name " argstr ": ")))

   (if (eq argstr "prefix")
     (setq str (vl-string-left-trim " " str))
     (setq str (vl-string-right-trim " " str))
   )

   (cond
     ((eq "" str)
       (princ "\nBlocks will not be renamed. ")
     )
     ((not (snvalid (StripSpaces str) 0))
       (while
         (and 
           (not (eq "" str))
           (not 
             (snvalid
               (setq str (StripSpaces (getstring T (strcat "\nInvalid " argstr ": ")))) 0
             )
           )
         )
       )
     )
   )
   (if (not (eq "" str))
     str
   )
 ) ;end

 ;; Entmake a lwpline. 
 ;; Returns a lwpline vla-object if successful.
 (defun SF:MakeLWPolyline (ptlst width)
   (if 
     (and
       (> (length ptlst) 1)
       (apply 'and ptlst)
     )
     (if (entmake
           (append
             (list
               '(0 . "LWPOLYLINE")
               '(100 . "AcDbEntity")
               '(100 . "AcDbPolyline")
    			(cons 90 (length ptlst))
    			(cons 43 width)
             )
             (mapcar '(lambda (x) (cons 10 x)) ptlst)
           )
         )
       (progn
         (setq renameflag T)
         (vlax-ename->vla-object (entlast))
       )
     )
   )
 ) ;end

 ;; Arguments: two vla-objects.
 ;; Apply the properties of the old object to new object 
 ;; and delete the old object.
 (defun ApplyProps (old new)
   (if 
     (and 
       old 
       new
       (not (vlax-erased-p old)) ;added 7/26/2006
       (not (vlax-erased-p new)) ;added 7/26/2006
     )
     (progn
       (mapcar '(lambda (x) (vlax-put new x (vlax-get old x)))
         '("Color" "Layer" "Linetype" "LinetypeScale" "Lineweight")
       )
       (vl-catch-all-apply
         '(lambda () 
           (vlax-put new 'LinetypeGeneration (vlax-get old 'LinetypeGeneration))
         )
       )
       (vla-delete old)
       (setq renameflag T)
     )
   )
 ) ;end

 ;; Returns a nested point list from a flat point list.
 (defun PointList (obj / coord lst)
   (setq coord (vlax-get obj 'Coordinates))
   (cond
     ((eq "AcDbPolyline" (vlax-get obj 'ObjectName))
       (repeat (/ (length coord) 2)
         (setq lst (cons (list (car coord) (cadr coord)) lst)
               coord (cddr coord)
         )
       )
     )
     (T
       (repeat (/ (length coord) 3)
         (setq lst (cons (list (car coord) (cadr coord) (caddr coord)) lst)
               coord (cdddr coord)
         )
       )
     )
   )
   (reverse lst)
 ) ;end

 ;; Used when certain object types pass the TestXYNormal test.
 ;; Converts the argument object to a line. 
 ;; ApplyProps handles delete the source object.
 (defun TwoPointObj (obj / tracepts x y pts newobj)
   (if  
     (or
       (setq tracepts (SF:TraceObject obj))
       (setq tracepts (PointList obj))
     )
     (progn
       (setq x (caar tracepts)
             y (cadar tracepts)
       )
       (if
         (or 
           ;; Bug fixed 7/24/2007
           (vl-every '(lambda (n) (equal x (car n) 1e-2)) tracepts)
           (vl-every '(lambda (n) (equal y (cadr n) 1e-2)) tracepts)
         )
         (progn
           (if (= 2 (length tracepts))
             ;; Added 7/24/2007.
             (setq pts tracepts)
             (setq pts (Farthest2Points tracepts))
           )
           (if (= 2 (length pts))
             (progn
               (setq newobj 
                 (vlax-invoke (GetBlock) 'AddLine 
                   (ZZeroPoint (car pts)) (ZZeroPoint (cadr pts))
                 )
               )
               ;; Do this first, then send object to ProcessList.
               (ApplyProps obj newobj)
               (ProcessList (list newobj))
             )
           )
         )
       )
     )
   )
 ) ;end

 ;; Convert a list of attribute reference objects to text objects.
 (defun AttributesToText (attlst / elst n)
   (foreach x attlst
     (setq n (vlax-get x 'Normal))
     (setq elst (entget (vlax-vla-object->ename x)))
     (entmake
       (list
         '(0 . "TEXT")
         (cons 1 (vlax-get x 'TextString))
         (cons 7 (vlax-get x 'StyleName))
         (cons 8 (vlax-get x 'Layer))
         (cons 10 (ZZeroPoint (vlax-get x 'InsertionPoint)))
         (cons 11 (ZZeroPoint (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 74 elst)))
         '(210 0.0 0.0 1.0)
         (cons 410 (cdr (assoc 410 elst)))
       )
     ) ;make
     (RotateToNormal (vlax-ename->vla-object (entlast)) n)
   )
 ) ;end

 ;; Modify the X, Y and Z scale factors of a block
 ;; reference if they are close to equal so the explode
 ;; method can be used.
 ;; Return T if successful, otherwise nil.
 ;; If nil, call CommandExplode.
 ;; Note, the explode method works if a block has for
 ;; instance a negative X scale factor. The block was mirrored.
 ;; I'm not sure this is a complete solution in terms of
 ;; other possible negative values.
 (defun ModBlockScale (blk / xsf ysf zsf)
   (setq xsf (vlax-get blk 'XScaleFactor)
         ysf (vlax-get blk 'YScaleFactor)
         zsf (vlax-get blk 'ZScaleFactor)
   )
   (if
     (and
       (or
         (equal xsf ysf 1e-2)
         (equal (- xsf) ysf 1e-2)
       )
       (equal ysf zsf 1e-2)
     )
     (progn
       (vlax-put blk 'XScaleFactor (Round xsf 1e-2))
       (vlax-put blk 'YScaleFactor (Round ysf 1e-2))
       (vlax-put blk 'ZScaleFactor (Round zsf 1e-2))
       T
     )
   )
 ) ;end

 ;; Explode a block reference using the Explode method.
 ;; If the reference passes the TestZNormal test it's not exploded.
 (defun ExpBlockMethod (blkref / ip blkdef flag lay attlst exlst)
   (setq blkdef (vla-item blocks (vlax-get blkref 'Name)))
   (if 
     (or 
       (not (vlax-property-available-p blkdef 'Explodable))
       (eq acTrue (vlax-get blkdef 'Explodable))
     )
     (setq flag T)
   )
   (cond
     ((TestZNormal blkref)
       (setq ip (vlax-get blkref 'InsertionPoint))
       (CheckRename ip (ZZeroPoint ip))
       (vlax-put blkref 'InsertionPoint (ZZeroPoint ip))
       (setq attlst (vlax-invoke blkref 'GetAttributes))
       (foreach x attlst (FlatText x))
     )
     ;; Block can be exploded using the explode method and the Explodable property
     ;; is acTrue if that property exists.
     ((and flag (ModBlockScale blkref))    
       (setq lay (vlax-get blkref 'Layer)
             attlst (vlax-invoke blkref 'GetAttributes)
             exlst (vlax-invoke blkref 'Explode)
       )
       (if exlst
         (progn
           (setq renameflag T)
           (setq expblkcnt (1+ expblkcnt))
           (AttributesToText attlst)
           (vla-delete blkref)
           (foreach x exlst
             (if (eq "AcDbAttributeDefinition" (vlax-get x 'ObjectName))
               (vla-delete x)
             )
           )
           (setq exlst (vl-remove-if 'vlax-erased-p exlst))
           (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)
             )
           )
           (ProcessList exlst)
         )
         (progn
           (setq cnt (1+ cnt))
           (if (not (vl-position "AcDbBlockReference" notflatlst))
             (setq notflatlst (cons "AcDbBlockReference" notflatlst))
           )
         )
       )
     )
     ;; Otherwise use command because the block is not uniformly scaled.
     ;; Which the Exlpode method can't handle.
     (T (CommandExplode blkref))
   ) ;cond
 ) ;end

 ;; The types of objects which may be exploded with this function:
 ;; A hatch with an odd normal which can't be recreated because
 ;; the hatch pattern isn't available.
 ;; Dimensions with an odd normal.
 ;; AcDb3dSolid and AcDbBody objects. Some can be exploded, others can't.
 ;; Block references when the ExpBlockMethod function above can't do it 
 ;; because the reference is not uniformly scaled.
 (defun CommandExplode (obj / lay mark objname attlst name exlst)
   (setq mark (entlast)
         objname (vlax-get obj 'ObjectName)
   )
   (cond
     ((or 
		(eq "AcDb3dSolid" objname)
		(eq "AcDbBody" objname)
		(eq "AcDbSurface" objname)
		;; Added 7/23/2007
		(eq "AcDbZombieEntity" objname)
		;; Things like AeccDbContour and AeccDbPoint.
		;; From either LandDestop or Civil 3D. I'm not sure.
		(wcmatch objname "AeccDb*")
       )
       (command "._explode" (vlax-vla-object->ename obj))
       (if (not (eq mark (entlast)))
         (setq exlst (SSVLAList (ssget "p")))
       )
     )
     ((or 
		(eq "AcDbHatch" objname)
		(wcmatch objname "*Dimension")
       )
       (command "._explode" (vlax-vla-object->ename obj))
       (if (not (eq mark (entlast)))
         (setq exlst (SSVLAList (ssget "p")))
       )
     )
     
     ;; Added 7/24/2007
     ((wcmatch objname "AecDb*,AecsDb*")
       (command "._explode" (vlax-vla-object->ename obj))
       (if (not (eq mark (entlast)))
         (setq exlst (SSVLAList (ssget "p")))
       )
       (if
         (and
           (= 1 (length exlst))
           (eq "AcDbBlockReference" (vlax-get (car exlst) 'ObjectName))
           (wcmatch (setq name (vlax-get (car exlst) 'Name)) "`**")
         )
         (setq blknamelst (cons name blknamelst))
       )
     )

     ((eq "AcDbBlockReference" objname)
		(setq lay (vlax-get obj 'Layer)
  			attlst (vlax-invoke obj 'GetAttributes)
		)
		(command "._explode" (vlax-vla-object->ename obj))
		;; Had some problems here with blocks which cannot be exploded.
		;; The following test seems to fix it.
		(if 
  		(and 
			(not (eq mark (entlast)))
			(setq exlst (SSVLAList (ssget "p")))
			;(not (eq mark (entlast)))
  		)
  		(progn
			(setq expblkcnt (1+ expblkcnt))
			(AttributesToText attlst) ;seems OK here
			(foreach x exlst
  			(if (eq "AcDbAttributeDefinition" (vlax-get x 'ObjectName))
    			(vla-delete x)
  			)
			)
			(setq exlst (vl-remove-if 'vlax-erased-p exlst))
			;If an exlpoded object is on layer 0, put it on the
			;layer of the exploded object. If its color is byBlock, 
			;change color to byLayer.
			(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)
  			)
			)
  		)
		)
  	)
   ) ;cond
   (if exlst
     (progn
       (setq renameflag T)
       (ProcessList exlst)
     )
     ;Else set count of objects not processed and the ObjectName.
     (progn
       (setq cnt (1+ cnt))
       (if (not (vl-position objname notflatlst))
         (setq notflatlst (cons objname notflatlst))
       )
     )
   )
 ) ;end

 ;; Arguments: vla-object and a normal vector.
 ;; Called from FlatMtext, FlatText, FlatXref and FlatShape.
 ;; The check for the normal Z value approaching 1 or -1 is because
 ;; it seems within that range the display of the object simply
 ;; shows its rotation. There's an example of this in Ken Luk's
 ;; test file from customer files.
 ;; Note, put rotation could be like this.
 ;; (vlax-put obj 'Rotation (+ (* pi 0.5) (atan (cadr n) (car n))))
 (defun RotateToNormal (obj n)
   (if
     (and
       (not (equal 1.0 (caddr n) 1e-5))
       (not (equal -1.0 (caddr n) 1e-5))
     )
     (vlax-put obj 'Rotation 
       (+ (vlax-get obj 'Rotation) (+ (* pi 0.5) (angle '(0 0) n)))
     )
   )
 ) ;end

 ;;; TRACE FUNCTION ;;;
 (defun SF:TraceObject (obj / typlst typ ZZeroList TracePline TraceACE 
                  			TraceType1Pline TraceType23Pline)

   ;;;; start trace sub-functions ;;;;

   ;; Argument: 2D or 3D point list.
   ;; Returns: 3D point list with zero Z values.
   (defun ZZeroList (lst)
     (mapcar '(lambda (p) (list (car p) (cadr p) 0.0)) lst)
   )

   ;; Argument: vla-object, a heavy or lightweight pline.
   ;; Returns: WCS point list if successful.
   ;; Notes: Duplicate adjacent points are removed.
   ;;        The last closing point is included given a closed pline.
   (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))
     )

     (while (<= param endparam)
       (setq pt (vlax-curve-getPointAtParam obj param))
       ;Avoid duplicate points between start and end.
       (if (not (equal pt (car ptlst) 1e-12))
         (setq ptlst (cons pt ptlst))
       )
       ;A closed pline returns an error (invalid index) 
       ;when asking for the bulge of the end param.
       (if 
         (and 
           (/= param endparam)
           (setq blg (abs (vlax-invoke obj 'GetBulge param)))
           (/= 0 blg)
         )
         (progn
           (setq delta (* 4 (atan blg)) ;included angle
                 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

   ;; Argument: vla-object, an arc, circle or ellipse.
   ;; Returns: WCS point list if successful.
   (defun TraceACE (obj / startparam endparam anginc 
              			delta div inc pt ptlst)
     ;start and end angles
     ;circles don't have StartAngle and EndAngle properties.
     (setq startparam (vlax-curve-getStartParam obj)
           endparam (vlax-curve-getEndParam obj)
           ;anginc (* pi (/ 7.5 180.0))
           anginc (* pi (/ 2.5 180.0))
     )

     (if (equal endparam (* pi 2) 1e-6)
       (setq delta endparam)
       ;added abs 6/23/2007, testing
       (setq delta (abs (- endparam startparam)))
     )

     ;Divide delta (included angle) into an equal number of parts.
     (setq div (1+ (fix (/ delta anginc)))
           inc (/ delta div)
     )

     ;Or statement allows the last point on an open ellipse
     ;rather than using (<= startparam endparam) which sometimes
     ;fails to return the last point. Not sure why.
     (while
       (or
         (< startparam endparam)
         (equal startparam endparam 1e-12)
         ;(equal startparam endparam)
       )
       (setq pt (vlax-curve-getPointAtParam obj startparam)
             ptlst (cons pt ptlst)
             startparam (+ inc startparam)
       )
     )
     (ZZeroList (reverse ptlst))
   ) ;end

   ;; Explode curve fit pline and gather point list from arcs.
   ;; This sub-function deletes objects.
   (defun TraceType1Pline (obj / ptlst objlst lst)
     (setq ptlst (list (vlax-curve-getStartPoint obj))
           objlst (vlax-invoke obj 'Explode)
     )
     (foreach x objlst 
       (setq lst (TraceACE x))
       (if (not (equal (car lst) (last ptlst) 1e-8))
         (setq lst (reverse lst))
       )
       (setq ptlst (append ptlst (cdr lst)))
       (vla-delete x)
     )
     (ZZeroList ptlst)
   ) ;end

   ;; Explode quadratic and cubic plines and gather point list from lines.
   ;; Produces an exact trace.
   ;; This sub-function deletes objects.
   (defun TraceType23Pline (obj / objlst ptlst lastpt)
     (setq objlst (vlax-invoke obj 'Explode)
           lastpt (vlax-get (last objlst) 'EndPoint)
     )
     (foreach x objlst
       (setq ptlst (cons (vlax-get x 'StartPoint) ptlst))
       (vla-delete x)
     )
     (ZZeroList (reverse (cons lastpt ptlst)))
   ) ;end
   ;;;; end trace sub-functions ;;;;

   ;;;; primary trace function ;;;;
   (setq typlst '("AcDb2dPolyline" "AcDbPolyline"  
      			"AcDbCircle" "AcDbArc" "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 (= 3 (vlax-get obj 'Type)) (= 2 (vlax-get obj 'Type)))
               (TraceType23Pline obj)
             )
             ((= 1 (vlax-get obj 'Type))
               (TraceType1Pline obj)
             )
           )
		)
		((or (eq typ "AcDbCircle") (eq typ "AcDbArc") (eq typ "AcDbEllipse"))
  		(TraceACE obj)
		)
     )
   )
 ) ;end SF:TraceObject
 ;;; TRACE FUNCTION ;;;
 
 ;; Based on code by Luis Esquivel.
 ;; Returns a list of pattern names from AutoCAD.pat.
 (defun LstACADPAT ( / file line tmp lst )
   (setq file (open (findfile "acad.pat") "r"))
   (while (setq line (read-line file))
     (setq tmp (cons line tmp))
   )
   (close file)
   (setq tmp (reverse tmp))
   (setq lst (vl-remove-if-not
     '(lambda (string)
       (if (eq (substr string 1 1) "*") string)) tmp))

   (mapcar
     '(lambda (string)
       (substr string 2 (- (vl-string-search "," string) 1))) lst)
 ) ;end

 ;; Not used.
 ;(defun StartTimer ()
 ;  (setq *start* (getvar "date"))  
 ;) ;end

 ;; Not used.
 ;(defun EndTimer (/ end)
 ;  (setq end (* 86400 (- (getvar "date") *start*)))
 ;  (princ (strcat "\nTimer: " (rtos end 2 8) " seconds\n"))
 ;) ;end

 (defun UnlockLayers (doc / laylst)
   (vlax-for x (vla-get-Layers doc)
     ;filter out xref layers
     (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 RelockLayers (lst)
   (foreach x lst
     (vl-catch-all-apply 'vla-put-lock (list x :vlax-true))
   )
 ) ;end

 (defun 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

 ;; Filter out sub-entities and entities not in current space.
 ;; Returns a selection set of primary entities after ename ent
 ;; or nil if ent equals entlast.
 (defun SSAfterEnt (ent / ss entlst)
   (and
     (setq ss (ssadd))
     (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"))
         )
         (ssadd ent ss)
		)
  	)
	)
   (if (> (sslength ss) 0) ss)
 ) ;end
 
 ;; Revised to eliminate duplicate block names 6/5/2007.
 (defun GetNestedNames (blkcol blkname / name namelst temp1 temp2)
   ;first nested level
   (vlax-for x (vla-item blkcol blkname)
     (if 
       (and
         (= "AcDbBlockReference" (vlax-get x 'ObjectName))
         (not (vl-position (setq name (vlax-get x 'Name)) namelst))
       )
       (setq namelst (cons name namelst))
     )
   )
   ;nested deeper
   (setq temp1 namelst)
   (while temp1
     (foreach x temp1
       (vlax-for x (vla-item blkcol x)
         (if 
           (and
             (= "AcDbBlockReference" (vlax-get x 'ObjectName))
             (not (vl-position (setq name (vlax-get x 'Name)) namelst))
           )
           (setq namelst (cons name namelst)
                 temp2 (cons name temp2)
           )
         )
       )
     )
     (setq temp1 temp2 temp2 nil)
   )
   (reverse namelst)
 ) ;end

 (defun ClosestPoint ( pt ptlst / range dist res )
   (setq range (* (distance pt (car ptlst)) 1.1))
   (foreach p ptlst
     (setq dist (distance p pt))
     (if (< dist range)
       (setq range dist res p)
     )
   )
   res
 ) ;end

 ;; Arguments - a point and a point list.
 ;; Returns - the point farthest from point.
 (defun FarthestPoint (pt ptlst / x dist res)
   (setq x 0)
   (foreach p ptlst
     (setq dist (distance p pt)) 
     ;revised 7/12/2007 - added equal to avoid errors elsewhere
     (if (>= dist x)
       (setq x dist res p)
     )
   )
   res
 ) ;end

 ;; Argument: a point list.
 ;; Returns: the farthest two points in point list.
 (defun Farthest2Points (ptlst / pt)
   (list
     (setq pt (FarthestPoint (AveragePts ptlst) ptlst))
     (FarthestPoint pt ptlst)
   )
 ) ;end

 ;; Average point from point list.
 (defun AveragePts (ptlist / lst)
   (if (= (length (car ptlist)) 2) ;2D point list
     (setq lst 
       (list
         (apply '+ (mapcar '(lambda (x) (car x)) ptlist))
         (apply '+ (mapcar '(lambda (x) (cadr x)) ptlist))
       )
     )
     (setq lst ;3D point list
       (list
         (apply '+ (mapcar '(lambda (x) (car x)) ptlist))
         (apply '+ (mapcar '(lambda (x) (cadr x)) ptlist))
         (apply '+ (mapcar '(lambda (x) (caddr x)) ptlist))
       )
     )
   )
   (mapcar '(lambda (x) (/ x (length ptlist) 1.0)) lst)
 ) ;end

 ;; Joe Burke 2/23/03
 (defun Round (value to)
   (if (zerop to) value
     (* (atoi (rtos (/ (float value) to) 2 0)) to)))


 ;;;;;;;; START FLATTEN SUB-FUNCTIONS ;;;;;;;;;

 (defun FlatPointObj (obj / coord)
   ; no reason for renameflag here?
   (if (not (TestZNormal obj))
     (vlax-put obj 'Normal '(0.0 0.0 1.0))
   )
   (setq coord (vlax-get obj 'Coordinates))
   (CheckRename coord (ZZeroPoint coord))
   (vlax-put obj 'Coordinates (ZZeroPoint coord))
   (CheckRename (vlax-get obj 'Thickness) 0)
   (vlax-put obj 'Thickness 0.0)
 ) ;end

 (defun FlatLine (obj / stpt enpt)
   (if (not (TestZNormal obj))
     (progn
       (vlax-put obj 'Normal '(0.0 0.0 1.0))
       (setq renameflag T)
     )
   )
   (setq stpt (vlax-get obj 'StartPoint))
   (CheckRename stpt (ZZeroPoint stpt))
   (vlax-put obj 'StartPoint (ZZeroPoint stpt))
   (setq enpt (vlax-get obj 'EndPoint))
   (CheckRename enpt (ZZeroPoint enpt))
   (vlax-put obj 'EndPoint (ZZeroPoint enpt))
   (CheckRename (vlax-get obj 'Thickness) 0)
   (vlax-put obj 'Thickness 0.0)
   ;; If flattening made the length very short, delete line. 
   (if (equal 0.0 (vlax-get obj 'Length) 1e-6)
     (vla-delete obj)
   )
 ) ;end

 (defun FlatMText (obj / ip nrml)  
   (setq ip (vlax-get obj 'InsertionPoint))
   (CheckRename ip (ZZeroPoint ip))
   (vlax-put obj 'InsertionPoint (ZZeroPoint ip))
   (if (not (TestZNormal obj))
     (progn
       (setq nrml (vlax-get obj 'Normal))
       (vlax-put obj 'Normal '(0.0 0.0 1.0))
       (RotateToNormal obj nrml)
       (setq renameflag T)
     )
   )
 ) ;end

 (defun FlatText (obj / nrml pt ip ap)
   (CheckRename (vlax-get obj 'Thickness) 0)
   (vlax-put obj 'Thickness 0.0)
   (setq nrml (vlax-get obj 'Normal))
   (if (TestZNormal obj)
     (if (= 0 (vlax-get obj 'Alignment))
       (progn
         (setq ip (vlax-get obj 'InsertionPoint))
         (CheckRename ip (ZZeroPoint ip))
         (vlax-put obj 'InsertionPoint (ZZeroPoint ip))
       )
       (progn
         (setq ap (vlax-get obj 'TextAlignmentPoint))
         (CheckRename ap (ZZeroPoint ap))
         (vlax-put obj 'TextAlignmentPoint (ZZeroPoint ap))
       )
     )
     (progn
       (if (= 0 (vlax-get obj 'Alignment))
         (setq pt (vlax-get obj 'InsertionPoint))
         (setq pt (vlax-get obj 'TextAlignmentPoint))
       )
       (setq pt (ZZeroPoint pt))
       (vlax-put obj 'Normal '(0.0 0.0 1.0))
       (if (= 0 (vlax-get obj 'Alignment))
         (vlax-put obj 'InsertionPoint pt)
         (vlax-put obj 'TextAlignmentPoint pt)
       )
       (RotateToNormal obj nrml)
       (setq renameflag T)
     )
   )
 ) ;end

 ;; Convert a circle with odd normal to an ellipse or otherwise.
 (defun FlatCircle (obj / ratio cen pt rad newobj)
   (cond
     ((TestZNormal obj)
       (setq cen (vlax-get obj 'Center))
       (CheckRename cen (ZZeroPoint cen))
       (vlax-put obj 'Center (ZZeroPoint cen))
       (CheckRename (vlax-get obj 'Thickness) 0)
       (vlax-put obj 'Thickness 0.0)
     )
     ((TestXYNormal obj)
       (TwoPointObj obj)
     )
     (T
       (setq ratio (abs (caddr (vlax-get obj 'Normal)))
             cen (ZZeroPoint (vlax-get obj 'Center))
             pt (ZZeroPoint (vlax-curve-getPointAtParam obj 0))
             rad (vlax-get obj 'Radius)
       )
       (cond
         ((equal ratio 0.0 1e-4)
           (FlatACE obj)
         ) 
         ((equal ratio 1.0 1e-4)
           (if (setq newobj (vlax-invoke (GetBlock) 'AddCircle cen rad))
             (ApplyProps obj newobj)
           )
         )
         (T
           (setq newobj (vlax-invoke (GetBlock) 
             'AddEllipse cen (mapcar '- cen pt) (abs ratio))
           )
           (ApplyProps obj newobj)
         )
       )
     )
   )
 ) ;end

 ;; Convert an arc with odd normal to an ellipse or otherwise.
 (defun FlatArc (obj / ratio cen pt stpt enpt pt rad
                       newobj stparam enparam flag)
   (cond
     ((TestZNormal obj)
       (setq cen (vlax-get obj 'Center))
       (CheckRename cen (ZZeroPoint cen))
       (vlax-put obj 'Center (ZZeroPoint cen))
       (CheckRename (vlax-get obj 'Thickness) 0)
       (vlax-put obj 'Thickness 0.0)
     )
     ((TestXYNormal obj)
       (TwoPointObj obj)
     )
     (T
       (setq ratio (caddr (vlax-get obj 'Normal))
             cen (ZZeroPoint (vlax-get obj 'Center))
             stpt (ZZeroPoint (vlax-get obj 'StartPoint))
             enpt (ZZeroPoint (vlax-get obj 'EndPoint))
             rad (vlax-get obj 'Radius)
       )
       (if (minusp ratio)
         (setq ratio (abs ratio) flag T)
       )
       (cond
         ((< ratio 1e-4)
           (FlatACE obj)
         )
         ((equal ratio 1.0 1e-4)
           (if
             (setq newobj (vlax-invoke (GetBlock)
               'AddArc cen rad stpt (angle cen stpt) (angle cen enpt))
             )
             (ApplyProps obj newobj)
           )
         )
         (T
           (vlax-put obj 'StartAngle 0.0)
           (setq pt (ZZeroPoint (vlax-curve-getStartPoint obj)))
           (setq newobj (vlax-invoke (GetBlock)
             'AddEllipse cen (mapcar '- cen pt) ratio)
           )

           ;; This idea from BreakMethod seems to do the trick.
           (setq pt (vlax-curve-getClosestPointTo newobj stpt)
                 stparam (vlax-curve-getParamAtPoint newobj pt)
                 pt (vlax-curve-getClosestPointTo newobj enpt)
                 enparam (vlax-curve-getParamAtPoint newobj pt)
           )
           ;; If the ratio (last value of normal) 
           ;; was negative which param goes where is reversed.
           (if flag
             (progn
               (vlax-put newobj 'StartParameter enparam)
               (vlax-put newobj 'EndParameter stparam)
             )
             (progn
               (vlax-put newobj 'StartParameter stparam)
               (vlax-put newobj 'EndParameter enparam)
             )
           )
           (ApplyProps obj newobj)
         )
       ) ;cond
     ) ;progn
   ) ;if
 ) ;end

 ;; Revised 7/27/2007. Removed the kludge code. An ellipse with an
 ;; odd normal which fails the first two conditions is traced.
 ;; It avoids potential "degenerate geometry" errors which are
 ;; not worth the risk invloved trying to preserve an ellipse.
 (defun FlatEllipse (obj / cen)  
   (cond
     ((TestZNormal obj)
       (setq cen (vlax-get obj 'Center))
       (CheckRename cen (ZZeroPoint cen))
       (vlax-put obj 'Center (ZZeroPoint cen))
     )
     ((TestXYNormal obj)
       (TwoPointObj obj)
     )
     (T (FlatACE obj))
   )
 ) ;end

 ;; Revised 7/26/2007. Trace an object when there's
 ;; no other safe way to flatten it.
 (defun FlatACE (obj / ptlst newobj objname)
   (setq ptlst (SF:TraceObject obj))
   (if (setq newobj (SF:MakeLWpolyline ptlst 0.0))
     (ApplyProps obj newobj)
     (progn
       (setq objname (vlax-get obj 'ObjectName)
             cnt (1+ cnt)
       )
       (if (not (vl-position objname notflatlst))
         (setq notflatlst (cons objname notflatlst))
       )
     )
   )
 ) ;end

 ;; Heavy and lightweight plines.
 ;; A heavy pline is converted to lightweight if it is 
 ;; traced using SF:TraceObject.
 (defun FlatPline (obj / width ptlst newobj)
   (cond 
     ((TestZNormal obj)
       (CheckRename (vlax-get obj 'Elevation) 0)
       (vlax-put obj 'Elevation 0.0)
       (CheckRename (vlax-get obj 'Thickness) 0)
       (vlax-put obj 'Thickness 0.0)
     )
     ((TestXYNormal obj)
       (TwoPointObj obj)
     )
     (T   
       ;; If a pline had various widths, the new width is zero.
       ;; Seems nothing can be done about that.
       (if 
         (vl-catch-all-error-p 
           (setq width 
             (vl-catch-all-apply 'vlax-get (list obj 'ConstantWidth))
           )
         )
         (setq width 0.0)
       )
       (setq ptlst (SF:TraceObject obj))
       (if (setq newobj (SF:MakeLWpolyline ptlst width))
         (ApplyProps obj newobj)
       )
     )
   )
 ) ;end

 ;; A PolyFaceMesh object with one face needs to be exploded to a 
 ;; 3D Face before FlatCoordinates below can process it.
 (defun FlatPolyFaceMesh (obj / mark)
   (if (/= 1 (vlax-get obj 'NumberOfFaces))
     (FlatCoordinates obj)
     (progn
       (setq mark (entlast))
       (command "._explode" (vlax-vla-object->ename obj))
       (if (not (eq mark (entlast)))
         (FlatCoordinates (vlax-ename->vla-object (entlast)))
       )
     )
   )
 ) ;end

 ;; Handles 3DPoly, 3DFace, PolyFaceMesh, PolygonMesh and Leader objects.
 ;; A PolyFaceMesh object may need pre-processing. See the above function.
 ;; Note, it seems changing the coordinates of a leader when not
 ;; in WCS can change its normal. One reason the program flattens in WCS.
 (defun FlatCoordinates (obj / coord objname)
   (setq coord (vlax-get obj 'Coordinates))
   (if 
     (vl-catch-all-error-p
       (vl-catch-all-apply
         '(lambda () (vlax-put obj 'Coordinates (ZZeroCoord coord)))
       )
     )
     (progn
       (setq cnt (1+ cnt)
             objname (vlax-get obj 'ObjectName)
       )
       (if (not (vl-position objname notflatlst))
         (setq notflatlst (cons objname notflatlst))
       )
     )
   )
   (CheckRename (vlax-get obj 'Coordinates) coord)
 ) ;end

 ;; The normal of a spline is not exposed under Active X.
 ;; There is no normal if the spline is not planar.
 ;; See the IsPlanar property. So if it is planar and the
 ;; third value in the coordinate list is zero, then the
 ;; spline does not need to be modified.
 ;; If it is modified the spline should not change shape.
 ;; What will happen is any fit points may be lost.
 ;; Seems OK since fit points are sometimes removed during
 ;; spline edit operations anyway. Or it may not have 
 ;; fit points in the first place.
 (defun FlatSpline (obj / ctrlpts kts)
   (setq ctrlpts (vlax-get obj 'ControlPoints))
   (if
     (not
       (and
         (= -1 (vlax-get obj 'IsPlanar))
         (zerop (caddr ctrlpts))
       )
     )
     (progn
       (setq kts (vlax-get obj 'Knots))
       (vlax-put obj 'ControlPoints (ZZeroCoord ctrlpts))
       (vlax-put obj 'Knots kts)
       (setq renameflag T)
     )
   )
 ) ;end

 ;; The explode method doesn't work with dimension objects.
 ;; Spent some time with this one. Explode dims with odd normals
 ;; seems the best approach for now.
 (defun FlatDimension (obj / z pt)
   (if (TestZNormal obj)
     (progn
       (setq z (caddr (vlax-get obj 'TextPosition)))
       (CheckRename z 0)
       (if (not (zerop z))
         (vlax-invoke obj 'Move (list 0.0 0.0 z) '(0.0 0.0 0.0))
       )
       ;; Added the following if statements 8/8/2007
       (if (vlax-property-available-p obj 'ExtLine1Point)
         (progn
           (setq pt (vlax-get obj 'ExtLine1Point))
           (CheckRename pt (ZZeroPoint pt))
           (vlax-put obj 'ExtLine1Point (ZZeroPoint pt))
         )
       )
       (if (vlax-property-available-p obj 'ExtLine2Point)
         (progn
           (setq pt (vlax-get obj 'ExtLine2Point))
           (CheckRename pt (ZZeroPoint pt))
           (vlax-put obj 'ExtLine2Point (ZZeroPoint pt))
         )
       )
       (if (vlax-property-available-p obj 'ExtLine1StartPoint)
         (progn
           (setq pt (vlax-get obj 'ExtLine1StartPoint))
           (CheckRename pt (ZZeroPoint pt))
           (vlax-put obj 'ExtLine1StartPoint (ZZeroPoint pt))
         )
       )
       (if (vlax-property-available-p obj 'ExtLine2StartPoint)
         (progn
           (setq pt (vlax-get obj 'ExtLine2StartPoint))
           (CheckRename pt (ZZeroPoint pt))
           (vlax-put obj 'ExtLine2StartPoint (ZZeroPoint pt))
         )
       )
       (if (vlax-property-available-p obj 'ExtLine1EndPoint)
         (progn
           (setq pt (vlax-get obj 'ExtLine1EndPoint))
           (CheckRename pt (ZZeroPoint pt))
           (vlax-put obj 'ExtLine1EndPoint (ZZeroPoint pt))
         )
       )
       (if (vlax-property-available-p obj 'ExtLine2EndPoint)
         (progn
           (setq pt (vlax-get obj 'ExtLine2EndPoint))
           (CheckRename pt (ZZeroPoint pt))
           (vlax-put obj 'ExtLine2EndPoint (ZZeroPoint pt))
         )
       )
     )
     (CommandExplode obj)
   )
 ) ;end

 ;; Change the normal first and then the IP.
 (defun FlatXref (obj / ip nrml)
   (setq ip (vlax-get obj 'InsertionPoint)
         nrml (vlax-get obj 'Normal)
   )
   (if (not (TestZNormal obj))
     (progn 
       (vlax-put obj 'Normal '(0.0 0.0 1.0))
       (RotateToNormal obj nrml)
     )
   )
   (vlax-put obj 'InsertionPoint (ZZeroPoint ip))
 ) ;end

 (defun FlatTolerance (obj / ip nrml)
   (setq ip (vlax-get obj 'InsertionPoint)
         nrml (vlax-get obj 'Normal)
   ) 
   (if (not (TestZNormal obj))
     (progn
       (vlax-put obj 'Normal '(0.0 0.0 1.0))
       (setq renameflag T)
     )
   )
   (CheckRename ip (ZZeroPoint ip))
   (vlax-put obj 'InsertionPoint (ZZeroPoint ip))
 ) ;end

 ;; Formerly named FlatBlockReference.
 (defun FlatMInsert (obj / nrml blkip ip attlst flag ip ap)
   (setq nrml (vlax-get obj 'Normal)
         blkip (vlax-get obj 'InsertionPoint)
   )
   (if (not (TestZNormal obj))
     (progn
       (vlax-put obj 'Normal '(0.0 0.0 1.0))
       (setq flag T
             renameflag T
       )
     )
   )
   (setq attlst (vlax-invoke obj 'GetAttributes))   
   (foreach x attlst
     (CheckRename (vlax-get x 'Thickness) 0)
     (vlax-put x 'Thickness 0.0)
     (if (not (TestZNormal x))
       (progn
         (vlax-put x 'Normal '(0.0 0.0 1.0))
         (setq renameflag T)
       )
     )
     (if (= 0 (vlax-get x 'Alignment))
       (progn
         (setq ip (vlax-get x 'InsertionPoint))
         (CheckRename ip (ZZeroPoint ip))
         (vlax-put x 'InsertionPoint (ZZeroPoint ip))
       )
       (progn
         (setq ap (vlax-get x 'TextAlignmentPoint))
         (CheckRename ap (ZZeroPoint ap))
         (vlax-put x 'TextAlignmentPoint (ZZeroPoint ap))
       )
     )
   )
   (CheckRename blkip (ZZeroPoint blkip))
   (vlax-put obj 'InsertionPoint (ZZeroPoint blkip))
   ;; Doing this twice seems screwy but it works.
   (foreach x attlst
     (if (= 0 (vlax-get x 'Alignment))
       (vlax-put x 'InsertionPoint (ZZeroPoint (vlax-get x 'InsertionPoint)))
       (vlax-put x 'TextAlignmentPoint (ZZeroPoint (vlax-get x 'TextAlignmentPoint)))
     )
   )
   ;; not calling RotateToNormal here because the Rotate method
   ;; needs to be used, rather than put Rotation property for 2008.
   ;; Because attributes behave different in that version.
   ;; See topic named "vla-transformby problem rotating blocks"
   ;; dated 4/26/2007 in the customization NG. Check Tony's comments.
   (if
     (and
       flag
       (not (equal 1.0 (caddr nrml) 1e-5))
       (not (equal -1.0 (caddr nrml) 1e-5))
     )
     (progn
       (vlax-invoke obj 'Rotate 
         (vlax-get obj 'InsertionPoint) (+ (* pi 0.5) (angle '(0 0) nrml))
       )
       (setq renameflag T)
     )
   )
 ) ;end

 ;; The explode method doesn't work with hatch objects.
 ;; The patlst var is local in primary function.
 ;; Need to look at gradient hatches.

 ;; If a hatch has an odd normal and the hatch pattern is
 ;; available, the hatch is recreated to flatten it.
 ;; If the pattern isn't available, the hatch is exploded
 ;; and the result is flattened.

 ;; The HatchObjectType property specifies either a regular
 ;; hatch (zero) or a gradient hatch (one). Gradient hatch
 ;; was new in AutoCAD 2004. Like a solid hatch, a gradient hatch
 ;; cannot be exploded. If a gradient hatch has an odd normal
 ;; it's converted to a solid hatch to allow flattening.
 ;; The -hatchedit command does not work with a gradient hatch.
 ;; Gradients must be edited using the hatchedit dialog.

 ;; The HatchStyle style property determines Normal, Outer, Ignore.
 ;; The Style of the argument object is applied to the new hatch
 ;; if one is created.

 ;; Fixed a problem here when the hatch spacing of the existing
 ;; hatch is too dense so new hatch (or recreate boundary) fails.
 ;; Due to someone changed a standard hatch pattern?

 (defun FlatHatch (obj / rtd patname mark ss sset newobj)

   ;radians to degrees
   (defun rtd (radians)
  	(/ (* radians 180.0) pi)
   ) ;end

   (cond 
     ((TestZNormal obj)
       (CheckRename (vlax-get obj 'Elevation) 0)
       (vlax-put obj 'Elevation 0.0)
     )
     ((TestXYNormal obj)
       (vla-delete obj)
       (setq renameflag T)
     )
     ;; Added 7/21/2007.
     ;; A gradient hatch can be changed to a solid.
     ((and
		(vlax-property-available-p obj 'HatchObjectType)
		(= 1 (vlax-get obj 'HatchObjectType))
       )
       (vlax-put obj 'HatchObjectType 0)
       (ProcessList (list obj))
     )
     ;; Attempting to recreate the boundary and create a new hatch.
     ((and
		;; Recreate boundary introduced at 2006.
		(>= (atoi (getvar "AcadVer")) 16)
		(or patlst (setq patlst (LstACADPAT)))
		(setq patname (vlax-get obj 'PatternName))
		(vl-position patname patlst)
		(setq mark (entlast))
		(not (command "._hatchedit" (vlax-vla-object->ename obj) "b" "p" "n"))
		;; Selection set of the boundary object(s).
		(setq sset (SSAfterEnt mark))
		;; Added 7/10/2007 to prevent what's likely a rare problem.
		;; The hatch command includes an object which is not part of the
		;; selection set when zoomed way out. Seems like an AutoCAD bug.
		(not (command "zoom" "object" sset ""))
		(setvar "hpassoc" 1) 
		;(setvar "hpassoc" 0)
		(not (command "._hatch" patname 
               (vlax-get obj 'PatternScale)
               (rtd (vlax-get obj 'PatternAngle)) "s" sset ""
             )
		)
		;; Restore previous zoom.
		(not (command "zoom" "previous"))
		;; Delete boundary objects here rather than later.
		(if sset
  		(mapcar 'vla-delete (SSVLAList sset))
		)
		(setq newobj (vlax-ename->vla-object (entlast)))
		(eq "AcDbHatch" (vlax-get newobj 'ObjectName))
		;; updates the hatch
		(not (vl-catch-all-error-p 
  		(vl-catch-all-apply 'vlax-invoke 
			(list newobj 'Evaluate))))
  	) ;and
       (vlax-put newobj 'HatchStyle (vlax-get obj 'HatchStyle))
       (vlax-put newobj 'AssociativeHatch 0)
       (ApplyProps obj newobj)
     )
     (T (CommandExplode obj))
   ) ;cond
 ) ;end

 ;; AcDbSolid or AcDbTrace
 ;; Though Properties shows an Elevation value for a solid,
 ;; the vla-object does not have an elevation property.
 ;; Get the coord first, then change the normal, then put zzerocoord.
 (defun FlatSolidOrTrace (obj / coord)
   (CheckRename (vlax-get obj 'Thickness) 0)
   (vlax-put obj 'Thickness 0.0)
   (setq coord (vlax-get obj 'Coordinates))
   (cond
     ((TestZNormal obj)
       (CheckRename coord (ZZeroCoord coord))
       (vlax-put obj 'Coordinates (ZZeroCoord coord))
     )
     ((TestXYNormal obj)
       (TwoPointObj obj)
     )
     (T
       (vlax-put obj 'Normal '(0.0 0.0 1.0))
       (vlax-put obj 'Coordinates (ZZeroCoord coord))
     )
   )
 ) ;end

 (defun FlatShape (obj / ip nrml)
   (CheckRename (vlax-get obj 'Thickness) 0)
   (vlax-put obj 'Thickness 0.0)
   (setq ip (vlax-get obj 'InsertionPoint)
         nrml (vlax-get obj 'Normal)
   )
   (if (not (TestZNormal obj))
     (progn 
       (vlax-put obj 'Normal '(0.0 0.0 1.0))
       (RotateToNormal obj nrml)
       (setq renameflag T)
     )
   )
   (CheckRename ip (ZZeroPoint ip))
   (vlax-put obj 'InsertionPoint (ZZeroPoint ip))
 ) ;end

 (defun FlatRayOrXline (obj / bp sp dv)
   (setq bp (vlax-get obj 'BasePoint))
   (CheckRename bp (ZZeroPoint bp))
   (vlax-put obj 'BasePoint (ZZeroPoint bp))
   (setq sp (vlax-get obj 'SecondPoint))
   (CheckRename sp (ZZeroPoint sp))
   (vlax-put obj 'SecondPoint (ZZeroPoint sp))
   (setq dv (vlax-get obj 'DirectionVector))
   (CheckRename dv (ZZeroPoint dv))
   (vlax-put obj 'DirectionVector (ZZeroPoint dv))
 ) ;end

 ;; AcDbRasterImage or AcDbWipeout
 ;; Flatten raster (image) objects and wipeouts which are not 
 ;; parallel to WCS. Discovered by accident, changing the rotation 
 ;; property flattens ones which are not parallel to WCS.
 (defun FlatWipeoutOrRaster (obj / org)
   (vlax-put obj 'Rotation (vlax-get obj 'Rotation))
   (setq org (vlax-get obj 'Origin))
   (CheckRename org (ZZeroPoint org))
   (vlax-put obj 'Origin (ZZeroPoint org))
 ) ;end

 ;; Like a Table object the Normal property is not exposed.
 ;; Modify the normal using entmod.
 (defun FlatMline (obj / ename elst mark lst ptlst pts z line)
   (setq ename (vlax-vla-object->ename obj))
   (cond
     ;; Flatten to a single line.
     ((TestXYNormal ename)
		;; Could use CommandExplode if that function was changed to
		;; return the exploded objects list rather than passing that
		;; list to ProcessList. Other functions would have to be modified.
		;(setq lst (CommandExplode obj))
		(setq mark (entlast))
		(command "._explode" ename)
		;; Test object was exploded.
		(if (setq lst (SSVLAList (SSAfterEnt mark)))
  		(progn
			(foreach x lst
  			(setq ptlst (cons (ZZeroPoint (vlax-get x 'StartPoint)) ptlst))
  			(setq ptlst (cons (ZZeroPoint (vlax-get x 'EndPoint)) ptlst))
			)
			(setq pts (Farthest2Points ptlst))
			(setq line (car lst))
			(vlax-put line 'StartPoint (car pts))
			(vlax-put line 'EndPoint (cadr pts))
			(mapcar 'vla-delete (cdr lst))
			(setq renameflag T)
  		)
		)
  	)
     ;; Flatten mline with an odd normal.
     ((not (TestZNormal ename))
       (setq elst (entget ename))
       (entmod (subst (cons 210 '(0.0 0.0 1.0)) (assoc 210 elst) elst))
       ;; This is needed to flatten, though not at Z zero. Strange.
       (vlax-put obj 'Coordinates (ZZeroCoord (vlax-get obj 'Coordinates)))
       ;; All the Z values should be the same at this point.
       (setq z (caddr (vlax-get obj 'Coordinates)))
       (if (not (zerop z))
         (vlax-invoke obj 'Move (list 0.0 0.0 z) '(0.0 0.0 0.0))
       )
       (setq renameflag T)
     )
     ;; Flatten to Z zero coordinates. Move because this
     ;; (vlax-put obj 'Coordinates (ZZeroCoord (vlax-get obj 'Coordinates)))
     ;; does not work to change the Z vlaues.
     (T
       (setq z (caddr (vlax-get obj 'Coordinates)))
       (CheckRename z 0)
       (if (not (zerop z))
         (vlax-invoke obj 'Move (list 0.0 0.0 z) '(0.0 0.0 0.0))
       )
     )
   )
 ) ;end

 ;; The Direction property is similar to angle or rotation property.
 ;; The normal isn't exposed under Active X, but is
 ;; available using entget. Use entmod to change it.
 (defun FlatTable (obj / ename elst nrml ip dir)
   (setq ename (vlax-vla-object->ename obj)
         elst (entget ename)
         nrml (cdr (assoc 210 elst))
         ;The original ip for case where the normal is modified.
         ip (vlax-get obj 'InsertionPoint)
         dir (vlax-get obj 'Direction)
   )
   (if 
     (not
       (or
         ;; removed fuzz 6/6/2007
         (equal nrml '(0.0 0.0 1.0))
         (equal nrml '(0.0 0.0 -1.0))
       )
     )
     (progn
       (entmod (subst (cons 210 '(0.0 0.0 1.0)) (assoc 210 elst) elst))
       (setq renameflag T)
     )
   )
   (CheckRename ip (ZZeroPoint ip))
   (vlax-put obj 'InsertionPoint (ZZeroPoint ip))
   (CheckRename dir (ZZeroPoint dir))
   ;; Fix case when direction Z value is like this (0.569751 0.0 0.821818).
   (vlax-put obj 'Direction (ZZeroPoint dir))
   (vlax-invoke obj 'RecomputeTableBlock acTrue)
 ) ;end

 ;; Regions are exploded. Seems there's no other way to deal with them.
 (defun FlatRegion (obj / lst)
   (if (setq lst (vlax-invoke obj 'Explode))
     (progn
       (vla-delete obj)
       (setq renameflag T)
       (ProcessList lst)
     )
     ;Else set count of objects not processed and the ObjectName.
     (progn
       (setq cnt (1+ cnt))
       (if (not (vl-position "AcDbRegion" notflatlst))
         (setq notflatlst (cons "AcDbRegion" notflatlst))
       )
     )
   )
 ) ;end

 ;;;;;;;; END FLATTEN SUB-FUNCTIONS ;;;;;;;;;;;;;

 ;; ProcessList
 ;; Argument: a list of vla-objects.
 ;; It's primary function is send vla-objects to other sub-functions
 ;; for processing. All objects pass through this function.
 ;; It handles the progress indicator Spinbar. 
 ;; It also checks for objects passed which may be erased elsewhere.
 ;; And it does some pre-processing to check for very small objects,
 ;; which are deteted.
 
 (defun ProcessList (lst / objname)
   
   ;; Report either block definitions are being 
   ;; flattened or the selection set.
   (if inoutlst
     (princ 
       (strcat "\rFlattening blocks, please do not Cancel... " 
         (setq *sbar (Spinbar *sbar)) "\t")
     )    
     (princ 
       (strcat "\rFlattening selection... " 
         (setq *sbar (Spinbar *sbar)) "\t")
     )
   )

   (foreach x lst
     (if (not (vlax-erased-p x))
       (progn
         (setq objname (vlax-get x 'ObjectName))
         (cond
           ((eq "AcDbLine" objname)
             (if (< (vlax-get x 'Length) 1e-6)
               (vla-delete x)
               (FlatLine x)
             )
           )
           ((eq "AcDbCircle" objname)
             (if (< (vlax-get x 'Radius) 1e-6)
               (vla-delete x)
               (FlatCircle x)
             )
           )
           ((eq "AcDbArc" objname)
             (if 
               (or
                 (< (vlax-get x 'TotalAngle) 1e-6)
                 (< (vlax-get x 'Radius) 1e-6)
               )
               (vla-delete x)
               (FlatArc x)
             )
           )
           ((eq "AcDbEllipse" objname)
             (if
               (and
                 (< (vlax-get x 'MajorRadius) 1e-6)
                 (< (vlax-get x 'MinorRadius) 1e-6)
               )
               (vla-delete x)
               (FlatEllipse x)
             )
           )
           ((or
               (eq "AcDbPolyline" objname)
               (eq "AcDb2dPolyline" objname)
             )
             (if (< (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x)) 1e-6)
               (vla-delete x)
               (FlatPLine x)
             )
           )
           ((eq "AcDbSpline" objname)
             (if (< (vlax-curve-getEndParam x) 1e-6)
               (vla-delete x)
               (FlatSpline x)
             )
           )
           ((or
               (eq "AcDb3dPolyline" objname)
               (eq "AcDbFace" objname)
               (eq "AcDbLeader" objname)
               (eq "AcDbPolygonMesh" objname)
             )
             (FlatCoordinates x)
           )
           ((eq "AcDbPolyFaceMesh" objname)
             (FlatPolyFaceMesh x)
           )
           ((eq "AcDbPoint" objname)
             (FlatPointObj x)
           )
           ((and 
               (eq "AcDbBlockReference" objname)
               (vlax-property-available-p x 'Path)
             )
             (FlatXref x)
           )
           ;; Revised 7/16/2007 - explode a block which only
           ;; contains other blocks. It won't work if the block
           ;; reference is NUS beyond what ModBlockScale does.
           ((eq "AcDbBlockReference" objname)
             (vlax-for y (vla-item blocks (vlax-get x 'Name)) 
               (setq templst (cons y templst))
             )
             (if 
               (and 
                 (vl-every '(lambda (z)
                   (eq "AcDbBlockReference" (vlax-get z 'ObjectName))) 
                     templst)
                 (ModBlockScale x)
               )
               (progn
                 (ProcessList (vlax-invoke x 'Explode))
                 (vla-delete x)
                 (setq templst nil)
               )
               (ExpBlockMethod x)
             )
             (setq templst nil)
           )
           ((or
  			(eq "AcDbText" objname)
  			(eq "AcDbAttribute" objname)
  			(eq "AcDbAttributeDefinition" objname)
             )
             (FlatText x)
           )
           ((eq "AcDbMText" objname)
             (FlatMText x)
           )          
           ((eq "AcDbTable" objname)
             (FlatTable x)
           )
           ((eq "AcDbHatch" objname)
             (FlatHatch x)
           )
           ((wcmatch objname "*Dimension")
             (FlatDimension x)
           )
           ((eq "AcDbRegion" objname)
             (FlatRegion x)
           )
           ;; Keep in mind the 2008 "flatshot" command 
           ;; for flattening 3D solids.
           ((or
  			(eq "AcDb3dSolid" objname) 
  			(eq "AcDbBody" objname)
  			(eq "AcDbSurface" objname)
             )
             (CommandExplode x)
           )
           ((eq "AcDbShape" objname)
             (FlatShape x)
           )
           ((or
  			(eq "AcDbSolid" objname)
  			(eq "AcDbTrace" objname)
             )
             (FlatSolidOrTrace x)
           )
           ((or
  			(eq "AcDbRay" objname)
  			(eq "AcDbXline" objname)
             )
             (FlatRayOrXline x)
           )
           ;; Cannot be exploded.
           ((eq "AcDbMInsertBlock" objname)
             (FlatMInsert x)
           )
           ((eq "AcDbMline" objname)
             (FlatMline x)
           )
           ((or
  			(eq "AcDbWipeout" objname)   
  			(eq "AcDbRasterImage" objname)
             )
             (FlatWipeoutOrRaster x)
           )
           ((eq "AcDbFcf" objname)
             (FlatTolerance x)
           )
           ((or
  			(wcmatch objname "AecDb*,AecsDb*,AeccDb*")
  			(eq "AcDbZombieEntity" objname)
             )
             (CommandExplode x)
           )
           ;; Ignore viewports.
           ((eq "AcDbViewport" objname))
           ;; Any object not included above.
           (T 
             (setq cnt (1+ cnt))
             (if (not (vl-position objname notflatlst))
               (setq notflatlst (cons objname notflatlst))
             )
           )
         ) ;cond
       ) ;progn
     ) ;if not erased
   ) ;foreach
 ) ;end

 ;;;;;;; END SuperFlatten SUB-FUNCTIONS ;;;;;;;

 ;;;;;;; START PRIMARY ROUTINE ;;;;;;;

 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
       blocks (vla-get-Blocks doc)
       layouts (vla-get-Layouts doc)
       views (vla-get-Views doc) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
       mspace (vla-get-ModelSpace doc)
       mspacecnt (vlax-get mspace 'Count)
 )
 
 ;; Delete a temporary saved view if it exists.
 (vl-catch-all-apply '(lambda () (vla-delete (vla-item views "zztemp")))) 

 (vla-StartUndoMark doc)

 (setq locklst (UnlockLayers doc)
       hpa (getvar "hpassoc")
       expm (getvar "explmode")
       ucsfol (getvar "ucsfollow")
       cnt 0
       expblkcnt 0
 )

 (setvar "ucsfollow" 0)


 ;; Get the selection set.
 (if (setq ss (ssget (list (cons 410 (getvar "ctab")))))
   (progn

     ;;; ----- START PROGRAM OPTIONS ----- ;;;

     ;; Added program options 7/10/2007.
     ;; Thanks to Steve Doman for his help with the interface.

     ;; Added 8/6/2007 - recall previous options for Overkill
     ;; and explodable blocks in 2006 or later.
     (or *expans* (setq *expans* "No"))
     (or *overkillans* (setq *overkillans* "No"))
     
     ;; Moved from above 8/6/2007.
     (setq optans T)
     
     (cond
       ;; pre 2006 and ET is not loaded
       ((and (< (atof (getvar "AcadVer")) 16.2) (not acet-ss-remove-dups))
         (while optans

           (if presufstr 
             (princ (strcat "\nCurrent options: Rename=" renameans "> " presufstr))
             (princ (strcat "\nCurrent options: Rename=Unspecified"))
           )

           (initget "Rename")
           (setq optans
             (getkword 
               "\nSuperFlatten options [Rename blocks] < >: ")
           )
           (cond 
             ((eq optans "Rename")
               (initget "Prefix Suffix")
               (setq renameans 
                 (getkword "\nBlock name options: [Prefix/Suffix] <S>: ")
               )
               (if (not renameans) (setq renameans "Suffix"))
               (cond
                 ((eq renameans "Prefix")
                   (setq presufstr (PrefixSuffix "prefix"))
                 )
                 ((eq renameans "Suffix")
                   (setq presufstr (PrefixSuffix "suffix"))
                 )
               )
             )
           )
         )
       )

       ;; pre 2006 and ET is loaded
       ((and (< (atof (getvar "AcadVer")) 16.2) acet-ss-remove-dups)
         (while optans

           (if presufstr 
             (princ (strcat "\nCurrent options: Rename=" renameans "> " presufstr))
             (princ (strcat "\nCurrent options: Rename=Unspecified"))
           )
           (princ (strcat "  Overkill=" *overkillans*))

           (initget "Rename Overkill")
           (setq optans
             (getkword 
               "\nSuperFlatten options [Rename blocks/Overkill] < >: ")
           )
           (cond 
             ((eq optans "Rename")
               (initget "Prefix Suffix")
               (setq renameans 
                 (getkword "\nBlock name options: [Prefix/Suffix] <S>: ")
               )
               (if (not renameans) (setq renameans "Suffix"))
               (cond
                 ((eq renameans "Prefix")
                   (setq presufstr (PrefixSuffix "prefix"))
                 )
                 ((eq renameans "Suffix")
                   (setq presufstr (PrefixSuffix "suffix"))
                 )
               )
             )
             ((eq optans "Overkill")
               (initget "Yes No")
               (setq *overkillans* 
                 (getkword "\nRun Overkill after flattening? [Yes/No] <N>: ")
               )
               (if (not *overkillans*) (setq *overkillans* "No"))
             )
           )
         )
       )

       ;; 2006 or later and ET is not loaded
       ((and (>= (atof (getvar "AcadVer")) 16.2) (not acet-ss-remove-dups))
         (while optans
           (if presufstr 
             (princ (strcat "\nCurrent options: Rename=" renameans "> " presufstr))
             (princ (strcat "\nCurrent options: Rename=Unspecified"))
           )            
           (princ (strcat "  Explodable=" *expans*))

           (initget "Rename Explodable")
           (setq optans
             (getkword 
               "\nSuperFlatten options [Rename blocks/Explodable blocks] < >: ")
           )
           (cond 
             ((eq optans "Rename")
               (initget "Prefix Suffix")
               (setq renameans 
                 (getkword "\nBlock name options: [Prefix/Suffix] <S>: ")
               )
               (if (not renameans) (setq renameans "Suffix"))
               (cond
                 ((eq renameans "Prefix")
                   (setq presufstr (PrefixSuffix "prefix"))
                 )
                 ((eq renameans "Suffix")
                   (setq presufstr (PrefixSuffix "suffix"))
                 )
               )
             )
             ((eq optans "Explodable")
               (initget "Yes No")
               (setq *expans* 
                 (getkword 
                   "\nTemporarily set all blocks explodable? [Yes/No] <N>: ")
               )
               (if (not *expans*) (setq *expans* "No"))
             )
           )
         )
       )

       ;; 2006 or later and ET is loaded
       ((and (>= (atof (getvar "AcadVer")) 16.2) acet-ss-remove-dups)
         (while optans            
           (if presufstr 
             (princ (strcat "\nCurrent options: Rename=" renameans "> " presufstr))
             (princ (strcat "\nCurrent options: Rename=Unspecified"))
           )
           
           (princ (strcat "  Explodable=" *expans*
              			"  Overkill=" *overkillans*
      			)
           )
           
           (initget "Rename Explodable Overkill")
           (setq optans
             (getkword 
               "\nSuperFlatten options [Rename blocks/Explodable blocks/Overkill] < >: ")
           )
           (cond 
             ((eq optans "Rename")
               (initget "Prefix Suffix")
               (setq renameans 
                 (getkword "\nBlock name options: [Prefix/Suffix] <S>: ")
               )
               (if (not renameans) (setq renameans "Suffix"))
               (cond
                 ((eq renameans "Prefix")
                   (setq presufstr (PrefixSuffix "prefix"))
                 )
                 ((eq renameans "Suffix")
                   (setq presufstr (PrefixSuffix "suffix"))
                 )
               )
             )
             ((eq optans "Explodable")
               (initget "Yes No")
               (setq *expans* 
                 (getkword 
                   "\nTemporarily set all blocks explodable? [Yes/No] <N>: ")
               )
               (if (not *expans*) (setq *expans* "No"))
             )
             ((eq optans "Overkill")
               (initget "Yes No")
               (setq *overkillans* 
                 (getkword "\nRun Overkill after flattening? [Yes/No] <N>: ")
               )
               (if (not *overkillans*) (setq *overkillans* "No"))
             )
           )
         )
       )
     ) ; end options cond
     
     ;;; ----- END PROGRAM OPTIONS ----- ;;;

     ;; Added 6/25/2007 to deal with the 2006 Explodable blocks option.
     ;; It might be smarter by looking at selected
     ;; blocks and then decide whether anything needs to be done.
     ;; But that seems a bit of overkill since in most cases the
     ;; user will select all. The following seems sufficient.

     (if (eq "Yes" *expans*)
       (vlax-for x blocks 
         (if 
           (and
             (vlax-property-available-p x 'Explodable)
             (eq acFalse (vlax-get x 'Explodable))
           )
           (progn
             (setq expblklst (cons x expblklst))
             (vlax-put x 'Explodable acTrue)
           )
         )
       )
     )

     ;(starttimer)

     (setvar "cmdecho" 0)
     (setvar "explmode" 1)

     ;; Flattening needs to be done in WCS due to how some
     ;; objects behave while interacting with the code.
     ;; An isometric view like SW can be used without 
     ;; triggering the following.
     ;; There's a small speed penalty if the current view
     ;; has to be saved and restored.
     ;; The UCS/view can be whatever when the code is run 
     ;; and if not WCS, it will be restored as needed.
     (if (zerop (getvar "worlducs"))
       (progn
         (command "._view" "s" "zztemp")
         (command "._ucs" "w")
         (if (zerop (getvar "ucsfollow"))
           (command "._plan" "w")
         )
       )
     )

     ;; Convert the selection set to a list of vla-objects.
     ;; Might use the ActiveSelectionSet here.
     (setq lst (SSVLAList ss))

     ;; Make a list of block names selected including nested names.
     (foreach x lst
       (if 
         (and 
           (eq "AcDbBlockReference" (vlax-get x 'ObjectName))
           (not (vlax-property-available-p x 'Path))
         )
         (progn
           (setq name (vlax-get x 'Name))
           (if (not (vl-position name blknamelst))
             (setq blknamelst (cons name blknamelst))
           )
           (foreach i (GetNestedNames blocks name)
             (if (not (vl-position i blknamelst))
               (setq blknamelst (cons i blknamelst))
             )
           )
         )
       )
     )

     ;; Process the selected objects before flattening block defintions.
     ;; Moved to this location 7/19/2007. It needs to be here rather than
     ;; after flatten definitions so the condition for block references
     ;; in ProcessList does what it should. Explode blocks which only
     ;; contain other blocks.
     
     (ProcessList lst)

     ;; Check for for empty blocks.
     ;; Causes an error with copy objects.
     ;; Empty block named "CIRCULAR STAIRS" found in Ken Luk's 
     ;; customer files example file.
     (if blknamelst
       (progn
         ;; Delete the temporary layout if it already exists.
         (vl-catch-all-apply '(lambda () (vla-delete (vla-item layouts "SuperFlatten layout"))))
         (setq actlayout (vlax-get doc 'ActiveLayout)
               templayout (vlax-invoke layouts 'Add  "SuperFlatten layout")
               layoutblk (vlax-get templayout 'Block)
         )
         (vlax-put doc 'ActiveLayout templayout)
         (foreach x blknamelst
           (setq blkdef (vla-item blocks x)
                 inoutlst nil
                 renameflag nil
           )

           ;; added 7/16/2007 - from Steve's large example file:
           ;; a block definition
           ;; Name = "3D-BASE-STREET-TREES"
           ;; Origin = (66965.5 13010.2 -354.0)
           (setq orig (vlax-get blkdef 'Origin))
           (CheckRename orig (ZZeroPoint orig))
           (vlax-put blkdef 'Origin (ZZeroPoint (vlax-get blkdef 'Origin)))
           
           ;; List objects in source block and filter out viewports.
           (vlax-for i blkdef
             (or
               (eq "AcDbViewport" (vlax-get i 'ObjectName))
               (setq inoutlst (cons i inoutlst))
             )
           )

           (if inoutlst
             (progn

               ;; Copy list to the layout block.
               (setq inoutlst (vlax-invoke doc 'CopyObjects inoutlst layoutblk))

               ;; Empty the source block, except for viewports.
               (vlax-for i blkdef
                 (or
                   (eq "AcDbViewport" (vlax-get i 'ObjectName))
                   (vla-delete i)
                 )
               )

               ;; Flatten objects in layout.
               (ProcessList inoutlst)
               
               (setq inoutlst nil)

               ;; List the flattened objects, filter out viewports.
               (vlax-for i layoutblk
                 (or
                   (eq "AcDbViewport" (vlax-get i 'ObjectName))
                   (setq inoutlst (cons i inoutlst))
                 )
               )

               ;; Copy the flattened objects in the layout back into
               ;; the block definition and delete objects in the layout.
               (if inoutlst
                 (progn
                   (vlax-invoke doc 'CopyObjects inoutlst blkdef)
                   (mapcar 'vla-delete inoutlst)
                 )
               )
             )
           )

           (if 
             (and 
               ;; Cannot rename anonymous blocks.
               (not (vl-string-search "*" x))
               renameflag 
               renameans
               presufstr
             )
             (cond
               ((and
      			(eq renameans "Prefix")
      			(setq newname (strcat presufstr x))
                 )
                 ;; Added existing block name check 8/9/2007.
                 (if (ValidItem blocks newname)
                   (setq notrenamedlst (cons x notrenamedlst))
                   (progn
                     (vlax-put blkdef 'Name newname)
                     (setq newnamelst (cons newname newnamelst))
                   )
                 )
               )
               ((and
      			(eq renameans "Suffix")
      			(setq newname (strcat x presufstr))
                 )
                 ;; Added existing block name check 8/9/2007.
                 (if (ValidItem blocks newname)
                   (setq notrenamedlst (cons x notrenamedlst))
                   (progn
                     (vlax-put blkdef 'Name newname)
                     (setq newnamelst (cons newname newnamelst))
                   )
                 )
               )
             )
           )
         ) ;foreach
         (vlax-put doc 'ActiveLayout actlayout)
         ;templayout is deleted in the error handler.
       ) ;progn
     ) ;if blknamelst

     (if blknamelst
       (vla-regen doc acActiveViewport)
     )

     (if 
       (and 
         (eq "Yes" *overkillans*)
         (setq ss 
           (cadr 
             (acet-ss-remove-dups 
               (ssget "x" '((410 . "Model"))) 1e-6 nil)
           )
         )
       )
       (command "._erase" ss "")
     )


     (if (tblsearch "view" "zztemp")
       (command "._view" "restore" "zztemp" "._view" "delete" "zztemp")
     )

     (if (or newnamelst notrenamedlst)
       (textscr)
     )
     
     (if newnamelst
       (progn
         (princ "\nThe following blocks were renamed: ")
         (foreach x newnamelst
           (print x)
         )
       )
     )

     (if notrenamedlst
       (progn
         (princ "\nThe following blocks were not renamed due to existing block name conflict: ")
         (foreach x notrenamedlst
           (print x)
         )
       )
     )

     (if (> expblkcnt 0)
       (princ (strcat "\nNumber of blocks exploded: " (itoa expblkcnt)))
     )

     (princ 
       (strcat "\nNumber of objects in model space before: " 
         (itoa mspacecnt) " after: " (itoa (vlax-get mspace 'Count)) " \n"
       )
     )

     (if (> cnt 0)
       (progn
         (princ 
           (strcat "\nNumber of objects not processed or flattened: " (itoa cnt) " \n")
         )
         (if notflatlst
           (progn
             (princ "\nObject types not flattened: ")
             (foreach x notflatlst
               (setq pos (+ 3 (vl-string-search "Db" x)))
               (princ (strcat (substr x pos) " "))
             )
             (print)
           )
         )
       )
     )
     
     ;(endtimer)
     
   ) ;progn

   (princ "\nNothing selected. ")

 ) ;if
 
 (*error* nil)

) ;end SuperFlatten

 ;shortcut
 (defun c:SF () (c:SuperFlatten))

;;;;;;; END PRIMARY ROUTINE ;;;;;;;;

[bonuscad]

Bonjour,

 

Pour passer tes entitées en Z à zéro tu peux tenter cette procédure my_project.lsp

 

Normalement cette procédure marche bien pour des entités filaires qui ont du mal à être traitées par _move en aller-retour avec le Z à 1E99 et -1E99. Par contre les solides 3D ne sont pas traités...

Elle est plus rapide que FLATTEN des ExpressTools, mais flatten reste cependant une bonne procédure qui peut te convenir...

[ricodemexico]

jalna

Merci pour ton lisp, effectivement ça fonctionne . :)

il remplacera le mien.

 

Il me reste toujours cette histoire de changement d'échelle à comprendre.

 

Merci

[ricodemexico]

Bonuscad, merci,

 

j'essaierai ce lisp pour tester.

[x_all]

une idée de la valeur des variables :

 

- INSUNITS

- INSUNITSDEFSOURCE

- INSUNITSDEFTARGET

- MEASUREMENT

- MEASUREINIT

 

dans les 2 dessins?

[ricodemexico]

une idée de la valeur des variables :

 

- INSUNITS

- INSUNITSDEFSOURCE

- INSUNITSDEFTARGET

- MEASUREMENT

- MEASUREINIT

 

dans les 2 dessins?

 

pour le plan source :

- INSUNITS 0

- INSUNITSDEFSOURCE 4

- INSUNITSDEFTARGET 4

- MEASUREMENT 1

- MEASUREINIT 1

 

 

pour le plan cible

 

- INSUNITS 1

- INSUNITSDEFSOURCE 4

- INSUNITSDEFTARGET 4

- MEASUREMENT 1

- MEASUREINIT 1

 

 

merci :D

[x_all]

à priori tes blocs sont sans unités, et insunit étant à 1 dans le dessin cible ils passent en pouce...

remet insunit à 0 ça devrai aller...

[ricodemexico]

à priori tes blocs sont sans unités, et insunit étant à 1 dans le dessin cible ils passent en pouce...

remet insunit à 0 ça devrai aller...

 

merci x_all

[ricodemexico]

Bonjour,

 

Pour passer tes entitées en Z à zéro tu peux tenter cette procédure my_project.lsp

 

Normalement cette procédure marche bien pour des entités filaires qui ont du mal à être traitées par _move en aller-retour avec le Z à 1E99 et -1E99. Par contre les solides 3D ne sont pas traités...

Elle est plus rapide que FLATTEN des ExpressTools, mais flatten reste cependant une bonne procédure qui peut te convenir...

 

 

Bonjour BonusCad,

comment fais-tu pour lancer ton Lisp? Quel est son raccourci?

 

merci

[Goldorak44]

La commande de lancement est : my_project ;)

[ricodemexico]

merci :)