Страна, помогите! Каким образом между двумя непараллельными полилиниями для своих шкурных расчётов построить точно посередине между ними залегающую среднюю полилинию? Это две непараллельные обязательно сглаженные полилинии. Таково требование при подсчете запасов полезного ископаемого.
Двумя этими линиями указывается скажем выход пласта полезного ископаемого под наносы. Но подсчет запасов я обязан вести по средней линии между двумя этими границами. И, естественно, этих моментов довольно много, чтобы врукопашную выбирать среднюю точку. Из-за этого возникла эта проблема. Заранее благодарен.

[Startrek]

esli pravil'no ponjal sm kartinku
[ATTACH]1063859134.gif[/ATTACH]

[Arkady]

Я так понимаю ,что эти две поллилинии - это профиля разрезов?
Единственное что приходит в голову если это конечно профиля)
взять одну из полилинйй за базу, искать с определенным шагом расстояния по вертикали до другой линии ,и построить по ним результирующую(без сглаживания).Если идти с достаточно мелким шагом то результат будет приемлимым.

[bimari]

Действительно ребята, очень нужен лисп! Так надоело выполнять однообразную работу, тратя по пол дня на такую мутоту! Помогите! На предыдущей картинке правильно нарисовано, только ещё необходимо, чтобы это было применимо к кривым! Заранее спасибо!

[Огурец]

Xline c параметром B (бисектрисса), затем trim и pedit...

[forMA]

Может сгодится:

Код:

[Выделить все]

