PLINE Lisp Offset Question

Can anyone convert this lisp routine in to a workable version for Autocad
2004. It use to work in 14. Very handy for doing lease drawings.
Thanks for any help,
Ed

(defun C:OPM;;;AREAEDIT:STRETCH:SITE Offsetting stretch one side of a
Pline to mid point of a line perpendicular
( / a b c d e f g h i j k u v)
(command".ucs""w")
(while(mp1)
(setvar"osmode"128)
(setvar"lastpoint"(setq EPT(osnap EPT"nea")))
(setq a(getpoint EPT" midpoint between PER to: ")
b(inters a EPT e f nil)
a(polar b(angle b a)(/(distance b a)2))
)
(setvar"osmode"0)
(mp2)
)
(prin1)
)

 

Need routines mp2 and mp2 to check it out

 

Thanks for taking a look.

I believe I found the whole orig. routine.



;feature -- looks behind and ahead for other vertexes on same axis,

;since many fac man packages include tracing functions that draw another

;vertex at each side of a door jamb

;but we want this to treat a whole wall, even if broken by a door, as being

;between two vertexes

;feature -- works on angled walls, to look at the next or prior leg,

;and stretch along its axis, a distance equal to the hypotenuese of

;any triagle formed

;FUTURE -- to add an undo feature ;; hangup is (entget..), which has no

;susceptibility to (initget...), and AutoCAD refuses to fix this ;; requires

;making operator state a desire to continue or undo, then picking another,

;instead of a sensible process of either picking another or undoing

; **** COMMANDS ****

;Offsetting stretch one side of a Pline, to mid point of a line
perpendicular

(defun C:OPM( / a b c d e f g h i j k) ; u v

(varget)

(command"ucs""w");this is just too much trouble to avoid

(while t

(mp1)

(setvar"osmode"128)

(setvar"lastpoint"(setq EPT(osnap EPT"nea")))

(setq a(getpoint EPT" midpoint between PER to: ")

b(inters a EPT e f nil)

a(polar b(angle b a)(/(distance b a)2))

)

(setvar"osmode"0)

(mp2)

)

)

;Offsetting stretch one side of a Pline, to a line perpendicular

(defun C:OPP( / a b c d e f g h i j k) ; u v

(varget)

(command"ucs""w")

(while t

(mp1)

(setvar"osmode"128)

(setvar"lastpoint"(setq EPT(osnap EPT"nea")))

(setq a(getpoint EPT" PER to: ")

)

(setvar"osmode"0)

(mp2)

)

)

;Offsetting stretch one side of a Pline, without getting all entities,

;just the pline - preset distance, most like offset command

