Code:
;; Globale Variablen:
;; AT:CURVE->POLY-ACCURACY Genauigkeit der Auflösung bei Splines usw:
(setq AT:CURVE->POLY-ACCURACY 1.0)
;; AT:ARC-ACCURACY Winkel-Auflösung von Kreisen und Kreisbögen
(setq AT:ARC-ACCURACY 10.0)
(defun c:at-curve->poly (/ en)
(setvar "cmdecho" 0)
(if (setq en (car (entsel)))
(if (member (cdr (assoc 0 (entget en))) '( "LINE" "POLYLINE" "LWPOLYLINE" "ARC" "CIRCLE" "ELLIPSE" "SPLINE"))
(at-curve->poly en)
(alert "Fehler: für AT-CURVE->POLY nur zulässig:\n\nLINE, POLYLINE, LWPOLYLINE, ARC, CIRCLE, ELLIPSE, SPLINE")
)
)
(prin1)
)
(defun at-curve->poly (en / el lst)
(if (setq el (entget en))
(if (setq lst (at-curve->lpt en))
(progn
(command "._pline")
(mapcar '(lambda (pt) (command pt)) lst)
(if (and (assoc 70 el) (= 1 (logand 1 (cdr (assoc 70 el)))))
(command "_cl")
(command "")
)
)
(alert "Fehler: keine Punktliste für gewähltes Objekt gefunden!")
)
)
)
(defun at-curve->lpt (en / ACCURACY el closedflag lastent len vertexnumber stparam endparam
diffparam startpt endpt result
)
(cond
((= "LWPOLYLINE" (cdr (assoc 0 (entget en))))
(or AT:ARC-ACCURACY (setq AT:ARC-ACCURACY 10.0))
(setq result (at-poly->segmentpts en))
)
;;
(T
(or AT:CURVE->POLY-ACCURACY (setq AT:CURVE->POLY-ACCURACY 0.1))
(setq ACCURACY AT:CURVE->POLY-ACCURACY)
(if (= 'ENAME (type en))
(progn
(setq el (entget en)
en (vlax-ename->vla-object en)
)
)
(progn
(setq el (entget (vlax-vla-object->ename en)))
)
)
(if (and (assoc 70 el) (= 1 (logand 1 (cdr (assoc 70 el)))))
(setq closedflag T)
)
(setq lastent (entlast))
(if (vlax-property-available-p en 'Length)
(setq len (vlax-get-property en 'Length))
(progn
(setq len (vlax-curve-getDistAtPoint en (vlax-curve-getEndPoint en)))
;; Ellipsenbögen liefern vlax-curve-getDistAtParam = 0 aus:
(if (= 0.0 len)
(setq len (vlax-curve-getDistAtParam en 1.0))
)
)
)
(setq vertexnumber (fix (/ len ACCURACY)))
(if (= 0 vertexnumber)
(setq vertexnumber 1)
)
(setq stparam (vlax-curve-getstartparam en)
endparam (vlax-curve-getendparam en)
diffparam (/ (- endparam stparam) (float vertexnumber))
startpt (trans (vlax-curve-getStartPoint en) 0 1)
endpt (trans (vlax-curve-getEndPoint en) 0 1)
)
(at-deactivate-osmode)
;; (command "._pline" startpt)
(setq result (list startpt))
(while (< (+ stparam diffparam) endparam)
(setq stparam (+ stparam diffparam))
(setq startpt (vlax-curve-getPointAtParam en stparam))
;; (command (trans startpt 0 1))
(setq result (append result (list startpt)))
)
(if (/= 1 closedflag)
;; (command "_cl")
(setq result (append result (list endpt)))
;; (command endpt "")
)
(at-restore-osmode)
)
)
;; (setvar "osmode" HVP:OLDOSMODE)
result
)
(defun at-poly->segmentpts (en / bliste ptliste)
(if (and (not AT:ARC-ACCURACY)
(not (setq AT:ARC-ACCURACY (at-getvar "AT:ARC-ACCURACY")))
)
(if (not AT:ARC-ACCURACY)
(setq AT:ARC-ACCURACY 10.0)
)
)
(setq bliste (at-get-pl-bulgevertices en))
(setq ptliste
(apply
'append
(mapcar (function (lambda (part / data)
(cond
((= 0 (cdr (cadr part)))
(list (cdr (car part)))
)
((< (cdr (cadr part)) 0)
(setq data (at-pl-bulge->arcdata
(cdr (car part))
(cdr (cadr part))
(cdr (caddr part))
)
)
(at-arcdata->linesegments
(nth 0 data)
(nth 1 data)
(nth 2 data)
(nth 3 data)
AT:ARC-ACCURACY
)
)
((< 0 (cdr (cadr part)))
(setq data (at-pl-bulge->arcdata
(cdr (car part))
(cdr (cadr part))
(cdr (caddr part))
)
)
(reverse (at-arcdata->linesegments
(nth 0 data)
(nth 1 data)
(nth 2 data)
(nth 3 data)
AT:ARC-ACCURACY
)
)
)
)
)
)
bliste
)
)
)
(setq ptliste
(reverse
(cons (vlax-curve-getEndPoint (vlax-ename->vla-object en))
(reverse ptliste)
)
)
)
)
(defun at-arcdata->linesegments (center radius startangle endangle precision /
ea sa arcangle diffangle parts sp ep np result
)
(setq sa startangle ea endangle)
(while (< ea sa)
(setq ea (+ (* 2.0 PI) ea))
)
(setq arcangle (- ea sa))
(setq parts (fix (read (rtos (+ 0.5 (/ (* arcangle precision) (* 2.0 PI))) 2 0))))
(setq diffangle (/ arcangle (float parts)))
(setq sp (rot2r (pp+ center (list radius 0.0)) center startangle))
(setq ep (rot2r (pp+ center (list radius 0.0)) center endangle))
(setq result (list sp) np sp)
(repeat parts
(setq np (rot2r np center diffangle))
(setq result (cons np result))
)
result
)
(defun at-pl-bulge->arcdata (sp bulge ep / lastent cotbce x1 x2 y1 y2 temp cen rad sa ea)
(setq lastent (entlast))
(setq x1 (car sp) x2 (car ep))
(setq y1 (cadr sp) y2 (cadr ep))
(setq cotbce (/ (- (/ 1.0 bulge) bulge) 2.0))
; Compute center point and radius
(setq cen (list (/ (+ x1 x2 (- (* (- y2 y1) cotbce))) 2.0)
(/ (+ y1 y2 (* (- x2 x1) cotbce)) 2.0)
)
)
(setq rad (distance cen sp))
; Compute start and end angles
(setq sa (atan (- y1 (cadr cen)) (- x1 (car cen))))
(setq ea (atan (- y2 (cadr cen)) (- x2 (car cen))))
(if (< sa 0.0) ; Eliminate negative angles
(setq sa (+ sa (* 2.0 pi)))
)
(if (< ea 0.0)
(setq ea (+ ea (* 2.0 pi)))
)
(if (< bulge 0.0) ; Swap angles if clockwise
(progn
(setq temp sa)
(setq sa ea)
(setq ea temp)
)
)
(list cen rad sa ea)
)
(defun rot2r (p Ursprung Winkel / UrsprungN pN p0 x0 y0 z0 cosW sinW x1 y1 p1 result)
(setq UrsprungN (xyof Ursprung)
pN (3dpoint p)
p0 (pp- pN UrsprungN)
x0 (nth 0 p0)
y0 (nth 1 p0)
z0 (nth 2 p0)
cosW (cos Winkel)
sinW (sin Winkel)
x1 (- (* cosW x0) (* sinW y0))
y1 (+ (* sinW x0) (* cosW y0))
p1 (list x1 y1 z0)
result (pp+ p1 UrsprungN)
)
)
(defun xyof (p)
(list (car p) (cadr p) 0.0)
)
(defun 3dpoint (p)
(if (= (length p) 2)
(list (car p) (cadr p) 0.0)
p
)
)
(defun pp+ (p1 p2 /)
(setq p1 (3dpoint p1)
p2 (3dpoint p2)
)
(list (+ (car p1) (car p2))
(+ (cadr p1) (cadr p2))
(+ (caddr p1) (caddr p2))
)
)
(defun pp- (p1 p2 /)
(setq p1 (3dpoint p1)
p2 (3dpoint p2)
)
(list (- (car p1) (car p2))
(- (cadr p1) (cadr p2))
(- (caddr p1) (caddr p2))
)
)
(defun at-get-pl-bulgevertices (pl / en el result dxf result2)
(setq el (entget pl))
(cond
((= "LWPOLYLINE" (cdr (assoc 0 el)))
(foreach dxf el
(if (or (= 10 (car dxf))
(= 42 (car dxf))
)
(setq result (cons dxf result))
)
)
(if (= 1 (cdr (assoc 70 el))) ; geschlossen
(setq result (cons (car (reverse result)) result))
)
(setq result (reverse result))
)
((= "POLYLINE" (cdr (assoc 0 el)))
(setq en pl)
(while (= "VERTEX" (cdr (assoc 0 (setq el (entget (setq en (entnext en)))))))
(setq result (cons (assoc 10 el) result))
(setq result (cons (assoc 42 el) result))
)
(if (= 1 (cdr (assoc 70 el))) ; geschlossen
(setq result (cons (car (reverse result)) result))
)
(setq result (reverse result))
)
)
(while (< 2 (length result))
(setq result2 (cons (list (car result) (cadr result) (caddr result)) result2))
(setq result (cddr result))
)
(reverse result2)
)
(defun at-deactivate-osmode ()
(if (not AT:OLDOSMODE)
(setq AT:OLDOSMODE (getvar "osmode"))
)
(if (not (or (= 0 AT:OLDOSMODE)
(< 16384 AT:OLDOSMODE)
)
)
(setvar "osmode" (+ 16384 AT:OLDOSMODE))
)
)
(defun at-restore-osmode ()
(if AT:OLDOSMODE
(setvar "osmode" AT:OLDOSMODE)
)
)
Foren auf CAD.de
| 
- 
