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;;;AREA:PEDIT: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(m:op1)
(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)
(m:op2)
)
(prin1)
)

What you show doesn't require any changes. But without seeing the called
subroutines m:op1 and m:op2, it's impossible to tell what it's supposed to
do, or how it does it. (You *do* have those routines loaded, I hope? If not,
that alone could be your problem.)
___

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
(m:op1)
(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)
(m:op2)
)
)
;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
(m:op1)
(setvar"osmode"128)
(setvar"lastpoint"(setq EPT(osnap EPT"nea")))
(setq a(getpoint EPT" PER to: ")
)
(setvar"osmode"0)
(m:op2)
)
)
;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
(m:op1) ;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)
(m:op2) ;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(d:plpo) ;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
; (m:op1)
; (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 m:op1
(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)))
;Data:PLinePOints
(defun D:PLPO( / 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)

Polytechforum.com is a website by engineers for engineers. It is not affiliated with any of manufacturers or vendors discussed here.
All logos and trade names are the property of their respective owners.