;; Draw Elipse as Polyline with user defined width
;; Created and combined by Igal Averbuh 2016
;; Based on existing routines with great respect to authors (Lee Mac, Marko Ribar and others)

;; Polyline Width - Lee Mac
;; Applies a given constant width to all segments in a selection of polylines.

(defun c:psw ( / *error* idx sel wid )

(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(LM:startundo (LM:acdoc))
(if
(setq sel (LM:ssget "\nSelect polylines: " '("L" ((0 . "LWPOLYLINE,POLYLINE")))))

(progn
(initget 4)
(setq wid (getdist (strcat "\nSpecify Width of Pline : ")))
(repeat (setq idx (sslength sel))
(vla-put-constantwidth (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) wid)
)
)
)
(*error* nil)
(princ)
)

;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo - Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)

;; End Undo - Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)

;; Active Document - Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
(vl-load-com) (princ)

;; Convert Elipses to Polylines (Marko Ribar routine)
;; Saved from: http://www.theswamp.org/index.php?topic=48034.0
;; EllipseToPolyline
;; Returns a polyline (vla-object) which is an approximation of the ellipse (or elliptical arc)
;;
;; Argument : an ellipse (vla-object)

(defun EllipseToPolyline (el / *acdoc* cl norm cen
elv pt0 pt1 pt2 pt3 pt4 ac0
ac4 a04 a02 a24 bsc0 bsc2 bsc3
bsc4 plst blst spt spa fspa srat
ept epa fepa erat n
)
(vl-load-com)
(setq cl (equal (ang<2pi (vla-get-StartAngle el))
(ang<2pi (vla-get-EndAngle el))
1e-6
)
*acdoc* (vla-get-activedocument (vlax-get-acad-object))
norm (vlax-get el 'Normal)
cen (trans (vlax-get el 'Center) 0 norm)
elv (caddr cen)
cen (3dTo2dPt cen)
pt0 (mapcar '+ (trans (vlax-get el 'MajorAxis) 0 norm) cen)
ac0 (angle cen pt0)
pt4 (mapcar '+ cen (trans (vlax-get el 'MinorAxis) 0 norm))
pt2 (3dTo2dPt
(trans (vlax-curve-getPointAtparam el (/ pi 4.)) 0 norm)
)
ac4 (angle cen pt4)
a04 (angle pt0 pt4)
a02 (angle pt0 pt2)
a24 (angle pt2 pt4)
bsc0 (/ (ang<2pi (- a02 ac4)) 2.)
bsc2 (/ (ang<2pi (- a04 a02)) 2.)
bsc3 (/ (ang<2pi (- a24 a04)) 2.)
bsc4 (/ (ang<2pi (- (+ ac0 pi) a24)) 2.)
pt1 (inters pt0
(polar pt0 (+ ac0 (/ pi 2.) bsc0) 1.)
pt2
(polar pt2 (+ a02 bsc2) 1.)
nil
)
pt3 (inters pt2
(polar pt2 (+ a04 bsc3) 1.)
pt4
(polar pt4 (+ a24 bsc4) 1.)
nil
)
plst (list pt4 pt3 pt2 pt1 pt0)
blst (mapcar '(lambda (b) (tan (/ b 2.)))
(list bsc4 bsc3 bsc2 bsc0)
)
)
(foreach b blst
(setq blst (cons b blst))
)
(foreach b blst
(setq blst (cons b blst))
)
(foreach p (cdr plst)
(setq ang (angle cen p)
plst (cons
(polar cen (+ ang (* 2 (- ac4 ang))) (distance cen p))
plst
)
)
)
(foreach p (cdr plst)
(setq ang (angle cen p)
plst (cons
(polar cen (+ ang (* 2 (- ac0 ang))) (distance cen p))
plst
)
)
)
(setq vlaLayout (vla-ObjectIdToObject *acdoc* (vla-get-OwnerId el)))
(setq pl
(vlax-invoke
vlaLayout
'AddLightWeightPolyline
(apply 'append
(setq plst
(reverse (if cl
(cdr plst)
plst
)
)
)
)
)
)
(vlax-put pl 'Normal norm)
(vla-put-Elevation pl elv)
(mapcar '(lambda (i v) (vla-SetBulge pl i v))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
blst
)
(if cl
(vla-put-Closed pl :vlax-true)
(progn
(setq spt (vlax-curve-getClosestPointTo pl (vlax-get el 'Startpoint))
spa (vlax-curve-getParamAtPoint pl spt)
fspa (fix spa)
ept (vlax-curve-getClosestPointTo pl (vlax-get el 'Endpoint))
epa (vlax-curve-getParamAtPoint pl ept)
fepa (fix epa)
n 0
)
(cond
((equal spt (trans pt0 norm 0) 1e-9)
(if (= epa fepa)
(setq plst (sublist plst 0 (1+ fepa))
blst (sublist blst 0 (1+ fepa))
)
(setq erat (/ (- (vlax-curve-getDistAtParam pl epa)
(vlax-curve-getDistAtParam pl fepa)
)
(- (vlax-curve-getDistAtParam pl (rem (1+ fepa) 17))
(vlax-curve-getDistAtParam pl fepa)
)
)
plst (append (sublist plst 0 (1+ fepa))
(list (3dTo2dPt (trans ept 0 norm)))
)
blst (append (sublist blst 0 (1+ fepa))
(list (k*bulge (nth fepa blst) erat))
)
)
)
)
((equal ept (trans pt0 norm 0) 1e-9)
(if (= spa fspa)
(setq plst (sublist plst fspa nil)
blst (sublist blst fspa nil)
)
(setq srat (/ (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
(vlax-curve-getDistAtParam pl spa)
)
(- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
(vlax-curve-getDistAtParam pl fspa)
)
)
plst (cons (3dTo2dPt (trans spt 0 norm))
(sublist plst (1+ fspa) nil)
)
blst (cons (k*bulge (nth fspa blst) srat)
(sublist blst (1+ fspa) nil)
)
)
)
)
(T
(setq srat (/ (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
(vlax-curve-getDistAtParam pl spa)
)
(- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
(vlax-curve-getDistAtParam pl fspa)
)
)
erat (/ (- (vlax-curve-getDistAtParam pl epa)
(vlax-curve-getDistAtParam pl fepa)
)
(- (vlax-curve-getDistAtParam pl (rem (1+ fepa) 17))
(vlax-curve-getDistAtParam pl fepa)
)
)
)
(if (< epa spa)
(setq plst (append
(if (= spa fspa)
(sublist plst fspa nil)
(cons (3dTo2dPt (trans spt 0 norm))
(sublist plst (1+ fspa) nil)
)
)
(cdr (sublist plst 0 (1+ fepa)))
(if (/= epa fepa)
(list (3dTo2dPt (trans ept 0 norm)))
)
)
blst (append
(if (= spa fspa)
(sublist blst fspa nil)
(cons
(k*bulge (nth fspa blst) srat)
(sublist blst (1+ fspa) nil)
)
)
(sublist blst 0 fepa)
(if (= epa fepa)
(list (nth fepa blst))
(list (k*bulge (nth fepa blst) erat))
)
)
)
(setq plst (append
(if (= spa fspa)
(sublist plst fspa (1+ (- fepa fspa)))
(cons (3dTo2dPt (trans spt 0 norm))
(sublist plst (1+ fspa) (- fepa fspa))
)
)
(list (3dTo2dPt (trans ept 0 norm)))
)
blst (append
(if (= spa fspa)
(sublist blst fspa (- fepa fspa))
(cons
(k*bulge (nth fspa blst) srat)
(sublist blst (1+ fspa) (- fepa fspa))
)
)
(if (= epa fepa)
(list (nth fepa blst))
(list (k*bulge (nth fepa blst) erat))
)
)
)
)
)
)
(vlax-put pl 'Coordinates (apply 'append plst))
(foreach b blst
(vla-SetBulge pl n b)
(setq n (1+ n))
)
)
)
pl
)

;; Ang<2pi
;; Returns the angle expression betweem 0 and 2*pi
(defun ang<2pi (ang)
(if (and (<= 0 ang) (< ang (* 2 pi)))
ang
(ang<2pi (rem (+ ang (* 2 pi)) (* 2 pi)))
)
)

;; 3dTo2dPt
;; Returns the 2d point (x y) of a 3d point (x y z)
(defun 3dTo2dPt (pt) (list (car pt) (cadr pt)))

;; Tan
;; Returns the angle tangent
(defun tan (a) (/ (sin a) (cos a)))

;; SUBLIST
;; Returns a sub list
;;
;; Arguments
;; lst : a list
;; start : start index (first item = 0)
;; leng : the sub list length (number of items) or nil
(defun sublist (lst start leng / n r)
(if (or (not leng) (< (- (length lst) start) leng))
(setq leng (- (length lst) start))
)
(setq n (+ start leng))
(while (ename lwa))
(setq ell (vlax-vla-object->ename e))
(entupd (cdr (assoc -1 (entmod (subst (assoc 8 (entget ell)) (assoc 8 (entget lw)) (entget lw))))))
(setq lwd (entget lw))
(entupd (cdr (assoc -1 (entmod (vl-remove nil (append lwd (list (if (assoc 62 (entget ell)) (assoc 62 (entget ell))) (if (assoc 420 (entget ell)) (assoc 420 (entget ell))))))))))
(vla-delete e)
)
(vla-delete ss)
)
)
(*error* nil)
)

;; PELL
;; Draws an ellipse or an elliptical arc approximation (polyline) on the fly
(defun c:pell (/ *error* ec pe old ent lwa lw lwd)

(vl-load-com)

(defun *error* (msg)
(if msg
(prompt msg)
)
(setvar 'cmdecho ec)
(setvar 'pellipse pe)
(princ)
)

(setq ec (getvar 'cmdecho)
pe (getvar 'pellipse)
old (entlast)
)
(setvar 'cmdecho 1)
(setvar 'pellipse 0)
(command "_.ellipse")
(while (/= 0 (getvar 'cmdactive))
(command pause)
)
(if (not (eq old (setq ent (entlast))))
(progn
(setq lwa (EllipseToPolyline (vlax-ename->vla-object ent)))
(setq lw (vlax-vla-object->ename lwa))
(entupd (cdr (assoc -1 (entmod (subst (assoc 8 (entget ent)) (assoc 8 (entget lw)) (entget lw))))))
(setq lwd (entget lw))
(entupd (cdr (assoc -1 (entmod (vl-remove nil (append lwd (list (if (assoc 62 (entget ent)) (assoc 62 (entget ent))) (if (assoc 420 (entget ent)) (assoc 420 (entget ent))))))))))
(entdel ent)
)
)
(*error* nil)
)

(defun C:DS ()
(setvar "osmode" 16384)
(setvar "orthomode" 0)
(command "-layer" "m" "TPZ-Geo-Image" "C" "1" "" "")

(command "_ellipse" "_c")
(while (> (getvar "CmdActive") 0)
(command pause)
)
(c:e2p)
(c:psw)
; (command "_.pedit" "l" "" "w" (rtos (getvar 'PLINEWID)) "")
(setvar "osmode" 167)
(princ)
)
(c:ds)

Advertisements