;;----------------------------------------------------
;;  Функция для построения биссектрисы двух отрезков
;;  Отрезки могут быть параллельны, пересекаться или
;;  пересекаться их продолжение.
;;  Если отрезки не будут лежать в одной плоскости -
;;  результат работы не определен.
;;----------------------------------------------------
(defun C:BI_LINE ( / en1 en2 e1 e2 p1 p2 p11 p12 p21 p22 tmp 
d1 d2 _bm)
    (setvar "CMDECHO" 0)
    (setq en1 (car (entsel "\nВыберите первый отрезок: ")))
    (if en1 (redraw en1 3))
    (setq en2 (car (entsel "\nВыберите второй отрезок: ")))
    (if en2 (redraw en2 3))
    (setq _bm (getvar "BLIPMODE")) (setvar "BLIPMODE" 0)
    (if (and en1 en2 (setq e1 (entget en1)) (setq e2 (entget en2))
             (= "LINE" (cdr (assoc 0 e1))) (= "LINE" (cdr (assoc 0 e2))))
     (progn
      (setq p11 (cdr (assoc 10 e1)) p12 (cdr (assoc 11 e1))
            p21 (cdr (assoc 10 e2)) p22 (cdr (assoc 11 e2)))
      (if (> (+ (distance p11 p21) (distance p12 p22))
             (+ (distance p11 p22) (distance p12 p21))) (progn
          ; Меняем местами начало и конец второго отрезка
          (setq tmp (list p21 p22) p21 (cadr tmp) p22 (car tmp))
      ))
      (cond
        ;; Отрезки сами пересекаются
        ((setq p1 (inters p11 p12 p21 p22 T))
          (setq d1 (max (distance p1 p11) (distance p1 p21)))
          (setq d2 (max (distance p1 p12) (distance p1 p22)))
          (setq p11 (polar p1 (angle p1 p11) d1))
          (setq p12 (polar p1 (angle p1 p12) d2))
          (setq p21 (polar p1 (angle p1 p21) d1))
          (setq p22 (polar p1 (angle p1 p22) d2))
        )
        ;; Пересекаются прямые, на которых лежат отрезки
        ((setq p1 (inters p11 p12 p21 p22 nil))
          (if (> (distance p1 p11) (distance p1 p12)) (progn
             (setq tmp (list p11 p12) p11 (cadr tmp) p12 (car tmp))
             (setq tmp (list p21 p22) p21 (cadr tmp) p22 (car tmp))
          )) ;; (if (progn
          (setq d1 (min (distance p1 p11) (distance p1 p21)))
          (setq d2 (max (distance p1 p12) (distance p1 p22)))
          (setq p11 (polar p1 (angle p1 p11) d1))
          (setq p12 (polar p1 (angle p1 p12) d2))
          (setq p21 (polar p1 (angle p1 p21) d1))
          (setq p22 (polar p1 (angle p1 p22) d2))
        )
      ) ;; (cond
      (setq p1 (mapcar '* '(0.5 0.5 0.5) (mapcar '+ p11 p21)))
      (setq p2 (mapcar '* '(0.5 0.5 0.5) (mapcar '+ p12 p22)))
      (command "_.LINE" "_none" (trans p1 0 1)
                        "_none" (trans p2 0 1) "")
     )
     (progn
       (princ "\nЧто-то не выбрано, или выбрано что-то не то!")
     )
    )
    (setvar "BLIPMODE" _bm)
    (if en1 (redraw en1 4))
    (if en2 (redraw en2 4))
    (princ)
)

Выкладываю без разрешения автора. Но, мыслю он не будет в претензии Главное, чтоб польза была

[Румын]

В составе СПДСграфикс есть команда средняя линия, и она работает как с прямыми, так и с дугами НО при наличии у дуг общего центра (что понятно - в противном случае получается уже кривая второго порядка, для которой и вычисления совсем другие и точного отображения в автогаде добиться не очень-то, даже при помощи сплайна)

[Vlad®]

и как всегда, для Комапаса этот вопрос просто не существует.

[DEM]

Не думаю чтобы стандартными методами Компас сможет это решить.
Вы наверное не до конца прочли.
Т.к. требуется сделать еще одну полилинию между двумя криволинейными (в смысле они продолжительные с множеством изгибов).

[bimari]

Лисп BI_LINE отлично работает, НО только для отрезков, а мне очень нужно для полилинии, причем эти плинии не пересекаются, что облегчает наверняка написание проги, пожалуйста помогите.
Вот примерно, что мне надо...
[ATTACH]1161256558.dwg[/ATTACH]

[Vlad®]

Если задача эта разовая - для построения графика нужно построить одну кривую между двух других, то можно решить ее функцией Blend в Кореле или им подобных. Может это и не спортивно, зато эффективно. Пробовал. Получилось

------------------------------------
на каждого мудреца довольно просторы©

[Кулик Алексей aka kpblc]

Что-то никто не вспомнил про привязку _m2p...

[bimari]

К сожалению задача не разовая, а многократная, необходимая для построения горизонтальной разметки дорог в местах уширения дороги (где обочины дороги не параллельные). Пыталась строить в ручную, но ужасно припекло! Представье если трасса с пару десятков километров :?

[Zouss]

файлик с примером приложите - есть определенные соображения, хочется отладить на вашем типичном чертеже

[bimari]

Вот наглядный пример того, что мне надо получить в конце. Строила вручную...
[ATTACH]1161269279.dwg[/ATTACH]

[VVA]

Пробуй

Код:

[Выделить все]

;Middle PolyLine (MPL)
(defun C:MPL ( / en1 en2 e1 e2 p1 p2 p11 p12 p21 p22 tmp rev dL1 dpar1 dpar2 SP1 SP2 lst1 lst2 lstc i *error*)
  (defun *error* (msg)
  (if en1 (redraw en1 4))(if en2 (redraw en2 4))
    (vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object))))
  (vl-load-com)
  (vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
  (setvar "CMDECHO" 0) 
  (setq en1 (car (entsel "\nВыберите первую границу: "))) 
  (if en1 (redraw en1 3)) 
  (setq en2 (car (entsel "\nВыберите вторую границу: "))) 
  (if en2 (redraw en2 3))
   (if (and en1 en2 (setq e1 (entget en1)) (setq e2 (entget en2)) 
            (wcmatch (cdr (assoc 0 e1)) "*LINE,ARC")
	    (wcmatch  (cdr (assoc 0 e2)) "*LINE,ARC")) 
     (progn
      (setq curv1 (vlax-ename->vla-object en1)
	    curv2 (vlax-ename->vla-object en2)
	     p11  (vlax-curve-getStartPoint curv1)
	     p12  (vlax-curve-getEndPoint curv1)
	     p21  (vlax-curve-getStartPoint curv2)
	     p22  (vlax-curve-getEndPoint curv2)
	    )
      (if (> (+ (distance p11 p21) (distance p12 p22)) 
             (+ (distance p11 p22) (distance p12 p21)))
	(setq rev t)(setq rev nil))
      (initget 6)
      (setq dL1 (if (setq tmp (getint "\nКоличество опорных точек <100>: ")) tmp 100))
      (setq p1 (vlax-curve-getDistAtParam curv1 (vlax-curve-getEndParam curv1));_Длинна 1
	    p2 (vlax-curve-getDistAtParam curv2 (vlax-curve-getEndParam curv2));_Длинна 2
;;	   tmp (1+(fix (/ p1 dL1)));_Кол-во точек
	   tmp dL1
	   dpar1 (/ (- (vlax-curve-getEndParam curv1)(vlax-curve-getStartParam curv1)) tmp)
	   dpar2 (/ (- (vlax-curve-getEndParam curv2)(vlax-curve-getStartParam curv2)) tmp)
      SP1 (vlax-curve-getStartParam curv1)
      SP2 (vlax-curve-getStartParam curv2) 	    
	     i 0)
       (setq lst1 nil i 0 lst2 nil)
       (while (and (< (setq par1 (+ SP1 (* i dpar1)))(vlax-curve-getEndParam curv1))
		   (< (setq par2 (+ SP2 (* i dpar2)))(vlax-curve-getEndParam curv2)))
	(setq lst1 (append lst1 (list par1))
	      lst2 (append lst2 (list par2))
	      i (1+ i)))
       (setq lst1 (append lst1 (list (vlax-curve-getEndParam curv1))))
       (setq lst2 (append lst2 (list (vlax-curve-getEndParam curv2))))
       (if rev (setq lst2 (reverse lst2)))(setq lstc nil)
       (mapcar '(lambda (pr1 pr2)
	 (setq p1 (vlax-curve-getPointAtParam curv1 pr1))
	 (setq p2 (vlax-curve-getPointAtParam curv2 pr2))
	 (if (and p1 p2)(progn
	 (setq ptc (polar p1 (angle p1 p2)(* 0.5 (distance p1 p2))))
	 (setq lstc (append lstc (list ptc)))
;	 (vl-cmdf "_.LINE" p1 p2 "")
	  ))) lst1 lst2)
      (vl-cmdf "_.PLINE" (car lstc) "_W" 0 0)
      (foreach pt (cdr lstc)(vl-cmdf pt))(vl-cmdf "")))
     (if en1 (redraw en1 4))(if en2 (redraw en2 4))
     (vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))  
     (princ)
     )
  (princ "\nНаберите в командной строке MPL")

1. В качестве границ допускается выбирать все POLYLINE, SPLINE, ARC, LINE
2. UCS не обрабатывается
3. Пересечения кривых не анализируются
4. Количество опорных точек - на сколько частей разбивается кривая для получения средней линии

[bimari]

ОГРОМНОЕ ЧЕЛОВЕЧЕСКОЕ СПАСИБО!!!!!! ДЕЙСТВИТЕЛЬНО РАБОТАЕТ!!!!!! ЭТО ИМЕННО ТО, ЧТО МНЕ НАДО!!!!

[Лентяй]

Ну не могу я сидеть спокойно, когда VVA такие простыни катает ! Хоть уже и поздно, но все-таки держите прогу.

Код:

[Выделить все]

(defun C:MPL ( / adoc util crv1 crv2 crvs csp eps dL n prs pts npt npts)
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
	util (vla-get-utility adoc))  
  (vla-StartUndoMark adoc) 
  (setvar "CMDECHO" 0) 
  (mapcar '(lambda (x y) (vla-getEntity util x nil (strcat "\nВыберите " y " границу: "))) '(crv1 crv2) '("первую" "вторую"))
  (setq crvs (list crv1 crv2)
	csp (vla-ObjectIDToObject adoc (vla-get-OwnerID crv1)))
  (if (apply 'and (mapcar 'null crvs)) (alert "Недобор!!!") (progn
      (if (apply 'and (mapcar '(lambda (x) (wcmatch (vla-get-ObjectName x) "*Line,Arc")) crvs))
	(progn (setq eps (mapcar 'vlax-curve-getEndParam crvs))
	  (vla-InitializeUserInput util 6)
	  (setq dl (if (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
			(setq dl (vla-getInteger util "\nКоличество опорных точек <100>: "))))) 100 dl) n 0)
	  (while (< n dl)
	    (setq prs (mapcar '(lambda (x) (* (/ x dl) n)) eps)
		  pts (mapcar '(lambda (x y) (vlax-curve-getPointAtParam x y)) crvs prs)
		  npt (reverse (cdr (reverse (mapcar '(lambda (x y) (/ (+ x y) 2)) (car pts) (cadr pts)))))
		  npts (append npt npts)
		  n (1+ n)));while
	  (setq nts (vla-TranslateCoordinates util (vlax-3d-point '(0.0 0.0 0.0)) acUCS acOCS :vlax-false)
	  (vla-AddLightweightPolyline csp (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length npts)))) npts)
				 )));progn
	(alert "Не то выбрано")))));if
  (vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
  (princ)
);end
(princ "\nНаберите в командной строке MPL")

[PSW]

Попробуй вот это
Указываешь две полилинии и кол-во точек разбиения.
Вызов:
Command: PSW
;******************************************************************
; AutoCAD 2000-2007
; Автор : Пурошев Сергей
; Донецкий центр союза архитекторов Украины "Среда"
; E-mail psw@asc.inep.net
;******************************************************************

;************************************************************************
; Функция возвращает: Точку середины отрезка Т1 Т2
; Параметр - точки Т1 Т2
;************************************************************************
(defun SEREDINA (TE1 TE2 / AA)
(setq DX (/ (+ (car TE1) (car TE2)) 2.0))
(setq DY (/ (+ (cadr TE1) (cadr TE2)) 2.0))
(setq DZ 0.0)
(if (and (/= (caddr TE1) NIL) (/= (caddr TE2) NIL))
(progn
(setq DZ (/ (+ (caddr TE1) (caddr TE2)) 2.0))
)
)
(setq AA (list DX DY DZ))
) ;END DEFUN

;*****************************************************************
; ОСНОВНАЯ ПРОГРАММА
; ОСНОВНАЯ ПРОГРАММА
; ОСНОВНАЯ ПРОГРАММА
;****************************************************************
(defun C:PSW (/ DX ED EN I LABEL N OB OB1 SL SSS SSS1 T0 T00 T1 T11 T12 T21 T22)

(prompt "\nВыбери полилинию 1: ")
(setq ob (car (entsel)))
(prompt "\nВыбери полилинию 2: ")
(setq ob1 (car (entsel)))

(setq dx (GetInt "\nКоличество участков разбиения : "))
;****************************************
(setq en (entget Ob))
(setq sl (cdr (assoc 8 en)))
(setvar "CLAYER" sl)
;***************************************
(setq sss nil)
(setq sss (ssadd)) ; создать набор
(setq label (entlast)) ; поставить метку в DWG
;****************************************
(setvar "CECOLOR" "ByLayer")
;****************************************
(command "_divide" ob dx)
;**************************************
(while ; переписать в набор
(setq label (entnext label))
(setq sss (ssadd label sss))
)
;****************************************
;****************************************
;****************************************
;****************************************
(setq en (entget Ob1))
(setq sl (cdr (assoc 8 en)))
(setvar "CLAYER" sl)
;***************************************
(setq sss1 nil)
(setq sss1 (ssadd)) ; создать набор
(setq label (entlast)) ; поставить метку в DWG
;****************************************
(setvar "CECOLOR" "ByLayer")
;****************************************
(command "_divide" ob1 dx)
;**************************************
(while ; переписать в набор
(setq label (entnext label))
(setq sss1 (ssadd label sss1))
)
;****************************************
;****************************************
(setq n (sslength sss))
(setq i (- n 1))
(setq i 0)
(setq en (ssname sss i))
(setq ed (entget en))
(setq t11 (cdr (assoc 10 ed)))

(setq en (ssname sss1 i))
(setq ed (entget en))
(setq t12 (cdr (assoc 10 ed)))
(setq T0 (seredina T11 T12))
(command "PLINE" T0)
(setq i 1)
;****************************************
(repeat (- n 1)
(setq en (ssname sss i))
(setq ed (entget en))
(setq t11 (cdr (assoc 10 ed)))

(setq en (ssname sss1 i))
(setq ed (entget en))
(setq t12 (cdr (assoc 10 ed)))
(setq T0 (seredina T11 T12))
(command t0 )


(setq t00 t1)
(setq i (+ i 1))
)
;****************************************
(command "")
;(command "LINE" t11 t1 "")
;***************************************
;(entdel ob)
(command "ERase" sss "")
(command "ERase" sss1 "")
;***************************************
(SetVar "FILEDIA" 1) (princ)
)

[VVA]

>Лентяй Это не простыни, а муки творчества
Вот причесанный вариант

Код:

[Выделить все]

;Middle PolyLine (MPL)
(defun C:MPL ( / adoc *error* crvs eps dL pts pt1 pt2 ptc n osm)
(defun *error* (msg)(vla-Regen adoc acActiveViewport)(vla-EndUndoMark adoc)
(setvar "OSMODE" osm))
(vl-load-com)(setq osm (getvar "OSMODE"))
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(vla-StartUndoMark adoc)(setvar "CMDECHO" 0)
(setq crvs (mapcar '(lambda (y / en)(setq en(car(entsel (strcat "\nВыберите " y " границу: "))))
(if en (redraw en 3)) en) '("первую" "вторую")))
(if (vl-some 'null crvs)(alert "Недобор!!!")
(progn (mapcar '(lambda(x)(redraw x 4)) crvs)
  (setq crvs (mapcar 'vlax-ename->vla-object crvs))
  (if (apply 'and (mapcar '(lambda (x) (wcmatch (strcase(vla-get-ObjectName x)) "*LINE,ARC")) crvs))
  (progn
    (setq eps (mapcar '(lambda (x)(- (vlax-curve-getEndParam x)(vlax-curve-getStartParam x))) crvs))
    (initget 6)(setq dL (if (setq dL (getint "\nКоличество опорных точек <100>: ")) dL 100))
    (setq pts (mapcar '(lambda (dp crv / sps pr)(setq n 0)(while (< n dl)
       (setq pr (* (/ dp dl) n) pt (vlax-curve-getPointAtParam crv pr)
       sps (append sps (list pt)) n (1+ n))) sps) eps crvs))
    (setq pts (mapcar '(lambda (pt pr crv)(append pt (list(vlax-curve-getPointAtParam crv pr)))) pts eps crvs))
    (setq pts (mapcar '(lambda (crv pt )(vl-sort pt '(lambda (t1 t2)
      (< (vlax-curve-getDistAtParam crv (vlax-curve-getParamAtPoint crv t1))
         (vlax-curve-getDistAtParam crv (vlax-curve-getParamAtPoint crv t2))))))
    crvs pts))(setq pts (mapcar '(lambda(x)(mapcar '(lambda(y)(trans y 0 1)) x)) pts))
(setq pt1 (car pts) pt2 (cadr pts))
(if (> (+ (distance (car pt1)(car pt2))(distance (last pt1)(last pt2)))
       (+ (distance (car pt1)(last pt2))(distance (last pt1)(car pt2))))
(setq pt2 (reverse pt2)))
(setq ptc (mapcar '(lambda(t1 t2)(polar t1 (angle t1 t2)(* 0.5 (distance t1 t2)))) pt1 pt2))
(setvar "OSMODE" 0)(vl-cmdf "_.PLINE" (car ptc) "_W" 0 0)
(foreach pt (cdr ptc)(vl-cmdf pt))(vl-cmdf "")))));_if apply
(setvar "OSMODE" osm)(vla-EndUndoMark adoc)(princ));_defun
(princ "\nНаберите в командной строке MPL")

1. В качестве границ допускается выбирать все POLYLINE, SPLINE, ARC, LINE
2. UCS обрабатывается !!
3. Пересечения кривых не анализируются
4. Количество опорных точек - на сколько частей разбивается кривая для получения средней линии

===== Добавлено =======
Совсем забыл про OSMODE. Теперь вспомнил

[Zouss]

ув. парикмахеры, а системные переменные почему не восстанавливаем? move ton, однако %)

[Kirill_Ja]

Похоже, с 6 года что-то изменилось.
Строит некорректно (средняя линия пересекает линии между которыми она должна быть построена)
AutoCad Civil 3D 2013

[Кулик Алексей aka kpblc]

Kirill_Ja, ищи BGTOOLS, там, кажется, было построение средней линии.

[Kirill_Ja]

Если этот BGTOOLS http://forum.dwg.ru/showthread.php?t=5940&page=6
то, похоже, что нету.

[progettista]

в PLTOOLS есть pltools

[Kirill_Ja]

В PLTOOLS включена функция, описанная выше в этой теме. По крайней мере, дает те же результаты(

[kp+]

средняя линия - это из PLTOOLS

[progettista]

Надо все линии в ноль по Z сделать. Например есть superflatten

Код:

[Выделить все]

 ;; by Joe Burke

;; Please send bug reports to me directly at lowercase@hawaii.rr.com 
;; or post to the SuperFlatten topic at theswamp under "Show your stuff".

;; General notes:

;; Use this program with CAUTION! Yes, it's DANGEROUS!
;; Recommended: make a copy of the original file and run it on
;; the copy. Xref the original to the copy to compare the two.

;; Disclaimer: if the program wrecks your drawing, it ain't my fault.

;; The program is intended to be used with "vanilla" ACAD versions
;; 2000 and later. It has not been tested within vertical applications.
;; Testing with versions prior to 2006 is very limited at this point.
;; It has been tested with 2006 and 2008.

;; The program flattens objects to the WCS plane.
;; It may be run from any view. For instance an isometric view
;; may be useful so you can see what it's doing. Suggested method,
;; choose Top view then choose an isometric view like SouthWest.
;; This is still considered WCS, so the program will not switch 
;; views while the selection set is processed. The selection set
;; is processed before blocks are processed.

;; Some objects may be erased. For instance, a line which when
;; flattened has a length close or equal to zero.

;; Some objects may change type. For instance, an arc which
;; is parallel to Front view is converted to a line. A circle
;; or arc which is not parallel to WCS is converted to an an ellipse.
;; An ellipse with an odd normal is converted to a polyline.

;; Locked layers are temporarily unlocked.

;; A block reference (insert) with an odd normal is exploded and  
;; the resulting objects are flattened. Including any nested blocks.
;; A count of exploded references, if any, is provided at the command line.
;; Attributes in exploded blocks are converted to text.

;; Objects inside block definitions are flattened as needed.
;; A side effect of this is unexpected results may occur when the
;; entire drawing is not flattened. In that case, exploding selected 
;; blocks before running the routine may be helpful.

;; Note, some block references simply cannot be exploded. 
;; AutoCAD may create such blocks while exploding NUS (non uniformly scaled) 
;; nested blocks. These blocks are anonymous and have a name like this *E<number>.
;; I think these are rare so there's no attempt to deal with them.
;; The report at the end will indicate a block reference could not
;; be flattened and how many.

;; -----------------------------------
;; Program options at the command line:
;; > SuperFlatten options [Rename blocks/Explodable blocks/Overkill/Proxies] < >:

;; All options are offered when using 2006 or later and 
;; Express Tools is loaded. Fewer options are offered when using
;; 2005 or ealier and depending on whether ET is loaded or not.

;; The Rename blocks option is always available.
;; > SuperFlatten options [Rename blocks/Explodable blocks/Overkill/Proxies] < >: r
;; > Block name options: [Prefix/Suffix] <S>: p
;; > Block name prefix: flat-
;; Example: there's a block named "BlockA" which contains objects 
;; which need to be flattened. If Rename blocks is chosen, the block
;; name is changed to "flat-BlockA". Note, a block is not renamed
;; if it does not contain object which need to be flattened.

;; If the option isn't used, block definitions are flattened and not renamed.

;; Any renamed blocks are listed at the command line. 
;; Thanks to Steve Doman for his input here.

;; The Proxies option is always available.
;; > SuperFlatten options [Rename blocks/Explodable blocks/Overkill/Proxies] < >: p
;; > Flatten proxy objects? [Yes/No] <N>:
;; If Yes is chosen, proxy objects are flattened.
;; There's a report at the command line regarding how many proxy objects
;; were selected at the first pass through options.

;; The Explodable blocks option is presented when using 2006 or later.
;; > SuperFlatten options [Rename blocks/Explodable blocks/Overkill/Proxies] < >: e
;; > Temporarily set all blocks explodable? [Yes/No] <N>:

;; 2006 introduced the idea a block definition may be set so any reference 
;; to it cannot be exploded. If Yes is chosen, all block defintions are 
;; temporarly set to allow explode. They are reset as needed after the 
;; program ends.

;; The Overkill option is presented when Express Tools is loaded.
;; > SuperFlatten options [Rename blocks/Explodable blocks/Overkill/Proxies] < >: o
;; > Run Overkill after flattening? [Yes/No] <N>:

;; If Yes is chosen Overkill is called. The option is particularly useful 
;; when 3D solids are exploded in order to flatten. Many duplicate objects 
;; may be deleted.
;; -----------------------------------

;; Programming notes:

;; Block definitions are flattened by copying the objects contained
;; in a definition to a temporary layout. This is done to allow use
;; of (command "explode") for objects which cannot be exploded using
;; the ActiveX Explode method. Thanks to Doug Broad for that idea.
;; The original objects in a definition are deleted and the flattened
;; objects are copied back to the definition.

;; When Overkill is called, the function used is (acet-ss-remove-dups...)
;; My testing indicates the function as called is not sensitive to the
;; current Overkill settings. Example, if Ignore Layers is checked in 
;; the Overkill dialog, duplicate objects on different layers are not deleted.
;; IOW, it seems safe in terms of doing the minimum comparison of objects
;; considered equal.

;; Object types supported: AcDbLine AcDbArc AcDbCircle AcDbEllipse
;; AcDbPolyline AcDb2dPolyline AcDb3dPolyline AcDbFace AcDbSpline
;; AcDbPoint AcDbBlockReference AcDbText AcDbMText AcDbAttribute
;; AcDbAttributeDefinition AcDbTable AcDbHatch AcDbSolid AcDbTrace
;; AcDbLeader Dimensions AcDbRay AcDbXline AcDbMline AcDbWipeout
;; AcDbRasterImage AcDbRegion AcDbShape AcDbPolyFaceMesh AcDbPolygonMesh 
;; AcDbMInsertBlock AcDbFcf (tolerance obj) AcDbHelix AcDbZombieEntity
;; AcDb3dSolid and AcDbBody (types which can be exploded) AcDbSurface.

;; "AcDbPlaneSurface" "AcDbFace" (cannot explode already above)
;; "AcDbCamera" "AcDbLight"

;; Normals when objects are drawn in these planes.
;; Top: (0.0 0.0 1.0)
;; Bottom: (0.0 0.0 -1.0)
;; Front: (0.0 -1.0 0.0)
;; Back: (0.0 1.0 0.0)
;; Left (-1.0 0.0 0.0)
;; Right (1.0 0.0 0.0)

;; ----------------------------------------------------------------
;; Version history:

;; Version SuperFlatten 1.0 - 7/23/2007.
;; Changed the program name from ZZero to SuperFlatten. Thanks to 
;; Steve Doman for clearing my head on this issue.  :-)
;; Internalized toolbox functions.

;; Version SuperFlatten 1.0a - 7/24/2007.
;; Added support for AeccDbContour, AeccDbPoint and AcDbZombieEntity
;; object types. The zombie type is a proxy object. Some proxy objects
;; can be exploded using command explode, though I'm not sure which ones.
;; AeccDbContour and AeccDbPoint are two which can. Currently under testing.

;; Version SuperFlatten 1.0b - 7/25/2007.
;; Refined the changes/additions in version 1.0a. Limited testing indicates
;; the program should be able to flatten drawings created in Architectural
;; Desktop. The results will differ depending on what version of ACAD is in
;; use and/or whether an ADT object enabler is installed. 
;; If Properties says an ADT object is a proxy (zombie), the proxy is  
;; exploded and the resulting objects are flattened. The likely result will 
;; be a large file with many duplicate objects. Consider using the Overkill 
;; option, though it may take a long time to finish.
;; If Properties says an ADT object is something like an AEC_WALL (AecDbWall)
;; then the result of exploding the object is an anonymous block. The objects
;; within those block definitions are subsequently flattened. So the result 
;; is likely many anonymous blocks, without a huge increase in the number
;; of primary objects contained in the drawing. The Overkill option won't be
;; much help in this case.

;; Whether the program should deal with ADT proxy objects is open to question.
;; 2008 has the -ExportToAutoCAD command which converts ADT objects to standard
;; ACAD objects. But it does not flatten them as far as I've seen. So if that's
;; what you want, you would have to run SuperFlatten anyway, after 
;; -ExportToAutoCAD. Note, versions prior to 2008, 2006 for instance, also
;; support the -ExportToAutoCAD command when the 2006 ADT object enabler 
;; is installed.

;; IOW, you can flatten an ADT drawing using SuperFlatten alone, without 
;; the intermediate step of using ExportToAutoCAD. Hopefully this allows 
;; someone using ACAD 2002 to flatten an ADT drawing. Not tested under 2002, 
;; but it works as tested under 2006.

;; Other changes:

;; Bug fix at sub-function TwoPointObj.
;; Revised the version checking in program options.

;; Version SuperFlatten 1.0c - 7/26/2007.
;; Revised the FlatEllipse sub-function so the program works with the Autodesk 
;; sample file named 3D House.

;; Version SuperFlatten 1.0d - 7/27/2007.
;; Revised the FlatEllipse, FlatCircle and FlatArc sub-functions so the program 
;; works with the Autodesk sample file named Welding Fixture Model.

;; Version SuperFlatten 1.0e - 7/28/2007.
;; Removed the reverse function at the end of sub-function SSVLAList. 
;; Speed testing with the Hotel Model example file indicates the program is 
;; consistently about 14% faster when the selection set list is not reversed. 
;; 42 seconds vs 49. I'm not sure why. Plus the visual integrity of what 
;; ends up on top of what when objects overlap is more faithful to the 
;; pre-flattened drawing.

;; Version SuperFlatten 1.0f - 8/7/2007.
;; Object selection now occurs before program options.
;; The current options are displayed while the user sets options.
;; The variables *overkillans* (for run Overkill) and 
;; *expans* (allow unexplodable blocks to be exploded)
;; are global now so the Yes/No settings are recalled when the 
;; program is run more than once. The Prefix/Suffix string for
;; the Rename blocks option is not global by design.

;; Version SuperFlatten 1.0g - 8/9/2007.
;; Revised the FlatDimension sub-routine to check for dimension types
;; which have point data associated. For instance, an angular dimension
;; has an ExtLine1StartPoint property.
;; Added sub-function ValidItem. Used to check whether the name of a
;; block may already exist when attempting to rename a block.
;; Added the notrenamedlst variable. It's a list of block names
;; which could not be renamed due to an existing block name conflict.
;; Added a report at the end which lists such block names.
;; Restored reverse list call at the SSVLAList function.
;; Revised the FlatHatch function. Added error checking at the Evaluate
;; call. Also moved it into the "and" condition.

;; Version SuperFlatten 1.0h - 8/10/2007.
;; Revised the FlatHatch function. Added zoom to selection set of
;; recreated boundary objects.

;; Version SuperFlatten 1.1 - 8/16/2007.
;; Commented out the timer functions and calls to those functions.

;; Version SuperFlatten 1.1a - 8/20/2007.
;; Bug fix at FlatSpline sub-function.
;; Revised Text and MText handling in terms of the angle of the object
;; when it has an odd normal. An old set of issues finally solved.

;; Version SuperFlatten 1.1a beta - 8/24/2007.
;; Revised AEC object handling to use Matt's suggestion. All AEC 
;; objects are processed using this (wcmatch objname "Aec*,AEC*").
;; Revised the CommandExplode function so when an AEC object
;; is exploded, the program does not assume only one anonymous
;; block was created as in version 1.1a.
;; Added a check before blocks are processed to ensure all the block 
;; names in blknamelst are still contained in the blocks collection.
;; Remove any which are not to avoid key not found error.

;; Version SuperFlatten 1.2 - 8/27/2007.
;; Removed support for AEC objects because I don't have the vertical
;; apps to test these objects and the -ExportToAutoCAD command does a 
;; better job flattening them anyway. Note, -ExportToAutoCAD does not
;; always flatten the objects it deals with even when the view is Top WCS.
;; SF will flatten any such remaining objects.
;; Added an interface option for proxy (zombie) objects. See program
;; options above.
;; Added SpinBar call while the selection set is evaluated for block 
;; names and proxy objects.
;; Bug fix at the CommandExplode function. Test for a possible empty
;; object to avoid a false report regarding objects not flattened.
;; A proxy object may be empty, contain no objects.
;; Aside regarding proxy objects. While researching the bug I found
;; this comment by Owen Wengerd in a thread dated 2003.
;; "If the proxy objects are marked as unerasable, then you'll need to use a 
;; third party tool such as my SuperPurge utility." I find no other
;; references on the web to an unerasable proxy. This may point to
;; another possible bug?

;; Version SuperFlatten 1.2a - 9/9/2007.
;; Added FlatLeader sub-function. It deals with twitchy leaders which have 
;; a hookline per James Allen's example file. Move the leader rather than
;; change its coordinates if that's sufficient to flatten it.
;; Otherwise pass the leader to the FlatCoordinates sub-function.
;; In that case if it has a hookline the leader will likely change shape.
;; No solution found for that problem.
;; Split former FlatSolidOrTrace function into two separate functions.
;; Added (setvar "pickstyle" 0) so groups will not interfere with 
;; command explode. Variable reset in the error handler.
;; Revised FlatMInsert so one with an odd normal is "exploded" like other 
;; blocks. Thanks to Jason Piercey for his code example.
;; Light objects are deleted now. Camera objects are not. There's a
;; commented out condition within ProcessList which can be restored so
;; camera objects are deleted.
;; Revised the FlatHatch sub-function. If 2006 or later and a hatch object 
;; has an odd normal and the pattern name is AR-CONC, AR-SAND or SOLID, 
;; attempt to flatten by recreating the object. Otherwise explode and flatten 
;; the results. The idea is only random patterns should be recreated. 
;; Others should be exploded in order to maintain visual integrity.
;; Revised the TestZNormal function to handle planar objects like arcs, 
;; circles, polylines etc. Removed the TwoPointObj function.
;; Added support for helix objects. Convert to a flat spline.

;; Version SuperFlatten 1.2b - 9/22/2007.
;; Added FlatMLeader sub-function. Marginal support for multileader objects.
;; Added the GetHatchScale function within FlatHatch. It adjusts the
;; hatch scale of a recreated hatch if the source hatch was created with a 
;; modified version of acad.pat or acadiso.pat.
;; Thanks to James Allen for his input on this topic.
;; Thanks to Marco Alessi for internationalizing command functions.
;; Added the CheckBlock and DeleteBlockProxies functions to delete
;; proxy objects in blocks. Should be a very rare case since the block
;; command does not allow proxies to be included in a block definition.
;; Revised the FlatDimension sub-function.

;; Version SuperFlatten 1.2c - 1/10/2008.
;; Revised the block reference condition in sub-function ProcessList.
;; Added some layer checking to the situation where a block which only
;; contains other blocks is exploded. Not uploaded yet to theswamp.

;; Version SuperFlatten 1.2d - 1/2/2010.
;; Revised the FlatDimension sub-function to move points in a dimension
;; to Z zero. The method used in version 1.2c proved unreliable.

;; Version SuperFlatten 1.2e - 1/12/2010.
;; Revised the FlatDimension sub-function to change associative dimensions
;; to non-associative. Added support for multiline attributes and preservation
;; of symbols in multiline attributes and fields in both attribute types
;; when a block is exploded in order to flatten. Revised the CommandExplode
;; function to preserve symbols and fields in expoded dimensions.
;; Revised the CommandExplode and FlatMLeader functions to allow flattening 
;; of mleader objects. As noted within the FlatMLeader function, the 
;; misbehaving solid object arrow heads are deleted. I will check versions
;; later than 2008 to see if the explode mleader bug has been fixed by
;; Autodesk.

;; Version SuperFlatten 2.0a beta - 2/10/2011.
;; WMFOutIn function added which handles 3DSolid and some other 3D object
;; types using WMF ActiveX methods. Requires ACAD 2005 or later.
;; Earlier ACAD versions use the CommandExplode function as previous versions
;; of SuperFlatten did.
;; Consider using the overkill option when 3DSolid objects are flattened
;; since the WMF process may create duplicate objects on top of each other.
;; Camera and Light object types are deleted.
;; Added support for AcDbPlaneSurface objects.
;; Thanks to Peter B (screen name peterba) at TheSwamp for suggesting the 
;; use of WMF.

;; Version SuperFlatten 2.0b beta - 3/6/2011.
;; Fixed internationalization at five locations.
;; Example: (ssget "p") changed to (ssget "_p").

;; Version SuperFlatten 2.0c - 12/6/2011.
;; Revised the FlatArc sub-function to fix a problem reported by
;; Peter B where a flattened arc could change direction. For example,
;; an arc which had a 30 degree included angle changed to an arc with a
;; 330 degree included angle. Thanks to Peter for his report.

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

;; The shortcut is SF

(vl-load-com)

(defun c:SuperFlatten ( / *error* acad 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 validlst testlst obj objname proxylst 
                      proxyreport pksty slu proxyerror version elevms elevps 
                      sscol WNFflag UCSflag

                      TestNormal TestZNormal ZZeroPoint ZZeroCoord 
                      ProcessList SF:MakeLWPolyline GetBlock PointList 
                      RotateToNormal ApplyProps FlatMText FlatText 
                      FlatPointObj FlatLine FlatACE FlatCircle FlatArc 
                      FlatPline FlatSpline FlatDimension FlatXref FlatShape 
                      FlatHatch FlatSolid FlatTrace FlatRayOrXline 
                      FlatWipeoutOrRaster FlatMline FlatTable FlatTolerance 
                      FlatRegion FlatPolyFaceMesh FlatCoordinates FlatMInsert 
                      AttributesToText ExpBlockMethod CommandExplode 
                      ModBlockScale SF:TraceObject CheckRename PrefixSuffix 
                      Spinbar LstACADPAT UnlockLayers RelockLayers 
                      SSVLAList SSAfterEnt Round GetNestedNames ValidItem 
                      FlatMLeader CheckBlock DeleteBlockProxies SF:GetFields 
                      SF:SymbolString WMFOutIn)

                      ;; Global variables: *expans* *overkillans* *proxyans*

  (defun *error* (msg / i)
    (cond
      ((not msg))
      ((wcmatch (strcase msg) "*QUIT*,*CANCEL*")
        (if blknamelst
          (princ "\n ** CANCELLED - UNDO RECOMMENED ** \n")
        )
      )
      (T (princ (strcat "\nError: " msg)))
    )
    (setvar "cmdecho" 1)
    ;; Restore any unexplodable blocks.
    (foreach x expblklst (vlax-put x 'Explodable acFalse))
    (RelockLayers locklst)
    (if hpa (setvar "hpassoc" hpa))
    (if slu (setvar "showlayerusage" slu))
    (if elevms (vlax-put doc 'ElevationModelSpace elevms))
    (if elevps (vlax-put doc 'ElevationPaperSpace elevps))
    (if expm (setvar "explmode" expm))
    (if pksty (setvar "pickstyle" pksty))
    (if 
      (and
        templayout
        (not (vlax-erased-p templayout))
      )        
      (vla-delete templayout)
    )
    ;; Moved down from above 2/4/2011.
    (if ucsfol (setvar "ucsfollow" ucsfol))
    (if (= 0 (vlax-get doc 'ActiveSpace))
      (vlax-put doc 'ActiveSpace 1)
    )
    (vla-EndUndoMark doc)
    (princ)
  ) ;end error
  
  ;;;;;;; START SuperFlatten SUB-FUNCTIONS ;;;;;;;

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

  ;; Added 1/27/2011. Revised 2/23/2011.
  ;; Argument: vla-object.
  ;; The zoom to object command was added in 2005 which is version 16.1.
  ;; The sub-function calls that zooom command.
  (defun WMFOutIn (obj / doc space tmp tmpwmf blkref space lay clr lt  
                         explst pts newobj UpperLeft ActiveXSS 2DPoints)
    (setq doc (vla-get-activedocument (vlax-get-acad-object))
          space (vlax-get (vla-get-ActiveLayout doc) 'Block)
    )

    ;; Returns the coordinates of the upper left corner of the current
    ;; view as a 3D point. Revised 2/24/2011.
    (defun UpperLeft ( / scrn ang vsiz vcen pt d)
      (setq scrn (getvar "screensize")
            ang (angle (list (car scrn) 0.0 0.0) (list 0.0 (cadr scrn) 0.0))
            vsiz (/ (getvar "viewsize") 2.0)
            vcen (getvar "viewctr")
            ;; View top middle point.
            pt (polar vcen (/ pi 2.0) vsiz)
            d (distance pt vcen)
            ;; Do the triangle math. Get the distance from view center 
            ;; to upper left corner.
            d (/ d (sin (- pi ang)))
      )
      ;; Point at upper left of screen.
      (polar vcen ang d)
    ) ; end UpperLeft

    ;; Argument: vla-object
    ;; Returns: an ActiveX selection set object.
    (defun ActiveXSS (obj / ssobj i)
      (if (setq i (ValidItem sscol "tempss"))
        (vla-delete i)
      )
      (setq ssobj (vlax-invoke sscol 'Add "tempss"))
      (vlax-invoke ssobj 'AddItems (list obj))
      (vla-item sscol "tempss")
    ) ; end ActiveXSS

    ;; Remove every third element from flat list of 3D points.
    (defun 2DPoints (coord / lst)
      (repeat (/ (length coord) 3)
        (setq lst (cons (car coord) lst)
              lst (cons (cadr coord) lst)
              coord (cdddr coord)
        )
      )
      (reverse lst)
    ) ; end 2DPoints

    ;; Added test for model space 2/9/2011. Aviods a non-fatal error message
    ;; at the command line regarding no active model space viewport when
    ;; flattening a block definition in paper space.
    (if (= 1 (vlax-get doc 'ActiveSpace))
      (command "._view" "_orthographic" "_top")
    )
    (if
      (and
        ;; get a temp filename
        (setq tmp (vl-filename-mktemp nil nil nil))
        (setq tmpwmf (strcat tmp ".WMF"))
      )
      (progn
        ;; WMFout
        (setq lay (vlax-get obj 'Layer)
              clr (vlax-get obj 'Color)
              lt (vlax-get obj 'Linetype)
        )
        ;; Requires 2005 or later for the zoom object command.
        (command "._zoom" "_object" (vlax-vla-object->ename obj) "")
        (vla-update obj)
        (vlax-invoke doc 'Export tmp "WMF" (ActiveXSS obj))
        ;; WMFin
        (if (not (vl-catch-all-error-p
          (setq blkref (vl-catch-all-apply 'vlax-invoke 
            (list doc 'Import tmpwmf (UpperLeft) 2.0)))))
          (progn
            (princ "Flattening solid objects, please do not Cancel... ")
            (print)            
            (setq name (vlax-get blkref 'Name))
            (setq explst (vlax-invoke blkref 'Explode))
            (vla-delete blkref)
            (command "._purge" "_blocks" name "_no")
            (foreach x explst 
              ;; Convert heavy plines from WMFin to lines or lightweight plines.
              (setq pts (vlax-get x 'Coordinates))
              (vla-delete x)
              (if
                (or
                  ;; Convert two point object to a line.
                  (= 6 (length pts))
                  ;; Given a three point object and the first and third points
                  ;; are the same, convert to a line.
                  (and
                    (= 9 (length pts))
                    (equal (car pts) (nth 6 pts) 1e-8)
                    (equal (cadr pts) (nth 7 pts) 1e-8)
                  )
                )
                (setq newobj (vlax-invoke space 'AddLine
                  (list (car pts) (cadr pts) 0.0)
                  (list (nth 3 pts) (nth 4 pts) 0.0)
                ))
                ;; Else convert to lwpline.
                (setq newobj (vlax-invoke space 'AddLightWeightPolyline (2DPoints pts)))
              )             
              (vlax-put newobj 'Layer lay)
              (vlax-put newobj 'Color clr)
              (vlax-put newobj 'Linetype lt)
            )
            (vla-delete obj)
            ;; There's a slight speed penalty for doing restore view here within 
            ;; the function. The reason it's here, rather than in the error function,
            ;; is when placed in the error function and the user cancels the routine,
            ;; an error would occur in the error function. I'm not sure why.
            (if 
              (and
                (= 1 (vlax-get doc 'ActiveSpace)) ;; model space
                (tblobjname "view" "SFview")
              )
              (command "._view" "_restore" "SFview")
            )
          )
          ;; else
          (CommandExplode obj)
        )
        (vl-file-delete tmpwmf)
      )
    )
  )  ; end WMFOutIn

  ;; Argument: an ename or vla-object.
  ;; Return T if normal is (0.0 0.0 1.0) or (0.0 0.0 -1.0) within fuzz.
  (defun TestNormal (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

  ;; Revised 9/8/2007.
  ;; Example: a circle with a normal like this (0.819152 -0.573576 0.0)
  ;; looks like a line in top view. Convert to a like using the 
  ;; bounding box points.
  (defun TestZNormal (obj / n mn mx newobj)
    (if (= (type obj) 'VLA-object)
      (setq n (vlax-get obj 'Normal))
      (setq n (cdr (assoc 210 (entget obj)))
            obj (vlax-ename->vla-object obj)
      )
    )
    (if (equal 0.0 (caddr n) 1e-8)
      (progn
        (vla-GetBoundingBox obj 'mn 'mx)
        (setq mn (ZZeroPoint (vlax-safearray->list mn))
              mx (ZZeroPoint (vlax-safearray->list mx))
        )
        (cond
          ((or             
             ;; Back (0.0 1.0 0.0) or Right (1.0 0.0 0.0).
             (equal 1.0 (apply '+ n) 1e-8)
             ;; Includes Left (-1.0 0.0 0.0).
             (and
               (minusp (car n))
               (not (minusp (cadr n)))
             )
             ;; Includes Front (0.0 -1.0 0.0).
             (and
               (not (minusp (car n)))
               (minusp (cadr n))
             )
            )
            (setq newobj (vlax-invoke (GetBlock) 'AddLine mn mx))
          )
          ;; Or use the other two corners of the bounding box.
          (T
            (setq newobj 
              (vlax-invoke (GetBlock) 'AddLine 
                (list (car mx) (cadr mn) 0.0)
                (list (car mn) (cadr mx) 0.0)
              )
            )
          )
        )
        (ApplyProps obj newobj)
        ;; Return T to condition calls.
        (setq renameflag T)
      ) ;progn
    ) ;if
  ) ;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. Also set renameflag T.
  (defun ApplyProps (old new)
    (if 
      (and 
        old 
        new
        (not (vlax-erased-p old))
        (not (vlax-erased-p new))
      )
      (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

  ;; Revised 1/10/2010.
  ;; Convert a list of attribute reference objects to text objects.
  ;; Attributes may be either either text or multiline attribute.
  ;; Returns: a list of text and/or mtext vla-objects.
  ;; Note: the calling function must check the object passed
  ;; is not on a locked layer. Otherwise these functions will
  ;; cause "On locked layer" errors.
  ;; The function does not delete the object passed. The calling
  ;; function must to do that.
  (defun AttributesToText (attlst / n elst str obj res AlignMtext UCSAng)

    ;; Argument: text or attribute, including mutiline, vla-object.
    ;; Returns: the appropriate AttachmentPoint property for an mtext object.
    ;; Based on code by by Lee McDonnell.
    (defun AlignMtext (obj / align)
      (setq align (vlax-get obj 'Alignment))
      (cond 
        ((<= 0 align 2) (1+ align))
        ((<= 3 align 5) 1)
        (T (- align 5))
      )
    ) ;end

    ;; Mtext angle (code 50) is in terms of UCS.
    ;; Text rotation is expressed in WCS.
    ;; Convert angle from WCS to UCS by John Uhden.
    (defun UCSAng (ang)
      (angle
        (trans '(0 0 0) 0 1)
        (trans (polar '(0 0 0) ang 1) 0 1)
      )
    )
    (foreach attobj attlst 
      (setq n (vlax-get attobj 'Normal))
      (setq elst (entget (vlax-vla-object->ename attobj)))
      (setq str (SF:GetFields attobj))
      (if 
        (and
          (vlax-property-available-p attobj 'MTextAttribute)
          (= -1 (vlax-get attobj 'MTextAttribute))
        )
        ;; multiline attribute
        (progn
          (if
            (entmake
              (list
                '(0 . "MTEXT")
                '(100 . "AcDbEntity")
                '(100 . "AcDbMText")
                (cons 1 (vlax-get attobj 'TextString))
                ;(cons 1 str)
                (cons 7 (vlax-get attobj 'StyleName))
                (cons 8 (vlax-get attobj 'Layer))
                ;(cons 10 (vlax-get x 'InsertionPoint))
                (cons 10 (vlax-get attobj 'TextAlignmentPoint))
                ;; this is AttachmnetPoint property
                (cons 71 (AlignMtext attobj))
                (cons 40 (vlax-get attobj 'Height))
                (cons 50 (UCSAng (vlax-get attobj 'Rotation)))
                ;(cons 50 (vlax-get attobj 'Rotation))
                (cons 62 (vlax-get attobj 'Color))
                ;; Added in 2.3 12/10/2009 mtext width
                (cons 41 (vlax-get attobj 'MTextBoundaryWidth))
                ;(cons 210 (vlax-get attobj 'Normal))
                (assoc 410 elst)
              )
            ) ;make
            (progn
              (if (assoc 90 elst)
                (entmod 
                  (append 
                    (entget (entlast))
                    (vl-member-if '(lambda (x) (= 90 (car x))) elst)
                  )
                )
              )
              (setq obj (vlax-ename->vla-object (entlast)))
              (vlax-put obj 'Normal n)
              (setq res (cons (FlatMText obj) res))
            )
          )
        ) ; progn
        ;; standard text attribute
        (progn
          (if
            (entmake
              (list
                '(0 . "TEXT")
                (cons 1 (vlax-get attobj 'TextString))
                (cons 7 (vlax-get attobj 'StyleName))
                (cons 8 (vlax-get attobj 'Layer))
                (cons 10 (vlax-get attobj 'InsertionPoint))
                (cons 11 (vlax-get attobj 'TextAlignmentPoint))
                (cons 40 (vlax-get attobj 'Height))
                (cons 41 (vlax-get attobj 'ScaleFactor))
                (cons 50 (vlax-get attobj 'Rotation))
                (cons 51 (vlax-get attobj 'ObliqueAngle))
                (cons 62 (vlax-get attobj 'Color))
                ;; Added 10/29/2009
                ;(cons 210 (vlax-get attobj 'Normal))
                (cons 67 (cdr (assoc 67 elst)))
                (cons 71 (cdr (assoc 71 elst)))
                (cons 72 (cdr (assoc 72 elst)))
                ;; Revised 10/29/2009
                ;; Vertical text justification type
                ;; DXF code 74 in an attribute and
                ;; code 73 in a text object.
                ;(cons 73 (cdr (assoc 73 elst)))
                (cons 73 (cdr (assoc 74 elst)))
                (assoc 410 elst)
              )
            ) ; make
            (progn
              (setq obj (vlax-ename->vla-object (entlast)))
              (vlax-put obj 'Normal n)
              (if (= 0 (vlax-get obj 'Alignment))
                (vlax-put obj 'InsertionPoint 
                  (vlax-get attobj 'InsertionPoint)
                )
                (vlax-put obj 'TextAlignmentPoint 
                  (vlax-get attobj 'TextAlignmentPoint)
                )
              )
              (setq res (cons (FlatText obj) res))
            )
          )
        )
      )
      ;; Preserve symbols and fields.
      (if (and str obj) (vlax-put obj 'TextString str))
    ) ;foreach
    res
  ) ;end AttributesToText

  ;; Argument: ename or vla-object.
  ;; Object types: mtext, attribute, mleader or dimension.
  ;; Returns: a string with symbols intact.
  (defun SF:SymbolString (obj / e typ str name String blocks)
    ;; A multiline attributue may contain two 1 DXF codes and multiple
    ;; 3 DXF codes. In either case the first code 1 should be ingored
    ;; since it contains a string which is not displayed on screen.
    ;; Apparently this odd condition occurs when text is pasted on top
    ;; of existing text. The old text is stored in the first DXF code 1
    ;; and the text displayed on screen is stored in the second DXF code 1.
    (defun String (ename / str lst)
      (setq str "")
      (setq lst
        (vl-remove-if-not
          '(lambda (x) (or (= 3 (car x)) (= 1 (car x)))) (entget ename)
        )
      )
      (if (and (< 1 (length lst)) (= 1 (caar lst)))
        (setq lst (cdr lst))
      )
      (foreach x lst
        (setq str (strcat str (cdr x)))
      )
    ) ; end String

    (if (= (type obj) 'VLA-OBJECT)
      (setq e (vlax-vla-object->ename obj))
      (progn
        (setq e obj)
        (setq obj (vlax-ename->vla-object obj))
      )
    )
    (setq typ (vlax-get obj 'ObjectName))
    (cond
      ((or
         (eq typ "AcDbMText")
         (eq typ "AcDbAttribute")
        )
        (setq str (String e))
      )
      ((eq typ "AcDbMLeader")
        (setq str (cdr (assoc 304 (entget e))))
      )
      ((and
         (wcmatch typ "*Dimension*")
         (setq name (cdr (assoc 2 (entget e))))
         (wcmatch name "`*D*")
         (setq blocks 
           (vla-get-blocks
             (vla-get-activedocument
               (vlax-get-acad-object)
             )
           )
         )
       )
       (vlax-for x (vla-item blocks name)
         (if (eq "AcDbMText" (vlax-get x 'ObjectName))
           (progn
             (setq str (String (vlax-vla-object->ename x)))
             ;; Preserve symbols. This also updates the string returned
             ;; by the FieldCode method so it contains symbols.
             (vlax-put x 'TextString str)
             ;; Modified version of the standard SymbolString function
             ;; in order to preserve fields when a dimension is exploded
             ;; in order to flatten using the CommandExplode function.
             (setq str (vlax-invoke x 'FieldCode))
           )
         )
       )
     )
    )
    str
  ) ; end SF:SymbolString
  
  ;; Argument: source vla-object.
  ;; Returns: the same string as the FieldCode method, but works with 
  ;; fields in attributes and mleaders. FieldCode does not work with 
  ;; attributes or mleaders. Returns the source text string if no fields 
  ;; found in an attribute or mleader.
  (defun SF:GetFields (obj / srcdict srcdictename srcTEXTdict
                             srcfieldename targdict targdictename
                             fieldelst fielddict dicts actlay
                             tempobj lockflag res)
    
    (cond 
      ;; If the object does not have an extension dictionary or
      ;; the dictionary can be deleted because it is empty.
      ((or
         (= 0 (vlax-get obj 'HasExtensionDictionary))
         (not 
           (vl-catch-all-error-p
             (vl-catch-all-apply 'vlax-invoke
               (list (vlax-invoke obj 'GetExtensionDictionary) 'Delete)
             )
           )
         )
       )
       (setq res (SF:SymbolString obj))
      )
      ;; Source is an attribute or mleader and it contains one or more fields.
      ;; Create a new temporary mtext object. Apply source field dictionaries
      ;; to it. Then get the FieldCode from temp object and erase it.
      ;; For some reason mtext objects in tables do not behave well when
      ;; a dictionary is added. In fact, the updatefield command seems
      ;; to destroy such fields. This method avoids that problem.
      ((and
        (= -1 (vlax-get obj 'HasExtensionDictionary))
        (setq srcdict (vlax-invoke obj 'GetExtensionDictionary))
        (setq srcdictename (vlax-vla-object->ename srcdict))
        (setq srcTEXTdict (dictsearch srcdictename "ACAD_FIELD"))
        (setq srcfieldename (cdr (assoc 360 srcTEXTdict)))
       )
        ;; Check for active layer locked.
        (setq actlay (vlax-get doc 'ActiveLayer))
        (if (= -1 (vlax-get actlay 'Lock))
          (progn
            (vlax-put actlay 'Lock 0)
            (setq lockflag T)
          )
        )
        (setq tempobj (vlax-invoke (GetBlock) 'AddMText '(0.0 0.0 0.0) 0.0 "xx"))
        (setq targdict (vlax-invoke tempobj 'GetExtensionDictionary)
              targdictename (vlax-vla-object->ename targdict)
              fieldelst (entget srcfieldename)
              ;; not sure about the need for these
              fieldelst (vl-remove (assoc 5 fieldelst) fieldelst)
              fieldelst (vl-remove (assoc -1 fieldelst) fieldelst)
              fieldelst (vl-remove (assoc 102 fieldelst) fieldelst)
              fieldelst (vl-remove-if '(lambda (x) (= 330 (car x))) fieldelst)
        )
        (foreach x fieldelst
          (if (= 360 (car x))
            (progn
              (setq dicts (cons (cdr x) dicts))
            )
          )
        )
        ;; remove all 360s from fieldelst
        (setq fieldelst (vl-remove-if '(lambda (x) (= 360 (car x))) fieldelst))  
        (foreach x (reverse dicts)
          (setq fieldelst (append fieldelst (list (cons 360 (entmakex (entget x))))))
        )
        (setq fielddict
          (dictadd targdictename "ACAD_FIELD"
            (entmakex
              '(
                (0 . "DICTIONARY")
                (100 . "AcDbDictionary")
                (280 . 1)
                (281 . 1)
              )
            )
          )
        )
        (dictadd fielddict "TEXT" 
          (entmakex fieldelst)
        )
        (vlax-put tempobj 'TextString (SF:SymbolString tempobj))
        (setq res (vlax-invoke tempobj 'FieldCode))
        (vla-delete tempobj)
        (if lockflag (vlax-put actlay 'Lock -1))
      )
      ;; This really isn't needed given first conditon, but leave it.
      (T (setq res (SF:SymbolString obj)))
    )
    res
  ) ;end SF:GetFields

  ;; 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 TestNormal 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
      ((TestNormal 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)
         ;; Body objects cannot be expoded.
         ;; sphere explode twice = body
         ;; Removed 2/7/2011.
         ;; (eq "AcDbBody" objname)
         (eq "AcDbSurface" objname)
         (eq "AcDbHatch" objname)
         (eq "AcDbHelix" objname)
         (eq "AcDbZombieEntity" objname)
         (eq "AcDbPlaneSurface" objname)
        )
        (command "._explode" (vlax-vla-object->ename obj))
        (if (not (eq mark (entlast)))
          (setq exlst (SSVLAList (ssget "_p")))
        )
      )
      ;; Added 1/11/2010.
      ((wcmatch objname "*Dimension*")
        (setq str (SF:SymbolString obj))
        (command "._explode" (vlax-vla-object->ename obj))
        (if 
          (and 
            (not (eq mark (entlast)))
            (setq exlst (SSVLAList (ssget "_p")))
          )
          (foreach x exlst
            (if (eq "AcDbMText" (vlax-get x 'ObjectName))
              (vlax-put x 'TextString str)
            )
          )
        )
      )
      ;; Added 1/12/2010.
      ((eq "AcDbMLeader" objname)
        (command "._explode" (vlax-vla-object->ename obj))
        (if 
          (and 
            (not (eq mark (entlast)))
            (setq exlst (SSVLAList (ssget "_p")))
          )
          (foreach x exlst
            (if (eq "AcDbSolid" (vlax-get x 'ObjectName))
              (progn
                (vla-delete x)
                (setq exlst (vl-remove x exlst))
              )
            )
          )
        )
      )
      ((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")))
           )
           (progn
             (setq expblkcnt (1+ expblkcnt))
             (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 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    
    (cond
      (exlst
        (setq renameflag T)
        (ProcessList exlst)
      )
      ;; Testing for an empty object, such as a proxy.
      ;; If explode list is nil and the object was erased 
      ;; by command "explode" then it was an empty object.
      ;; So don't count it and don't add it to notflatlst.
      ;; Revised 8/27/2007.
      ((not (vlax-erased-p obj))
        (setq cnt (1+ cnt))
        (if (eq "AcDbZombieEntity" objname)
          (setq objname "DbProxy")
        )
        (if (not (vl-position objname notflatlst))
          (setq notflatlst (cons objname notflatlst))
        )
      )
    )
  ) ;end CommandExplode

  ;; Arguments: vla-object and a normal vector.
  ;; Called from 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 ;;;
  (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 ;;;
  
  ;; Based on code by Luis Esquivel.
  ;; Returns a list of pattern names from acad.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

  (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

  ;; Arguments: a blocks collection and a block name string.
  ;; Returns a list of block names nested in blkname if any.
  (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

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

  ;; Added 9/22/2007. Check a block definition for an object type.
  ;; Return T if object type found.
  ;; Example: (CheckBlock <blkname> "AcDbZombieEntity")
  (defun CheckBlock (blkname objtyp / flag)
    (setq objtyp (strcase objtyp))
    (vlax-for x (vla-item blocks blkname)
      (if (eq objtyp (strcase (vlax-get x 'ObjectName)))
        (setq flag T)
      )
    )
    flag
  )

  ;; Added 9/22/2007.
  ;; Works in conjunction with the CheckBlock function above.
  ;; Example:
  ;; (if (CheckBlock <blkname> "AcDbZombieEntity") 
  ;;   (DeleteBlockProxies <blkname>)
  ;; )
  ;; The main reason for this function is a proxy object cannot be deleted
  ;; from a block definition using (vla-delete <proxy obj>). An error occurs.
  ;; If the block contains only proxies, delete all references (inserts) 
  ;; including nested and delete the block definition.
  ;; If the block contains proxies and other object types, copy the objects 
  ;; to a temporary block. The proxies are ignored in the process. Then change
  ;; the name of all block references to the temporary block name. Delete the
  ;; original block definition, which deletes the proxy objects. 
  ;; Then change the name of the temporary block back to the original block name.
  (defun DeleteBlockProxies (blkname / blkdef tempname org copylst tempblk)
    (setq blkdef (vla-item blocks blkname))
    (vlax-for x blkdef (setq copylst (cons x copylst)))
    ;; This could be if...
    (cond 
      ;; Block only contains proxy objects.
      ((vl-every 
        '(lambda (x) 
           (eq "AcDbZombieEntity" (vlax-get x 'ObjectName))
         )
         copylst
        )
        (vlax-for x blocks
          (if (eq acFalse (vlax-get x 'IsXref))
            (vlax-for i x
              (if 
                (and 
                  (eq "AcDbBlockReference" (vlax-get i 'ObjectName))
                  (eq (strcase blkname) (strcase (vlax-get i 'Name)))
                )
                (vla-delete i)
              )
            )
          )
        )
        (if (vl-catch-all-error-p 
              (vl-catch-all-apply 'vla-delete (list blkdef))
            )
          (setq proxyerror T)
        )
      )
      ;; Block contains proxy objects and other object types.
      (T 
        (if
          (and
            (setq tempname (strcat "%%%" blkname))
            (not (ValidItem blocks tempname))
            (setq org (vlax-get blkdef 'Origin))
            (setq tempblk (vlax-invoke blocks 'Add org tempname))
          )
          (progn
            (vlax-invoke doc 'CopyObjects (reverse copylst) tempblk)
            ;; Should catch all nested blocks.
            (vlax-for x blocks
              (if (eq acFalse (vlax-get x 'IsXref))
                (vlax-for i x
                  (if 
                    (and 
                      (eq "AcDbBlockReference" (vlax-get i 'ObjectName))
                      (eq (strcase blkname) (strcase (vlax-get i 'Name)))
                    )
                    (vlax-put i 'Name tempname)
                  )
                )
              )
            )
            (if 
              (not 
                (vl-catch-all-error-p 
                  (vl-catch-all-apply 'vla-delete (list blkdef))
                )
              )
              (vlax-put tempblk 'Name blkname)
              (setq proxyerror T)
            )
          )
        ) ;if
      ) ;cond T
    ) ;cond
  ) ;end

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

  (defun FlatPointObj (obj / coord)
    (if (not (TestNormal 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 (TestNormal 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)
      (progn
        (vla-delete obj)
        (setq renameflag T)
      )
    )
  ) ;end

  ;; Revised 8/19/2007.
  (defun FlatMText (obj / ip apt ang ip1 ip2)
    (setq ip (vlax-get obj 'InsertionPoint))
    (CheckRename ip (ZZeroPoint ip))
    (if (TestNormal obj)
      (vlax-put obj 'InsertionPoint (ZZeroPoint ip))
      (progn
        (setq apt (vlax-get obj 'AttachmentPoint))
        (vlax-put obj 'AttachmentPoint 1)
        (setq ip1 (vlax-get obj 'InsertionPoint))
        (vlax-put obj 'AttachmentPoint 2)
        (setq ip2 (vlax-get obj 'InsertionPoint))
        (setq ang (angle ip1 ip2))
        (vlax-put obj 'Normal '(0.0 0.0 1.0))       
        (vlax-put obj 'Rotation ang)
        (vlax-put obj 'AttachmentPoint apt)
        (vlax-put obj 'InsertionPoint (ZZeroPoint ip))
        (setq renameflag T)
      )
    )
  ) ;end

  ;; Revised 8/19/2007.
  (defun FlatText (obj / pt ip ap algn ang)
    (CheckRename (vlax-get obj 'Thickness) 0)
    (vlax-put obj 'Thickness 0.0)
    (if (TestNormal 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))
        )
      )
      ;; If the text object has an odd normal.
      (progn
        (setq algn (vlax-get obj 'Alignment))
        (if (= 0 algn)
          (setq pt (vlax-get obj 'InsertionPoint))
          (setq pt (vlax-get obj 'TextAlignmentPoint))
        )
        ; Center alignment to get the angle.
        (vlax-put obj 'Alignment 1)
        (setq ang 
          (angle 
            (vlax-get obj 'InsertionPoint)
            (vlax-get obj 'TextAlignmentPoint)
          )
        )
        ; Restore previous alignment.
        (vlax-put obj 'Alignment algn)
        (vlax-put obj 'Normal '(0.0 0.0 1.0))
        (if (= 0 algn)
          (vlax-put obj 'InsertionPoint (ZZeroPoint pt))
          (vlax-put obj 'TextAlignmentPoint (ZZeroPoint pt))
        )
        (vlax-put obj 'Rotation ang)
        (setq renameflag T)
      ) ;progn odd normal
    ) ;if
    ;; Revised to return the result object 9/3/2007.
    obj
  ) ;end

  ;; Convert a circle with odd normal to an ellipse or otherwise.
  (defun FlatCircle (obj / ratio cen pt rad newobj)
    (cond
      ((TestNormal 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)
      )
      ((TestZNormal 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.
  ;; Revised 9/14/2007 to remove the "stpt" argument per
  ;; Marco's comment at theswamp.
  ;; "AddArc method has only 4 arguments (not 5)"
  ;; Revised 12/2/2011 per Peter's example drawing which demonstrated
  ;; how an arc might change direction in some odd cases. IOW, the
  ;; included angle might change from 30 degress to 330 degress.
  ;; The solution applied here is as follows. Check the TotalAngle of
  ;; the original arc and compare that to the TotalAngle of the new arc.
  ;; If the two are not equal, with some fuzz factor, reverse the 
  ;; StartAngle and EndAngle of the new arc object.
  ;; This fixes the problem in Peter's example file Arcs.dwg.
  ;; Note, I'm still not sure what the fuzz factor when comparing 
  ;; TotalAngles should be. The current fuzz is one degree, which is
  ;; 0.0174533 expressed in radians.
  ;; Notes to myself: I'm not convinced the above solution is the best
  ;; because the problem arc in Peter's example has a normal Z value of -1.
  ;; The source of the problem may be in that case the start and end
  ;; angles are simply reversed. 
  ;; Regardless, this version fixes the problem Peter reported, without
  ;; any apparent problems with other arcs.
  (defun FlatArc (obj / ratio cen pt stpt enpt pt rad newobj stparam 
                        enparam flag oldang newang oldstang oldenang)    
    ;; Added per comments above 12/2/2011.
    (setq oldang (vlax-get obj 'TotalAngle))    
    (cond
      ((TestNormal 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)
      )
      ((TestZNormal 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 (angle cen stpt) (angle cen enpt))
              )
              (progn
                ;; Added per comments above 12/2/2011.              
                (setq newang (vlax-get newobj 'TotalAngle)) 
                ;; Revised 12/2/2011.
                ;(if (not (equal oldang newang 0.0174533)) ; one degree
                ;; Revised 12/6/2011. This test checks for the actual problem,
                ;; the arc reversed direction, and therefore is considered 
                ;; somewhat safer than the above test, which only tested
                ;; whether the included angles of the old and new arcs are different.
                (if (equal newang (- (* pi 2) oldang) 0.0174533)
                  (progn
                    (setq oldstang (vlax-get newobj 'StartAngle))
                    (setq oldenang (vlax-get newobj 'EndAngle))
                    (vlax-put newobj 'EndAngle oldstang)
                    (vlax-put newobj 'StartAngle oldenang)
                  )
                )
                (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. An ellipse with an odd normal which fails the 
  ;; first two conditions is traced and converted to a pline.
  ;; This avoids potential "degenerate geometry" errors which are
  ;; not worth the risk invloved trying to preserve an ellipse.
  (defun FlatEllipse (obj / cen) 
    (cond
      ((TestNormal obj)
        (setq cen (vlax-get obj 'Center))
        (CheckRename cen (ZZeroPoint cen))
        (vlax-put obj 'Center (ZZeroPoint cen))
      )
      ((TestZNormal 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 
      ((TestNormal 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)
      )
      ((TestZNormal 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
 
  ;; Added function 9/11/2007. See version history 1.2b.
  (defun FlatMLeader (obj / mn mx n1 n2)
    (vla-GetBoundingBox obj 'mn 'mx)
    (setq n1 (caddr (vlax-safearray->list mn)))
    (setq n2 (caddr (vlax-safearray->list mx)))
    (cond
      ;; Doesn't need to be flattened.
      ((and 
         (equal 0 n1 1e-8)
         (equal 0 n2 1e-8)
       )
      )
      ;; Move if it's parallel to WCS.
      ((equal n1 n2 1e-8)
        (vlax-invoke obj 'Move (list 0.0 0.0 n1) '(0.0 0.0 0.0))
      )

      ;; This is what should happen, but there's a bug in 2008 with SP1
      ;; which causes the leader arrows to go flying off in space.
      ;; Revised 1/12/2010 to allow flattening of mleader objects.
      ;; Note, within the CommandExplode function the misbehaving solid 
      ;; object arrows are deleted. I think that's a better alternative
      ;; than not flattening mleaders as before.
      (T (CommandExplode obj))

      ;(T
      ;  (setq cnt (1+ cnt)
      ;        objname (vlax-get obj 'ObjectName)
      ;  )
      ;  (if (not (vl-position objname notflatlst))
      ;    (setq notflatlst (cons objname notflatlst))
      ;  )
      ;)
    )
  ) ;end FlatMLeader

  ;; ObjectName "AcDbMLeader"
  ;; Argument: an mleader vla-object. Trying to change the coordinates
  ;; does not work for some unknown reason.
  ;(defun FlatMLeader (obj / idx vert)
  ;  (setq idx 0)
  ;  (repeat (vlax-get obj 'LeaderCount)
  ;    (setq vert (vlax-invoke obj 'GetLeaderLineVertices idx))
  ;    (vlax-invoke obj 'SetLeaderLineVertices idx (ZZeroCoord vert))
  ;    (setq idx (1+ idx))
  ;  )
  ;)

  ;; Added function 8/29/2007. See version history 1.2a.
  (defun FlatLeader (obj / coord zlst n)
    (setq coord (vlax-get obj 'Coordinates))
    (repeat (/ (length coord) 3)
      (setq zlst (cons (caddr coord) zlst)
            coord (cdddr coord)
      )
    )
    (setq n (car zlst))
    (cond
      ((vl-every '(lambda (z) (equal 0.0 z 1e-6)) zlst))
      ((vl-every '(lambda (z) (equal n z 1e-6)) (cdr zlst))
        (vlax-invoke obj 'Move (list 0.0 0.0 n) '(0.0 0.0 0.0))
      )
      (T 
        (FlatCoordinates obj)
      )
    )
  ) ;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
  ;; coordinate lists are equal with fuzz, 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 testpts kts)
    (setq ctrlpts (vlax-get obj 'ControlPoints)
          testpts (ZZeroCoord ctrlpts)         
    )
    ;; Revised 8/17/2007 - bug fix.
    (if 
      (or 
        (eq acFalse (vlax-get obj 'IsPlanar))
        (not (equal ctrlpts testpts 1e-8))
      )
      (progn
        (setq kts (vlax-get obj 'Knots))
        (vlax-put obj 'ControlPoints testpts)
        (vlax-put obj 'Knots kts)
        (setq renameflag T)
      )
    )
  ) ;end

  ;|
  ;; Not currently used.
  ;; Argument: the ename of a dimension
  ;; Example given a rotated or aligned dimension
  ;; Returns: 1 if first dimension point is associative
  ;;          2 if second dimension point is associative
  ;;          3 if both points are associative
  ;;          nil if the dimension is not associative
  ;; Note: the value returned is the bitsum of the associativity flag.
  ;; 1 = First point reference
  ;; 2 = Second point reference
  ;; 4 = Third point reference
  ;; 8 = Fourth point reference
  (defun DimAssoc (dim / elst dict)
    (if (= (type dim) 'VLA-OBJECT)
      (setq dim (vlax-vla-object->ename dim))
    )
    (and 
      (setq elst (entget dim))
      (setq dict (cdr (assoc 360 elst))) ;dictionary ename
      (setq elst (entget dict))
      (setq elst (entget (cdr (assoc 360 elst)))) ;DIMASSOC elst
    )
    (cdr (assoc 90 elst))
  ) ;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 proplst e elst dxf13 dxf14)
    (if (TestNormal obj)
      (progn
        ;; Added 1/8/2010.
        (command "._dimdisassociate" (vlax-vla-object->ename obj) "")
        (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))
        )

        ;; Revised 9/22/2007. Condensed if statements.
        (setq proplst '("ExtLine1Point" "ExtLine2Point" "ExtLine1StartPoint" 
                        "ExtLine2StartPoint" "ExtLine1EndPoint" "ExtLine2EndPoint")
        )
        (foreach p proplst
          (if (vlax-property-available-p obj p)
            (progn
              (setq pt (vlax-get obj p))
              (CheckRename pt (ZZeroPoint pt))
              (vlax-put obj p (ZZeroPoint pt))
            )
          )
        )
        ;; Revised 1/2/2010. Ensure points in the dimension are at Z zero.
        (setq e (vlax-vla-object->ename obj))
        (setq elst (entget e))
        (if (setq dxf13 (assoc 13 elst))
          (progn
            (setq dxf13 (list 13 (cadr dxf13) (caddr dxf13) 0.0))
            (entmod (subst dxf13 (assoc 13 elst) elst))
            (setq elst (entget e))
          )
        )
        (if (setq dxf14 (assoc 14 elst))
          (progn
            (setq dxf14 (list 14 (cadr dxf14) (caddr dxf14) 0.0))
            (entmod (subst dxf14 (assoc 14 elst) elst))
          )
        )
      )
      (CommandExplode obj)
    )
  )

  ;; 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 (TestNormal 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 (TestNormal 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
  
  ;; Revised 9/4/2007. 
  ;; Flatten an minsert with an odd normal based on code by Jason Piercey.
  ;; Such objects are treated the same as a regular block with an odd normal.
  ;; Explode and flatten the results.
  (defun FlatMInsert (obj / ip attlst colcnt rowcnt colspc rowspc collst 
                            rowlst xfac yfac inspt rot bname blknum index 
                            inslst attlst txtlst vlaip newip nrml newblk 
                            newobj blklst)
    (if (TestNormal obj)
      (progn
        (setq ip (vlax-get obj 'InsertionPoint))
        (CheckRename ip (ZZeroPoint ip))
        (vlax-put obj 'InsertionPoint (ZZeroPoint ip))
        (setq attlst (vlax-invoke obj 'GetAttributes))
        (foreach x attlst
          (CheckRename (vlax-get x 'Thickness) 0)
          (vlax-put x 'Thickness 0.0)         
          ;; FlatText checks for rename.
          (FlatText x)
        )
      )
      (progn
        (setq colcnt (vlax-get obj 'Columns)
              rowcnt (vlax-get obj 'Rows)
        )
        (if (or (> colcnt 1) (> rowcnt 1))
          (progn 
            (setq bname (vlax-get obj 'Name) 
                  lay (vlax-get obj 'Layer)
                  xfac (vlax-get obj 'XScaleFactor) 
                  yfac (vlax-get obj 'YScaleFactor) 
                  rot (vlax-get obj 'Rotation) 
                  colspc (vlax-get obj 'ColumnSpacing) 
                  rowspc (vlax-get obj 'RowSpacing)
                  nrml (vlax-get obj 'Normal)
                  blknum (* rowcnt colcnt)
            )
            (if (setq attlst (vlax-invoke obj 'GetAttributes))
              (setq txtlst (AttributesToText attlst))
            )
            ;; The insertion point of an minsert returned by entget is not the 
            ;; same as what properties shows and what this (vlax-get obj 
            ;; 'InsertionPoint) returns when the object has an odd normal.
            ;; But this (inspt) is the point which works. Not sure why.
            (setq inspt (cdr (assoc 10 (entget (vlax-vla-object->ename obj))))
                  vlaip (ZZeroPoint (vlax-get obj 'InsertionPoint))
            )
            (setq index 1)
            (repeat (1- colcnt)
              (setq collst (cons (polar inspt rot (* index colspc)) collst))
              (setq index (1+ index)) 
            )
            (setq collst (cons inspt collst))
            (setq index 1)
            (foreach x collst 
              (progn 
                (repeat (1- rowcnt) 
                  (progn 
                    (setq rowlst (cons (polar x (+ rot (* pi 0.5)) (* index rowspc)) rowlst)) 
                    (setq index (1+ index))
                  ) 
                ) 
                (setq index 1)
              ) 
            ) 
            (foreach x rowlst (setq inslst (cons x inslst)))
            (foreach x collst (setq inslst (cons x inslst)))
            (setq index 0)
            (repeat blknum 
              (entmake (list '(0 . "INSERT") 
                             '(100 . "AcDbEntity") 
                             (cons 8 lay) 
                             '(100 . "AcDbBlockReference") 
                             (cons 2 bname) 
                             (cons 10 (nth index inslst)) 
                             (cons 41 xfac) 
                             (cons 42 yfac) 
                             (cons 50 rot)                    
                             (cons 210 nrml)
                       )
              )
              (setq newblk (vlax-ename->vla-object (entlast))
                    blklst (cons newblk blklst)
                    newip (ZZeroPoint (vlax-get newblk 'InsertionPoint))
              )
              (foreach i txtlst
                (setq newobj (vlax-invoke i 'Copy))
                (vlax-invoke newobj 'Move vlaip newip)
              )
              (setq index (1+ index))
            ) ;repeat
            ;; Delete the minsert object.
            (vla-delete obj)
            ;; Delete the text objects initially created.
            (mapcar 'vla-delete txtlst)
            (setq renameflag T)
            ;; Pass new block objects to ProcessList for flattening.
            ;; New text objects if any are already flat.
            (ProcessList blklst)
          ) ;progn
        ) ;progn
      ) ;if
    ) ;if
  ) ;end

  ;; The explode method doesn't work with hatch objects.
  ;; The patlst var is local in primary function.

  ;; If a hatch has an odd normal and the hatch pattern name is
  ;; AR-CONC or AR-SAND the hatch is recreated to flatten it.
  ;; Otherwise the hatch is exploded and the result is flattened
  ;; in order to maintain visual integrity.

  ;; The HatchObjectType property specifies either a regular
  ;; hatch (zero) or a gradient hatch (one). Gradient hatch
  ;; was new in ACAD 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 definition?

  (defun FlatHatch (obj / rtd patname mark ss sset newobj 
                          mn mx scale GetHatchScale)

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

    ;; Added 9/14/2007.
    ;; Argument: hatch vla-object.
    ;; Returns a corrected scale value when a hatch object was created
    ;; using a non-standard hatch definition.
    ;; Note, it only checks the first y offset. A pattern definition may
    ;; contain multiple y offsets.
    (defun GetHatchScale (obj / stdoffsetlst patname elst scl ang 
                                xoff yoff yspacing offset)

      ;; Example ("ANSI31" 0.125 3.175)
      ;; 0.125 - the y offset in acad.pat.
      ;; 3.175 - the y offset in acadiso.pat.
      ;; (* 0.125 25.4) = 3.175.
      ;; Add to this list as needed.
      (setq stdoffsetlst 
        '(("AR-SAND" 1.567 39.8018)
          ("AR-CONC" -5.89789472 -149.807)
          ("ANSI31" 0.125 3.175)
          ("ANSI32" 0.375 9.525)
          ("ANSI33" 0.25 6.35)
          ("ANSI34" 0.75 19.05)
          ("ANSI35" 0.25 6.35)
          ("ANSI36" 0.125 3.175)
          ("ANSI37" 0.125 3.175)
          ("ANSI38" 0.125 3.175))
      )
      (setq patname (vlax-get obj 'PatternName))
      (if (vl-position patname (mapcar 'car stdoffsetlst))
        (progn
          (setq
            scl (vlax-get obj 'PatternScale)
            elst (entget (vlax-vla-object->ename obj))
            ;; Don't use the PatternAngle property here.
            ;; It may not agree with what DXF code 53 returns.
            ang (cdr (assoc 53 elst))
            xoff (cdr (assoc 45 elst))
            yoff (cdr (assoc 46 elst))
            yspacing (/ (- (* yoff (cos ang)) (* xoff (sin ang))) scl)
          )
          (if (zerop (getvar "measurement"))
            (setq offset (car (cdr (assoc patname stdoffsetlst))))
            (setq offset (cadr (cdr (assoc patname stdoffsetlst))))
          )
          (abs (* scl (/ yspacing offset)))
        )
      )
    ) ;end

    (cond 
      ((TestNormal obj)
        (CheckRename (vlax-get obj 'Elevation) 0)
        (vlax-put obj 'Elevation 0.0)
      )
      ((TestZNormal obj))
      ;; 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.
      ;; Revised 9/8/2007. Limited to patterns AR-CONC and AR-SAND 
      ;; because they are random. Include SOLID and ANSI patterns.
      ((and
         ;; Recreate boundary introduced at 2006.
         (>= (atof (getvar "AcadVer")) 16.2)
         (or patlst (setq patlst (LstACADPAT)))
         (setq patname (vlax-get obj 'PatternName))
         (vl-position patname patlst)
         (or 
           (if (eq "SOLID" patname) (setq scale 1.0))
           (setq scale (GetHatchScale obj))
         )
         ;; Avoid the hatch boundary associativity removed message.
         (not (vlax-put obj 'AssociativeHatch 0))
         (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 ACAD bug.
         (not (command "._zoom" "_object" sset ""))
         (if hpa (setvar "hpassoc" 0))
         (not (command "._hatch" patname scale
                (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))
        ;; Should not be needed.
        ;(vlax-put newobj 'AssociativeHatch 0)
        (ApplyProps obj newobj)
      )
      (T (CommandExplode obj))
    ) ;cond
  ) ;end

  ;; AcDbSolid 
  ;; Added 9/1/2007. Split former FlatSolidOrTrace function.
  ;; 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 FlatSolid (obj / coord)
    (CheckRename (vlax-get obj 'Thickness) 0)
    (vlax-put obj 'Thickness 0.0)
    (setq coord (vlax-get obj 'Coordinates))
    (cond
      ((TestNormal obj)
        (CheckRename coord (ZZeroCoord coord))
        (vlax-put obj 'Coordinates (ZZeroCoord coord))
      )
      ((TestZNormal obj))
      (T
        (vlax-put obj 'Normal '(0.0 0.0 1.0))
        (vlax-put obj 'Coordinates (ZZeroCoord coord))
        (setq renameflag T)
      )
    )
  ) ;end
  
  ;; AcDbTrace
  ;; Added 9/1/2007. Split former FlatSolidOrTrace function.             
  (defun FlatTrace (obj / coord)
    (CheckRename (vlax-get obj 'Thickness) 0)
    (vlax-put obj 'Thickness 0.0)
    (setq coord (vlax-get obj 'Coordinates))
    (cond
      ((TestNormal obj)
        (CheckRename coord (ZZeroCoord coord))
        (vlax-put obj 'Coordinates (ZZeroCoord coord))
      )
      (T
        (vlax-put obj 'Normal '(0.0 0.0 1.0))
        (vlax-put obj 'Coordinates (ZZeroCoord coord))
        (setq renameflag T)
      )
    )
  ) ;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 (TestNormal 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
      ((TestZNormal ename))
      ;; Flatten mline with an odd normal.
      ((not (TestNormal 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.
  ;; Revised 9/9/2007 - added condition.
  ;; Revised 1/18/2011 with thanks to Peter B at the swap for his bug
  ;; report regarding the fact some regions cannot be exploded.
  ;; That caused an error in version SF 1.2e.
  (defun FlatRegion (obj / lst)
    (cond
      ((TestZNormal obj))
      (T 
       (if
         (not (vl-catch-all-error-p 
           (setq lst (vl-catch-all-apply 'vlax-invoke (list obj 'Explode)))))
          (progn
            (vla-delete obj)
            (setq renameflag T)
            (ProcessList lst)
          )
          ;Else send object to WMFOutIn if 2005 or later.
          (if (>= version 16.2)
            (WMFOutIn obj)
            ;; Else count as not flattened.
            (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
    (if (or inoutlst WMFflag)
      (princ 
        (strcat "\rFlattening complex objects, 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)
              )
            )
            ;; Added 9/11/2007.
            ((eq "AcDbMLeader" objname) 
              (FlatMLeader x)
            )
            ;; Added 8/29/2007.
            ((eq "AcDbLeader" objname)
              (FlatLeader x)
            )
            ((or
                (eq "AcDb3dPolyline" objname)
                (eq "AcDbFace" 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
                  ;; Revised 1/10/2008. Added the layer checking typically
                  ;; done in ExpBlockMethod and CommandExplode.
                  (setq lay (vlax-get x 'Layer))
                  (setq templst (vlax-invoke x 'Explode))
                  (foreach i templst
                    (if (eq "0" (vlax-get i 'Layer))
                      (vlax-put i 'Layer lay)
                    )
                    (if (zerop (vlax-get x 'Color))
                      (vlax-put x 'Color 256)
                    )
                  )
                  (ProcessList templst)
                  (vla-delete x)
                )
                (ExpBlockMethod x)
              ) ;if
              (setq templst nil lay 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 "AcDbSurface" objname)
               ;; Added 2/4/2011.
               (eq "AcDbPlaneSurface" objname)
              )
              ;; Added 2/6/2011. Use WMF out in with 2005 or later.
              ;; Otherwise use the CommandExplode function.
              (if (>= version 16.1)
                (WMFOutIn x)
                (CommandExplode x)
              )
            )
            ;; Added 2/7/2011.
            ;; Body objects cannot be exploded.
            ((eq "AcDbBody" objname)
              (if (>= version 16.1)
                (WMFOutIn x)
                (progn
                  (setq cnt (1+ cnt))
                  (if (not (vl-position "AcDbBody" notflatlst))
                    (setq notflatlst (cons "AcDbBody" notflatlst))
                  )
                )
              )
            )
            ((eq "AcDbShape" objname)
              (if (>= version 16.1)
                (WMFOutIn x)
                (CommandExplode x)
              )
            )
            ;; Added 9/1/2007.
            ((eq "AcDbSolid" objname)
              (FlatSolid x)
            )
            ;; Added 9/1/2007.
            ((eq "AcDbTrace" objname)
              (FlatTrace 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)
            )
            ;; Removed support for AEC objects 8/25/2007. 
            ((wcmatch (strcase objname) "AEC*")
              (setq cnt (1+ cnt))
              (if (not (vl-position "DbAecObject" notflatlst))
                (setq notflatlst (cons "DbAecObject" notflatlst))
              )
            )
            ;; Added 9/9/2007. Explodes to a spline.
            ((eq "AcDbHelix" objname)
              (CommandExplode x)
            )
            ;; Added proxy option 8/25/2007.
            ((eq "AcDbZombieEntity" objname)
              (CommandExplode x)
            )
            ;; Revised 2/4/2011. Both object types deleted.
            ((or
               (eq "AcDbLight" objname)
               (eq "AcDbCamera" objname)
               (eq "AcDbSun" objname)
             )
              (vla-delete 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 ProcessList

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

  ;;;;;;; START PRIMARY ROUTINE ;;;;;;;
  
  ;;;;;;; START BEFORE SELECTION ;;;;;;;

  (setq 
     acad (vlax-get-acad-object)
     doc (vla-get-ActiveDocument acad)
     views (vla-get-Views doc)
  )
  ;; Delete SFview if it exists.
  (if (setq i (ValidItem views "SFview"))
    (vl-catch-all-apply 'vla-delete (list i))
  )
 
  (vla-StartUndoMark doc)

  ;; Ensure model space is active.
  (if (= 0 (vlax-get doc 'ActiveSpace))
    (progn
      (princ "\n SupperFlatten is designed to run in model space. Switching to model. ")
      (vlax-put doc 'ActiveSpace 1)
    )
  )
  
  ;;;;;;; END BEFORE SELECTION ;;;;;;;

  ;;;;;;; GET SELECTION SET ;;;;;;

  (if (setq ss (ssget (list (cons 410 (getvar "ctab")))))
    ;; Long progn...
    (progn
      ;; 2004 or later.
      (if (>= version 16)
        (setq hpa (getvar "hpassoc"))
      )
      ;; 2006 or later. Added 9/14/2007.
      (if (>= version 16.2)
        (progn
          (setq slu (getvar "showlayerusage"))
          (setvar "showlayerusage" 0)
        )
      )
      (setq  
         blocks (vla-get-Blocks doc)
         layouts (vla-get-Layouts doc)
         sscol (vla-get-SelectionSets doc)
         mspace (vla-get-ModelSpace doc)
         mspacecnt (vlax-get mspace 'Count)
         elevms (vlax-get doc 'ElevationModelSpace)
         elevps (vlax-get doc 'ElevationPaperSpace)
         version (atof (getvar "AcadVer"))
         locklst (UnlockLayers doc)
         expm (getvar "explmode")
         ucsfol (getvar "ucsfollow")
         pksty (getvar "pickstyle")
         cnt 0
         expblkcnt 0
      )
      (vlax-put doc 'ElevationModelSpace 0.0)
      (vlax-put doc 'ElevationPaperSpace 0.0)
      (setvar "ucsfollow" 0)
      (setvar "cmdecho" 0)
      (setvar "explmode" 1)
      (setvar "pickstyle" 0)
      ;; UCSflag is used at the end of the routine to restore the previous UCS
      ;; if it was not world originally.
      (if (= 0 (getvar "worlducs"))
        (setq UCSflag T)
      )
      ;; Flattening needs to be done in WCS due to how some
      ;; objects behave while interacting with the code.
      (command "._ucs" "_world")
      ;; Convert the selection set to a list of vla-objects.
      (setq lst (SSVLAList ss))
      ;; Moved the following to this location 8/25/2007.
      ;; Make a list of block names selected including nested names.
      ;; Also test for proxy objects.
      (setq testlst lst)
      (while testlst
        (princ 
          (strcat "\rAnalyzing selection... " 
            (setq *sbar (Spinbar *sbar)))
        )        
        (setq obj (car testlst)
              objname (vlax-get obj 'ObjectName)
        )
        (if 
          (or 
            (eq "AcDb3dSolid" objname) 
            (eq "AcDbBody" objname)
            (eq "AcDbSurface" objname)
            (eq "AcDbPlaneSurface" objname)
          )
          (setq WMFflag T)
        )
        (if 
          (and 
            (eq "AcDbBlockReference" objname)
            (not (vlax-property-available-p obj 'Path))
          )
          (progn
            (setq name (vlax-get obj '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))
              )
            )
          )
        )
        (if (eq "AcDbZombieEntity" objname)
          (setq proxylst (cons obj proxylst))
        )        
        (setq testlst (cdr testlst))        
      ) ;while
      ;; Added 9/22/2007 to deal with proxy objects within blocks.
      (foreach x blknamelst
        (if (CheckBlock x "AcDbZombieEntity") 
          (DeleteBlockProxies x)
        )
        ;; Added 2/9/2011. Check for these object types in selected blocks.      
        (if (not WMFflag)
          (if 
            (or
              (CheckBlock x "AcDb3dSolid")
              (CheckBlock x "AcDbBody")
              (CheckBlock x "AcDbSurface")
              (CheckBlock x "AcDbPlaneSurface")
            )
            (setq WMFflag T)
          )
        )
      )
      ;; Added here 2/19/2011. SFview is only needed wnen flattening 3D solids 
      ;; and similar object types. If SFview pre-existed, it was deleted above.
      (if WMFflag
        (progn
          (command "._view" "_save" "SFview")
          ;; Visual styles were added in 2007. Two reasons for the following
          ;; command calls. First, set the view style to 2d wireframe.
          ;; Second, in some cases beta testing showed if the view was set to
          ;; 2d wireframe and then the view was saved, the saved wiew was not
          ;; 2d wirefame as expected. Seems like a bug. Whatever, this fixes
          ;; that problem and eliminates the need for the user to set the view
          ;; to 2d wireframe before running the routine. 
          ;; Exmaple file: 2008 Sample folder Visualization - Conference Room.dwg.
          (if (>= version 17)
            (progn
              (command "._view" "_settings" "_visual" "SFview" "2d wireframe"
                       "_background" "SFview" "_none" "" "")
              (command "._view" "_restore" "SFview")
            )
          )
        )
      )     
      (cond
        ((not WMFflag))
        ((and
            WMFflag
           (not (>= version 16.1))
         )
         (princ "\n  Flattening 3D solids using WMF out/in requires 2005 or later. ")
        )
        ((and
           WMFflag
           (>= version 16.1)
         )
         (princ "\n  Flattening 3D solids using WMF out/in. ")
        )
      )

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

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

      (or *expans* (setq *expans* "No"))
      (or *overkillans* (setq *overkillans* "No"))
      (or *proxyans* (setq *proxyans* "No"))
      
      (setq optans T)
      
      (cond
        ;; pre 2006 and ET is not loaded
        ((and (< version 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 "  Proxies=" *proxyans*))

            (initget "Rename Proxies")
            (setq optans
              (getkword 
                "\nSuperFlatten options [Rename blocks/Proxies] < >: ")
            )
            (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 "Proxies")
                (initget "Yes No")
                (setq *proxyans* 
                  (getkword "\nFlatten proxy objects? [Yes/No] <N>: ")
                )
                (if (not *proxyans*) (setq *proxyans* "No"))
              )
            )
          )
        )

        ;; pre 2006 and ET is loaded
        ((and (< version 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*
                           "  Proxies=" *proxyans*
                   )
            )
            
            (if (not proxyreport)
              (progn
                (if proxylst 
                  (princ (strcat "\n  " (itoa (length proxylst)) " proxies selected. "))
                  (princ "\n  No proxies selected. ")
                )
                (setq proxyreport T)
              )
            )

            (initget "Rename Overkill Proxies")
            (setq optans
              (getkword 
                "\nSuperFlatten options [Rename blocks/Overkill/Proxies] < >: ")
            )
            (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"))
              )
              ((eq optans "Proxies")
                (initget "Yes No")
                (setq *proxyans* 
                  (getkword "\nFlatten proxy objects? [Yes/No] <N>: ")
                )
                (if (not *proxyans*) (setq *proxyans* "No"))
              )
            )
          )
        )

        ;; 2006 or later and ET is not loaded
        ((and (>= version 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*
                           "  Proxies=" *proxyans*
                   )
            )

            (if (not proxyreport)
              (progn
                (if proxylst 
                  (princ (strcat "\n  " (itoa (length proxylst)) " proxies selected. "))
                  (princ "\n  No proxies selected. ")
                )
                (setq proxyreport T)
              )
            )

            (initget "Rename Explodable Proxies")
            (setq optans
              (getkword 
                "\nSuperFlatten options [Rename blocks/Explodable blocks/Proxies] < >: ")
            )
            (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 "Proxies")
                (initget "Yes No")
                (setq *proxyans* 
                  (getkword "\nFlatten proxy objects? [Yes/No] <N>: ")
                )
                (if (not *proxyans*) (setq *proxyans* "No"))
              )
            )
          )
        )

        ;; 2006 or later and ET is loaded
        ((and (>= version 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*
                           "  Proxies=" *proxyans*
                   )
            )
            
            (if (not proxyreport)
              (progn
                (if proxylst 
                  (princ (strcat "\n  " (itoa (length proxylst)) " proxies selected. "))
                  (princ "\n  No proxies selected. ")
                )
                (setq proxyreport T)
              )
            )

            (initget "Rename Explodable Overkill Proxies")
            (setq optans
              (getkword 
                "\nSuperFlatten options [Rename blocks/Explodable blocks/Overkill/Proxies] < >: ")
            )
            (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"))
              )
              ((eq optans "Proxies")
                (initget "Yes No")
                (setq *proxyans* 
                  (getkword "\nFlatten proxy objects? [Yes/No] <N>: ")
                )
                (if (not *proxyans*) (setq *proxyans* "No"))
              )
            )
          )
        )
      ) ; end options cond
      
      ;;; ----- END PROGRAM OPTIONS ----- ;;;

      ;(starttimer)
      
      ;; 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)
            )
          )
        )
      )
      ;; Remove proxy objects from the selection list if proxyans is No.
      (if (eq "No" *proxyans*)
        (foreach x proxylst
          (setq lst (vl-remove x lst))
        )
      )

      ;; 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)

      ;; Added 8/23/2007.
      ;; Check the names in blknamelst are still valid items
      ;; in the blocks collection.
      (foreach x blknamelst
        (if (ValidItem blocks x)
          (setq validlst (cons x validlst))
        )
      )
      (setq blknamelst (reverse validlst))

      ;; 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))
                    (vl-catch-all-apply 'vla-delete (list 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 (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)
            )
          )
        )
      )
      (if proxyerror (princ "\nA problem occurred with proxies inside blocks. "))
      (if UCSflag (command "._ucs" "_previous"))
      (if (setq i (ValidItem views "SFview"))
        (vl-catch-all-apply 'vla-delete (list i))
      )
      
      ;(endtimer)
    
    ) ; end long progn
    ;; Else
    (princ "\nNothing selected. ")
  ) ;if
  (*error* nil)

) ;; end SuperFlatten

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

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

[Modis]

Всем привет!
Вопрос касается программирования, но интересует меня скорее методика построения (алгоритм), а не сам код. Прошу меня не перенаправлять на вот эту тему и ей подобные - указанные там коды работают некорректно в некоторых случаях.
Итак - имеем две кривые (полилинии). Не учитываем что они могут пересекаться.
Построение ведем по такому алгоритму:
- Указываем число опорных точек
- Замеряем длину первой указанной полилинии и делим ее на количество опорных точек
- Идем в цикле "вдоль" этой полилинии сегментами (т.е. длину, полученную в прошлом пункте, умножаем на номер шага цикла). Не могу понятно объяснить, но думаю кто в теме - тот понял
- От второй полилинии нахожу отрезок, ближайший к текущей точке в первой полилинии (closestPointTo). По логике - это перпендикуляр. Хотя я тут не уверен
- Между двумя точками нахожу середину и по вот этим "серединам" строю новую полилинию
В общем, если у меня две полилинии идут примерно в одном направлении, то строится все нормально. А вот если у меня полилинии имеют сильные искривления, то в углах поворота строится все некорректно. На картинке пример построения: синие - это указанные полилинии, красная - это построенная программно полилиния, а зеленые - это я вручную опускал перпендикуляры, чтобы понять что происходит

Получается, что выбранный мной вариант не корректен. А если рассматривать вариант с перпендикулярами, то вот в таких углах как на картинке из той полилинии что "внутри" можно опускать по два перпендикуляра на полилинию, что "снаружи"

[igr]

В приложении к AutoCAD ModPlus есть эта функция. Хорошее приложение

[Кулик Алексей aka kpblc]

Modis, я бы шел по другому пути (хотя это и оффтоп): делишь одну полилинию на Х частей, потом для второй определяешь, с какой стороны (с начала или с конца) ее делить, и тоже делишь на те же Х частей. Полученные точки соединяешь. Или такой вариант уже пройден и не срабатывает?
P.S. Посмотри код PLTOOLS, там наверняка найдешь интересное решение.

[Modis]

Сообщение от igr В приложении к AutoCAD ModPlus есть эта функция. Хорошее приложение

так я автор этого приложения

[Modis]

Сообщение от Кулик Алексей aka kpblc P.S. Посмотри код PLTOOLS, там наверняка найдешь интересное решение.

Вот такой результат выдает PLTOOLS:

Потому-то вопрос я и задал. Меня не оставляют мысли, что возможно решение нужно искать уже в чистой математике (геометрии), но не нашел ничего на эту тему

[VVA]

Сообщение от Modis но интересует меня скорее методика построения (алгоритм), а не сам код

Наиболее точные построения дает метод "катящегося круга". Ссылки даны в #232

[Кулик Алексей aka kpblc]

Картинку не видно.

[Modis]

Сообщение от VVA Наиболее точные построения дает метод "катящегося круга". Ссылки даны в #232

Блин.... в общем почитал ответ, почитал форум, взял код Ли Мака отсюда и вот такой результат

[VVA]

Посмотрел код Lee Maca - ничем не отличается от моего (в моем PLTOOLS - линии разбиваться на равное количество частей и между точками каждой части находится середина. У Ли - в каждой кромке откладываются равные длинны) в #232 есть ссылка на эту программу. Здесь действительно "катящийся круг". Алгоритм разрисован в картинках и, думаю, понятен.

[igr]

Очень рад -отличное приложение

[Modis]

Сообщение от igr Очень рад -отличное приложение

Спасибо. Приятно слышать

[kp+]

Сообщение от VVA в #232 есть ссылка на эту программу.

Она у Вас запускается? У меня - нет Акад 2010. Где-то когда-то давно видел прежнюю версию этой проги, которая нормально работала, но по каким-то причинам не сохранил

[VVA]

Вот версия, скачанная мной в 2014. Проверял на 2013

[Vassa]

Возможно, подойдет в качестве идеи для lisp'а: использовать сеть соединения (команда П-СОЕД (RULESARF)). После построения сети (рис. 2), строим (с привязкой к середине "поперечных" ребер сети) "среднюю" линию (3). На рис. 4 результат. Плотность сети (и, соответственно, точность построения "средней") задается переменной SURFTAB1.

[fasadel]

Граждане. Пока не дано определение, что такое средняя линия, обсуждение программной реализации бесполезно! Кто-то делит линии на равные сегменты и соединяет их концы (#42), кто-то катит круг (#37), кто-то вообще параллельными отрезками работает (#29). Дело не в точности того или иного построения. Результат будет получаться разный по геометрической сути.

Мне видится "правильным" вариант катящихся кругов.

Offtop: Интересно тот, кто задавал вопрос, вышел на пенсию или ещё нет?

[kp+]

Сообщение от fasadel Пока не дано определение, что такое средняя линия, обсуждение программной реализации бесполезно!

С определением-то все просто: средняя линия - это геометрическое место точек, равноудаленных от двух заданных линий. Вопрос в другом - минимально необходимое количество и расположение ключевых точек для построения такой линии. Вариант разбиения исходных линий на равное количество мелких отрезков и поиска середин отрезков, соединяющих их вершины - не всегда адекватен.

Сообщение от fasadel Мне видится "правильным" вариант катящихся кругов.

+1

[Vassa]

Сообщение от kp+ Вариант разбиения исходных линий на равное количество мелких отрезков и поиска середин отрезков, соединяющих их вершины - не всегда адекватен.

Проверил на разных конфигурациях "непараллельных". Согласен с Вашим мнением.
Вариант "катящегося круга" дает наилучший из предложенных вариантов результат.

[trir]

http://doc.cgal.org/latest/Straight_...n_2/index.html

[Modis]

Сообщение от Vassa Вариант "катящегося круга" дает наилучший из предложенных вариантов результат

Я уже писал - не дает (( Может и лучший, но не верный результат
http://forum.dwg.ru/showpost.php?p=1574882&postcount=36

[VVA]

Сообщение от trir http://doc.cgal.org/latest/Straight_...n_2/index.html

Еще ссылка https://neerc.ifmo.ru/wiki/index.php...aight_skeleton

[VVA]

Сообщение от Modis Я уже писал - не дает (( Может и лучший, но не верный результат http://forum.dwg.ru/showpost.php?p=1574882&postcount=36

Версия Rolling Ball из #41 дает лучший результат, чем

Сообщение от Modis взял код Ли Мака отсюда и вот такой результат

Только с опциями надо разобраться, а то у меня почти час работала. Правда и линии начертил от балды

Команда: ROLLIN ===========================================================================# Choose the starting end of the first Polyline Boundary: Choose the starting end of the second Polyline Boundary: The total length of 1. border is: 53201.6156 The total length of 2. border is: 73450.952 What is the increment along the boundary to check for ball fit? <0>: Increment: 11.1741 Ball increase factor, 0.1 - 9.0 ....... [0.5/1/2/3/4/5/6/7/8/9] <8>: Increase factor: 8 Number of Part Angles for ang. > 180° (2-100, 1 = use standard) <1>: 5 Number of Part Angles for angles > 180° : 5 Show side to draw ball/centerline with <M-left-klick>: RIGHT side --------------------------------------------------------------------------- => Start time..: 16:16:18 Building ball angle list ... DONE (Time: 0.503 sec.) To do: 0 of 4870, Center points: 3814 ** 7 intersection point(s) could not be corrected. => Elapsed time: 54 mins. 45.131 secs. --------------------------------------------------------------------------- Do you want to remove colinear points from centerline? [Yes/No] <Y>: Y Removing colinear pts. from list ... DONE, removed: 2906, kept: 908 --------------------------------------------------------------------------- Elapsed Time for tests: 0.316 drawing centerline ... DONE The total length of Centerline is: 53339.5902 Do you want to GET the Circles? [Yes/No] <N>: Do you want to GET the Circle radius lines? [Yes/No] <N>:

[Vassa]

Насколько я понимаю, начиная с #46 подразумевается та или иная конкретная программная реализация ИДЕИ "катящегося круга". Все они, по-видимому, имеют какие то недостатки, в силу чего дают такие, позвольте сказать, неприемлемые результаты. Я примерял ИДЕЮ вручную, приблизительно, но вполне допустимо, на варианте из сообщения #36. Результат, по-моему, визуально вполне приемлем.

[Shrainer]

Коллеги, приветствую!
Пытаюсь запустить лисп катящегося круга - не хочет работать с полилинией.
Обе на одной отметке (нулевой).
Выбираю 1 и 2 линию, указываю параметры, задаю направление - и либо ни чего не выдает, либо выдает Internall Error.

AutoCad 2016

[Kaha251184]

https://apps.autodesk.com/ACD/ru/Det...ed,desc&query=
"...Настройка 50% была бы полезна, например, для генерации центральной полилинии или средней полилинии между двумя другими полилиниями"-описание (из переводчика).
БЕСПЛАТНО

[Browning Zed]

Апну тему. Код ниже - имхо, самый корректный вариант построения срединной линии из всех мной встреченных. В проге один, "визуальный" недочет - перед тем как средняя линия будет построена на экране на мгновение отобразятся необходимые для построения, промежуточные линии. Может умельцы подправят.

Код:

[Выделить все]

 
;;;************************ centerPline.LSP ***********************;;;
;;;                                                                ;;;
;;;                Centerline between two polyline                 ;;;
;;;                                                                ;;;
;;;                  author: Gian Paolo Cattaneo                   ;;;
;;;                                                                ;;;
;;;                  version: 1.0  -  21.12.2013                   ;;;
;;;                                                                ;;;
;;;****************************************************************;;;


(defun c:CPL ( / *error* Loft_n Loft_p Loft_u Loft_v :e1 :e2
                 e1 e2 p1 p2 D_off EL e1o e2o L1 L2 EL1 E_new
                 *pl* E_join pa pb e_del results rip)

    (defun *error* ( msg )
        (command "_.undo" "_end")
        (if Loft_n (setvar 'loftnormals Loft_n))
        (if Loft_p (setvar 'loftparam Loft_p))
        (if Loft_u (setvar 'surfu Loft_u))
        (if Loft_v (setvar 'surfv Loft_v))
        (if pl_type (setvar 'plinetype pl_type))
        (setvar 'cmdecho cmd)

        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (setq cmd (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    (command "_.undo" "_begin")    

    (if (null ETmsg) (check_ET))
    (check_ucs)
    (check_view)
    (check_ver)

    (setq Loft_n (getvar 'loftnormals))
    (setq Loft_p (getvar 'loftparam))
    (setq Loft_u (getvar 'surfu))
    (setq Loft_v (getvar 'surfv))
    (setq pl_type (getvar 'plinetype))

    (setvar 'loftnormals 0)
    (setvar 'loftparam 7)
    (setvar 'surfu 0)
    (setvar 'surfv 0)
    (if (= 0 (getvar 'plinetype)) (setvar 'plinetype 1))

    (if (and
            (setq :e1 (<sel> "\nSelect First Polyline"))
	    (setq p1 (cadr :e1))
	    (setq :e1 (car :e1))
            (not (redraw :e1 3))
            (setq :e2 (<sel> "\nSelect Second Polyline"))
	    (setq p2 (cadr :e2))
	    (setq :e2 (car :e2))	    
        )
        (progn
            (redraw :e1 4)
            (check_elev)
            (check_normal)
            (setq e1 (entmakex (cdr (entget :e1))))
            (setq e2 (entmakex (cdr (entget :e2))))
            (setq D_off (* (Max (MaxDist e1 e2) (MaxDist e2 e1)) 0.53))
	    
            (setq EL (entlast))
            (command "_offset" D_off e1 "_non" p2 "")
            (setq e1o (entlast))	    
            (check_offset)

            (setq EL (entlast))
            (command "_offset" D_off e2 "_non" p1 "")
            (setq e2o (entlast))
            (check_offset)   

            (command "_move" e1o e2o "" "_non" "0,0,0" "_non" (list 0.0 0.0 (* D_off 0.5)))

            (command "_loft" e1 e1o "" "")
            (setq L1 (entlast))
            (command "_loft" e2 e2o "" "")
            (setq L2 (entlast))

            (setq EL (entlast) EL1 EL)

            (command "_intersect" L1 L2 "")

            (mapcar
               '(lambda (x)
                    (if (not (vlax-erased-p x)) (entdel x))
                )
                (list e1o e2o e1 e2 L1 L2)
            )       

            (if (> (sslength (setq E_new (e_next EL "SS"))) 0)
                (progn
                    (if :ET:     
                        (acet-flatn E_new nil)
                        (progn
                            (command "_move" E_new "" "_non" "0,0,0" "_non" "0,0,1e99")
                            (command "_move" E_new "" "_non" "0,0,0" "_non" "0,0,-1e99")
                        )
                    )
                    (setq E_join (e_next EL1 "LS"))

                    (if (= "LINE" (cdr (assoc 0 (entget (car E_join)))))
                        (progn
                            (setq pa (trans (cdr (assoc 10 (entget (car E_join)))) 0 1))
                            (setq pb (trans (cdr (assoc 11 (entget (car E_join)))) 0 1))
                            (command "_pline" "_non" pa "_non" pb "")
                            (setq E_join (subst (entlast) (setq e_del (car E_join)) E_join))
                            (entdel e_del)
                        )
                    )
                    (command "_.join")
                    (apply 'command E_join)
                    (command "")
                    (setq results t)
                )
            )
        )
    )
    (setvar 'loftnormals Loft_n)
    (setvar 'loftparam Loft_p)
    (setvar 'surfu Loft_u)
    (setvar 'surfv Loft_v)
    (setvar 'plinetype pl_type)
    (command "_.undo" "_end")
    (setvar 'cmdecho cmd)
    (prompt "\n*") (prompt "\n*")(prompt "\n*")
    (if results (prompt (strcat "\nCenterline created " (if :ET: "(Polyline)." "(Spline)."))))
    (princ)
)

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

(defun check_ET ()
    (if (member "acetutil.arx" (arx))
        (progn
            (or acet-flatn (load "FLATTENSUP.LSP"))
            (setq :ET: t)
        )
        (progn
            (setq :ET: nil)
            (alert
                (strcat
                    "Express Tools are not installed."
                    "\nIf there are curves the centerline is drawn with a spline."
                )
            )
	    (setq ETmsg t) 
        )
    )
)

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

(defun check_ucs ()
    (or
        (and
            (zerop (caddr (getvar 'ucsxdir)))
            (zerop (caddr (getvar 'ucsydir)))
        )
        (progn
            (alert "UCS not normal to the WCS")
            (exit)
        )
    )
)
                           
;****************************************************************************

(defun check_view ()
    (or
        (and
            (zerop (car (getvar 'viewdir)))
            (zerop (cadr (getvar 'viewdir)))
            (> (caddr (getvar 'viewdir)) 0)
        )
        (progn
            (alert "View needs to be in plan (0 0 1)")
            (exit)
        )
    )
)

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

(defun check_ver ()
    (if (< (atoi (substr (ver) 13)) 2011)
        (progn
            (alert "This routine require AutoCAD 2011 or higher.")
            (exit)
        )
    )
)

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

(defun <sel> (<msg> / *poly* *esel* *p*)
    (while (not *poly*)
        (setvar "errno" 0)
        (setq *esel* (entsel <msg>))
        (setq *poly* (car *esel*))
        (setq *p* (cadr *esel*))
        (if (= 7 (getvar 'errno))
            (alert "No objects selected")
        )
        (if (= 'ename (type *poly*))
            (cond
                ( (null (wcmatch (cdr (assoc 0 (entget *poly*))) "LWPOLYLINE"))
                  (alert "Invalid selection, the object is not a LWPOLYLINE.")
                  (setq *poly* nil)
                )
                ( (= 1 (logand 1 (cdr (assoc 70 (entget *poly*)))))
                  (alert "Invalid selection, the polyline is not open.")
                  (setq *poly* nil)
                )
            )
        )
    )
    (list *poly* *p*)
)

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

(defun check_elev ()
    (if
        (not
            (equal
                (cdr (assoc 38 (entget :e1)))
                (cdr (assoc 38 (entget :e2)))
                1e-6
            )
        )
        (progn
            (alert "Polylines have different elevation.")
            (exit)
        )
    )
)

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

(defun check_normal ()
    (if
        (or
            (not (equal (cdr (assoc 210 (entget :e1))) '(0.0 0.0 1.0) ))
            (not (equal (cdr (assoc 210 (entget :e2))) '(0.0 0.0 1.0) ))
        )
        (progn
            (alert "Polyline is not normal to the WCS.")
            (exit)
        )
    )
)

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

(defun e_next (entL mode / next)
    (if (= mode "SS") (setq next (ssadd)))
    (if (/= entL (entlast))
        (while (setq entL (entnext entL))
       	    (if (entget entL)
                (cond
                    ( (= mode "LS") (setq next (cons entL next)) )
                    ( (= mode "SS") (setq next (ssadd entL next)) )
                )
            )
        )
    )
    next
)

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

(defun check_offset ( / o_del)
    (if rip (setq rip (1+ rip)) (setq rip 1))
    (if (> (length (setq o_del (e_next EL "LS"))) 1)
        (progn
            (entdel e1)
            (entdel e2)
            (if (= rip 2) (entdel e1o))
            (mapcar
               '(lambda (x)
                    (if (not (vlax-erased-p x)) (entdel x))
                )
                o_del
            )
            (alert
                (strcat
                    "Modeling failed."
                    "\nTry to split the polylines into more portions."
                )
            )
            (exit)
        )
    )
)

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

(defun MaxDist (ent1 ent2 / :step De1 :div p_step :D Dmax)
    (setq :step (/ (setq De1 (vlax-curve-getDistAtParam ent1 (vlax-curve-getEndParam ent1))) 500))
    (setq :div :step)
    (setq Dmax 0.00)
    (while (< :div De1)
        (setq p_step (vlax-curve-getPointAtDist ent1 :div))
        (setq :D (distance p_step (vlax-curve-getClosestPointTo ent2 p_step)))
        (if (> :D Dmax) (setq Dmax :D))
        (setq :div (+ :div :step))
    )
    Dmax
)

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

(vl-load-com)

(prompt "\n*") (prompt "\n*")
(princ "\nCenterline between two polyline - by Gian Paolo Cattaneo")
(princ "\ncenterPline.LSP loaded ............... Type \"CPL\" to run ")
(princ)

[АлексЮстасу]

Сообщение от VVA Версия Rolling Ball из #41 дает лучший результат

Отказывается работать в 2019:

Command: ROLLIN ===========================================================================# Choose the starting end of the first Polyline Boundary: Choose the starting end of the second Polyline Boundary: The total length of 1. border is: 22891.4711 The total length of 2. border is: 17313.6319 ... -- F:rb-ERROR -- Resetting program changes ... Cannot invoke (command) from *error* without prior call to (*push-error-using-command*). Converting (command) calls to (command-s) is recommended.

Сообщение от Browning Zed Код ниже - имхо, самый корректный вариант построения срединной линии из всех мной встреченных.

Отказывается для замкнутых. Отказывается для полилиний с разным уровнем. Запустил для длинных полилиний - думает долго, все думает, снял задачу...

[АлексЮстасу]

Сообщение от fasadel Offtop: Интересно тот, кто задавал вопрос, вышел на пенсию или ещё нет?

Опять понадобилось.
Из того, что в предыдущий раз насобирал, лучший для меня результат оказался у cPoly.lsp. Чья, откуда - не помню.
Увы, MPL из PlTools на наших задачах выдает совсем не то.

А в cPoly.lsp самый ни на есть катящийся круг - видно, как он катится, изменяясь в диаметре от расстояний между полилиниями.
Недостаток - нельзя задать количество вершин, как в MPL. Лучше всего, чтобы программка сама брала среднее от количества вершин выбранных полилиний.
В сложных случаях и cPoly пересекает линии.
Еще она забавная-мистическая - ощущение, что программка требует участия-внимания! Если не двигать мышкой, то она может замереть. А когда просто мышкой водишь - двигается непрерывно и быстро.

В файле синие линии - берега реки. Белые - результат cPoly. Желтая - MPL при 100. Увы, результат MPL от изменения числа вершин лучше почти не становится.