actr lisp 跑_[求助]求从多段线偏移某个线条的lisp程序？

[code="lisp]

(defun c:test1 (/   ent     bul       dt p

pt   pt0     laste     th-pl-getsegat

txt-mkline     th2o      txt-3rd txt-4th

txt-5th

)

(defun thado ()

(cond

(%$*thado*$%)

(setq %$*thado*$% (vlax-get-acad-object))

)

)

(defun thactdoc ()

(cond

(%$*thactdoc*$%)

(setq %$*thactdoc*$% (vla-get-activedocument (thado)))

)

)

(defun th-pl-getsegat (obj p / blg p1 p2 pa pcen pn v)

(setq pn (vlax-curve-getclosestpointto obj (trans p 1 0))

pa (fix (vlax-curve-getparamatpoint obj pn))

p1 (vlax-curve-getpointatparam obj pa)

p2 (vlax-curve-getpointatparam obj (1+ pa))

)

(setq obj (th2o obj))

(setq blg (vla-getbulge obj pa))

(if (zerop blg)

(list "kLine" (list pa (1+ pa)) p1 p2)

(progn

(setq v    (vlax-curve-getsecondderiv obj pa)

pcen (mapcar

'+

p1

v

)

)

(if (> blg 0)

(list "kArc" (list pa (1+ pa)) pcen p1 p2)

(list "kArc"

(list pa (1+ pa))

(mapcar

'-

p1

v

)

p2

p1

)

)

)

)

)

(defun txt-mkline (p1 p2 / ent)

(if (setq ent (entmakex (list '(0 . "LINE")

'(100 . "AcDbEntity")

'

(100 . "AcDbLine")

(cons 10 p1)

(cons 11 p2)

'(210 0. 0. 1.)

)

)

)

ent

)

)

(defun th2o (object)

(cond

((is-ename object)

(vlax-ename->vla-object object)

)

((is-vla-object object)

object

)

((is-string object)

(vl-catch-all-apply

'(lambda ()

(vla-handletoobject (thactdoc) object)

)

)

)

(t

nil

)

)

)

(defun txt-3rd (lst)

(caddr lst)

)

(defun txt-4th (lst)

(cadddr lst)

)

(defun txt-5th (lst)

(car (cddddr lst))

)

(if (and

(setq p (entsel "\n点取多义线:"))

(setq pt0 (getpoint "\n偏移方向:"))

(setq dt (getdist "\n偏移距离:"))

)

(progn

(setq ent (car p)

pt (cadr p)

)

(setq bul (th-pl-getsegat (th2o ent) (osnap pt "_nea")))

(cond

((= (car bul) "kLine")

(setq laste (txt-mkline (txt-3rd bul) (txt-4th bul)))

(vl-cmdf "_.OFFSET" dt laste "_non" pt0 "")

(entdel laste)

)

((= (car bul) "kArc")

(vl-cmdf "_.ARC"

"C"

(txt-3rd bul)

(txt-4th bul)

(txt-5th bul)

)

(setq laste (entlast))

(vl-cmdf "_.OFFSET" dt laste "_non" pt0 "")

(entdel laste)

)

)

)

)

(princ)

)

[/code]