(defun C:OP( / a b e f g h i j k); c d u v

(setq D:OFD(defdist"\nOffset\nOffset distance"D:OFD))

(varget)

(command"ucs""w")

(while t

(mp1) ;sets values of EPT, e, f, g, u, and v

(setvar"snapbase"(list(car EPT)(cadr EPT)))

(setvar"snapunit"'(2000.0 1.0))

(setvar"snapmode"1)

(setvar"snapang"(angle e f))

(initget 1)

(setq a(getpoint EPT" Side to offset?")

b(angle EPT a)

b(if(equal b(* 2 pi)0.001)0 b)

a(polar EPT b D:OFD)

)

(setvar"snapunit"SU_V)

(mp2) ;uses a, e, f, g, u, and v

)

)















; **** BASE FUNCTIONS ****

;base function for selecting one side of pline

(defun M:OP1( / c) ;h i j k

(while(not(="VERTEX"(lstnent"\nPick polyline side")))(prompt" Not
polyline."))

(setq e(cdrass 10) ;the leading vertex of side selected

f(cdr(assoc 10(entget(entnext ENT))))

;next vertex, but nil if pline

;is closed & side selected was the closer

c(while(/="SEQEND"(cdr(assoc 0(setq d(entget(setq ENT(entnext ENT))))))))

;finding database of parent entity

ENT(cdr(assoc -2 d))

ELST(entget ENT)

h(dlpo) ;this lists all of the points in a pline

f(if f f(car h)) ;if no next point, because closed, use start point

;here the checking occurs for coaxial vertices before e and after f

i(length h)

j(- i(length(member e h))) ;position indicator of point e

k(1+ j) ; " " " " f

)

;e, searching backwards (and looping back to start, if necessary)

(while(and(>= j 0)

(inters(nth j h)(nth j h)e f nil) ;this will be true if coaxial

)

(setq e(nth j h)

j(if(and(= 0 j)

(member(car h)(cdr h)) ;this is closed pline

)

(1- i)

(1- j)

)

)

)

(setq u(if(= -1 j)nil(nth j h))) ;this is point before e - need for

;angle calc of this side, or nil if

;e is start of unclosed pline

;f, searching forward (and looping back to end, if necessary)

(while(and(<= k(1- i))

(inters(nth k h)(nth k h)e f nil) ;this will be true if coaxial

)

(setq f(nth k h)

k(if(and(=(1- i)k)

(member(car h)(cdr h))

)

0

(1+ k)

)

)

)

(setq v(if(= h k)nil(nth k h))) ;this is point after f - need for

;angle calc of this side, or nil if

;f is end of unclosed pline

;next are testing lines

;
(command".undo""g")(setvar"pdsize"-5)(setvar"pdmode"35)(command".point"e".po
int"f)

; (setvar"pdmode"3)(if u(command".point"u)(prompt"\nU is nil"))(if
v(command".point"v)(prompt"\nV is nil"))(command".undo""e")

;this selects crossing from e to f, and gets a set of everything NOT our
pline

(setq g(ssget"c"e f))

(ssdel ENT g)

)

;this function for testing - delete in final

;(defun C:OP()

; (while t

; (mp1)

; (getstring"Paused")

; (command".u")

; )

; )



;base function for stretching the side and redrawing anything underlying

(defun M:OP2( / b) ; w x y z

;a, e, f, and g come from mp1

(setvar"highlight"0)

; (setq b(inters a EPT e f nil))

(if(and(='PICKSET(type g))(>(sslength g)0))

(progn(command".stretch""c"e f"r"g""EPT a)

(repeat(setq aa(sslength g))

(redraw(ssname g(setq aa(1- aa))))

)

(redraw ENT)

)

(command".stretch""c"e f""EPT a)

) ;above was the basic

;perpendicular stretch

;below we check for the angles of

;the prior and following sides, and move

;the corners back into alignment

(setq c(angle EPT a) d(distance EPT a) ;can't just use D:OFD here, because

;OPP and OPM don't use the preset

r(angle u e)

r(if(equal r(* 2 pi)0.001)0 r) ;the degree to which Autocad

s(angle v f) ;is too precise really gets

s(if(equal s(* 2 pi)0.001)0 s) ;on my nerves

)

(if(or(not u)

(equal r c 0.001)

)

nil;(prompt"No change in e")

(progn;(print(angle u e))(print c)(print w)(print x)(setvar"cmdecho"1)

(setq w(polar e c d) ;to where e was stretched

x(polar e r(* d(/ 1(cos(- r c)))))

) ;to where we want e

(command".stretch""w"w w ENT""w x)

)

)

(if(or(not v)

(equal s c 0.001)

)

nil;(prompt"No change in f")

(progn(setq w(polar f c d) ;to where f was stretched

x(polar f s(* d(/ 1(cos(- s c)))))

) ;to where we want f

(command".stretch""w"w w ENT""w x)

)

)

)

; **** UTILITY FUNCTIONS FOR RESETTING VARIABLES ****

;

;get system variables

(defun varget()

(if V:VCHK(varreset)) ;(varget) sets this flag below so will not run twice
without a (varreset)

(setvar"cmdecho"0)

(prompt"\n")

(command".UNDO""G")

(setq D:OERR *error*)

(defun *error*(msg)

(prompt(strcat"Autolisp error: "msg))

(varreset);(varget) redefs *error* so that an error will cause a (varreset)

(clear)

)

(setq V:VCHK"Y";(varget)has to set a flag so that (varreset) knows whether
or not to run

SU_V(getvar"snapunit") SM_V(getvar"snapmode")

S_V(getvar"snapang") SB_V(getvar"snapbase")

O_V(getvar"osmode")

)

)

;Restore system variables

(defun varreset()(setvar"expert"0)

(if SSET(setq SSET nil))(if FILDES(setq FILDES(close FILDES)))

(command nil nil) ;cancel

(if V:VCHK

(progn(prompt"\nResetting variables...")(setq V:VCHK nil)

(setvar"snapang" S_V) (setvar"snapbase"SB_V)

(setvar"snapunit"SU_V) (setvar"snapmode"SM_V)

(setvar"osmode"O_V)

(command".undo""e")

(if ENT(redraw ENT))

(if D:OERR(setq *error* D:OERR))

)

)

(gc)

(prin1)

)

(defun lstnent(a / b c) ;for R11+ only

(if V:VCHK(setvar"snapmode"0))

(setvar"highlight"1)

(while(not(setq b(nentsel(strcat a": "))))(prompt"\n1 selected, 0 found."))

(setq ENT(car b) ;ENTity name

EPT(cadr b) ;Entity PoinT picked

ELST(entget ENT) ;Entity LiST

D:NENT(if(='ENAME(type(setq c(car(nth(1-(length b))b)))))c nil)

b(cdrass 0)) ;to make it return entity type, useable in (while...) loop
looking for an entity type

)

(defun cdrass(a)(cdr(assoc a ELST)))

;Replaces GETDIST to check for existing value

(defun DEFDIST (b c / d e) ;c is default value and b is prompt

(setq d(if c(if(=(type c)'REAL)c 3.5)3.5) e(initget"- +") e(getdist(strcat
b"/+/- <"(rtos d)">: ")))(cond((="+"e)(abs c))((="-"e)(- c))(e e)(t d)))







;DataLinePOints

(defun DLPO( / a b c d)

; (while(/="POLYLINE"(lstent"Pick pline")))

(setq a(entnext ent)

d(cdr(assoc 10(entget a)))

)

(while(and a

(="VERTEX"(cdr(assoc 0(setq c(entget a)))))

)

(setq b(cons(cdr(assoc 10 c))b)

a(entnext a)

)

)

(if(=(cdrass 70)1) ;if closed, add first point to end of list

(setq b(cons d b)) ;if manually closed, by picking rather than "C"

) ;option, first point already there

(setq b(reverse b))

)

(prompt"\n\nCommand names (type the caps) are OffsetPline, OffsetPlinePer,
and OffsetPlineMid.")

(prin1)