Code:
(defun LITPX (sss / li elem pkt1 pkt2 pliste)
(setq pliste nil)
(setq elem sss)
(command "_UCS" "_W")
(setq pkt1 (cdr (assoc 10 elem)))
(setq pkt2 (cdr (assoc 11 elem)))
(setq pliste (append pliste (list pkt1)))
(setq pliste (append pliste (list pkt2)))
(setq ppliste (append ppliste (list pliste)))
)
(defun LWTPX(sss / lwl elem pt pktx pkty pktz pkt pliste)
(setq elem sss)
(setq nv (cdr (assoc 210 elem)))
(setq tra (cdr (assoc 38 elem)))
(command "_UCS" "_W")
(command "_UCS" "_N" "_ZA" "" nv)
(setq v (list 0 0 tra))
(command "_UCS" "_O" v)
(setq pliste nil)
(foreach pt elem
(if (= 10 (car pt))
(progn
(setq pktx (cadr pt))
(setq pkty (caddr pt))
(setq pktz 0)
(setq pkt (list pktx pkty pktz))
(setq pkta (trans pkt 1 0))
(setq pliste (append pliste (list pkta)))
)
) )
(command "_UCS" "_W")
(setq ppliste (append ppliste (list pliste)))
)
(defun PLTPX (sss / pl vertex subent pliste)
(setq pl1 (ssname auswahl i))
(command "_UCS" "_W")
(setq pliste nil)
(setq subent (entnext pl1))
(while (/= (cdr (assoc 0 (entget subent))) "SEQEND")
(setq vertex (cdr (assoc 10 (entget subent))))
(setq subent (entnext subent))
(setq pliste (append (list vertex) pliste))
)
(setq ppliste (append ppliste (list pliste)))
)
(defun SPTPX (sss / elem pt pktx pkty pktz pkt ll pliste)
(setq elem sss)
(command "_UCS" "_W")
(setq ll (length elem))
(setq pliste nil)
(foreach pt elem
(if (= 10 (car pt))
(progn
(setq pktx (cadr pt))
(setq pkty (caddr pt))
(setq pktz (cadddr pt))
(setq pkt (list pktx pkty pktz))
(setq pkt (list pkt))
(setq pliste (append pliste pkt))
)
)
)
(setq ppliste (append ppliste (list pliste)))
)
(defun ARTPX(sss / bog aufl elem ra pm aw ew sw ii pt pliste)
(setq elem sss)
(setq bog (ssname auswahl i))
(command "_UCS" "_W")
(command "_UCS" "_E" bog)
(setq pliste nil)
(setq ra (cdr (assoc 40 elem)))
(setq pm (list 0 0))
(setq aw (cdr (assoc 50 elem)))
(setq ew (cdr (assoc 51 elem)))
(if (< ew aw)
(setq ew (+ (* 2 pi) ew))
)
(setq aufl 10)
(if (> (- ew aw) (* 0.5 pi)) (setq aufl 20))
(if (> (- ew aw) pi) (setq aufl 30))
(if (> (- ew aw) (* 1.5 pi)) (setq aufl 40))
(setq sw (/ (- ew aw ) aufl))
(setq aw 0)
(setq sw (abs sw))
(setq ii 0)
(while (<= ii aufl)
(setq pt (polar pm (+ aw (* ii sw)) ra))
(setq ptw (trans pt 1 0))
(setq pliste (append pliste (list ptw)))
(setq ii (+ ii 1))
)
(command "_UCS" "_W")
(setq ppliste (append ppliste (list pliste)))
)
(defun ELTPX(sss / elli aufl elem pm p1 zr fak aw ew
pmx pmy pmz p1x p1y p1z zrx zry zrz
p1w zrw p0 a b sw ii pt pliste)
(setq elem sss)
(setq pm (cdr (assoc 10 elem)))
(setq p1 (cdr (assoc 11 elem)))
(setq zr (cdr (assoc 210 elem)))
(setq fak (cdr (assoc 40 elem)))
(setq aw (cdr (assoc 41 elem)))
(setq ew (cdr (assoc 42 elem)))
(setq pmx (car pm))
(setq pmy (cadr pm))
(setq pmz (caddr pm))
(setq p1x (car p1))
(setq p1y (cadr p1))
(setq p1z (caddr p1))
(setq zrx (car zr))
(setq zry (cadr zr))
(setq zrz (caddr zr))
(setq p1w (list (+ pmx p1x) (+ pmy p1y) (+ pmz p1z)))
(setq zrw (list (+ pmx zrx) (+ pmy zry) (+ pmz zrz)))
(setq p0 (list 0 0 0))
(setq a (distance p0 p1))
(setq b (* fak a))
(command "_UCS" "_3P" pm p1w zrw)
(command "_UCS" "_X" (- (* 0.5 pi)))
(if (< ew aw)
(setq ew (+ (* 2 pi) ew))
)
(setq aufl 10)
(if (> (- ew aw) (* 0.5 pi)) (setq aufl 20))
(if (> (- ew aw) pi) (setq aufl 30))
(if (> (- ew aw) (* 1.5 pi)) (setq aufl 40))
(setq sw (/ (- ew aw ) aufl))
(setq pliste nil)
(setq ii 0)
(while (<= ii aufl)
(setq ptx (* a (cos(+ aw (* ii sw)))))
(setq pty (* b (sin(+ aw (* ii sw)))))
(setq pt (list ptx pty 0))
(setq ptw (trans pt 1 0))
(setq pliste (append pliste (list ptw)))
(setq ii (+ ii 1))
)
(command "_UCS" "_W")
(setq ppliste (append ppliste (list pliste)))
)
(defun SUCHEN_ANHAENGEN_LOESCHEN(uli)
(setq flag F)
(setq i -1)
(while (and (< i (length unord_liste)) (= flag F))
(progn
(setq i (+ 1 i))
(setq po1 (car ord_liste) po2 (last ord_liste))
(setq pu (nth i unord_liste))
(setq pu1 (car pu) pu2 (last pu))
(if (> eps (distance po2 pu1))
(progn
(setq ord_liste (append ord_liste (cdr pu)))
(setq unord_liste (apply 'append (subst nil (list pu) (mapcar 'list unord_liste))))
(setq flag T)
)
)
(if (and (> eps (distance po2 pu2)) (= flag F))
(progn
(setq ord_liste (append ord_liste (cdr (reverse pu))))
(setq unord_liste (apply 'append (subst nil (list pu) (mapcar 'list unord_liste))))
(setq flag T)
)
)
(if (and (> eps (distance po1 pu1)) (= flag F))
(progn
(setq ord_liste (append (reverse ord_liste) (cdr pu)))
(setq unord_liste (apply 'append (subst nil (list pu) (mapcar 'list unord_liste))))
(setq flag T)
)
)
(if (and (> eps (distance po1 pu2)) (= flag F))
(progn
(setq ord_liste (append (reverse ord_liste) (cdr (reverse pu))))
(setq unord_liste (apply 'append (subst nil (list pu) (mapcar 'list unord_liste))))
)
)
)
)
unord_liste
)
(defun C:PEDIT3D()
(alert "DEMO-VERSION
\nask scj.schulz@t-online.de\nfor the full version program")
(setq osmode_old (getvar "OSMODE"))
(command "OSMODE" 0)
(setq aunits_old (getvar "AUNITS"))
(command "_AUNITS" 3)
(setq eps 0.01)
(setq ppliste nil)
(setq auswahl (ssget))
(setq n_auswahl (sslength auswahl))
(setq i 0)
(while (< i n_auswahl)
(progn
(setq typ (cdr (assoc 0 (entget (ssname auswahl i)))))
(if (= typ "LINE") (LITPX(entget(ssname auswahl i))))
(if (= typ "LWPOLYLINE") (LWTPX(entget(ssname auswahl i))))
(if (= typ "POLYLINE") (PLTPX(entget(ssname auswahl i))))
(if (= typ "SPLINE") (SPTPX(entget(ssname auswahl i))))
(if (= typ "ARC") (ARTPX(entget(ssname auswahl i))))
(if (= typ "ELLIPSE") (ELTPX(entget(ssname auswahl i))))
(setq i (+ 1 i))
)
)
(setq unord_liste ppliste)
(setq ord_liste (car unord_liste))
(setq unord_liste (cdr unord_liste))
(while (< 0 (length unord_liste))
(SUCHEN_ANHAENGEN_LOESCHEN unord_liste)
)
(command "_3dpoly")
(foreach pt ord_liste (command pt))
(command nil)
(command "OSMODE" osmode_old)
(command "_AUNITS" aunits_old)
)
Foren auf CAD.de (alle Foren)
| 
"Lisp?!?! Why the Hell did you pick the most arcane, obscure, and hopelessly-rooted-in-the-computer-science-department language in the world for an AutoCAD programming language?" Read the whole story: 
