home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / PBANLV.LSP < prev    next >
Encoding:
Text File  |  1991-06-20  |  1.8 KB  |  52 lines
  1. (defun plverr(s)
  2.    (if (/= s "Function cancelled")
  3.        (princ (strcat "\nError:" s))
  4.    )
  5.    (command "layer" "s" "0" "")
  6.    (setvar "cmdecho" 1)
  7.    (setq *error* oer)
  8.    (princ)
  9. )
  10. (defun C:PBANLV(/ oer x insp insn ss wl hl ssl sn en sn1 en1 ins hgt n n1 xx ymin base insh)
  11.    (setvar "CMDECHO" 0)
  12.    (setq oer *error* *error* plverr) 
  13. ;   (initget "Right Left")
  14. ;   (setq fg (getkword "\n╤í╘±▒Ω╘┌╫≤▒▀,╙╥▒▀ (Left or Right):"))
  15. ;   (if (= fg "Right") (setq fg "R") (setq fg "L"))
  16.    (princ "\n╡┌╥╗╕÷┬Ñ░σ╕▀╢╚ <")
  17.    (princ 3300)
  18.    (setq wdh (if (setq x (getreal ">:")) x 3300))
  19.    (setq insp (getpoint "\n▒Ω╕▀╖√║┼▓σ╚δ╡π:"))
  20.    (command "layer" "m" "sdim" "")
  21.    (setq ss (ssget) wl nil hl nil)
  22.    (if ss (progn
  23.      (setq ssl (sslength ss) n 0 n1 0)
  24.      (repeat ssl
  25.        (setq sn (ssname ss n) en (entget sn))
  26.        (if (and (= "POLYLINE" (cdr (assoc 0 en))) (= "SBAN1" (cdr (assoc 8 en))))
  27.        (progn
  28.        (setq sn1 (entnext sn) en1 (entget sn1))
  29.        (setq rn (cdr (assoc 10 en1)) ww nil)
  30.        (setq ins (cdr (assoc 10 en1)))
  31.         (setq wl (cons (list (cadr ins) n1) wl))
  32.        (setq n1 (1+ n1))
  33.        )) ;if
  34.        (setq n (1+ n))
  35.      )
  36.      (setq n 0)
  37.      (repeat (length wl)
  38.         (setq ymin (apply 'min (mapcar 'car wl)))
  39.         (setq x (assoc ymin wl))
  40.         (if (= n 0) (setq base (- ymin wdh)))
  41.         (setq wl (subst (list 1000000.0 0) x wl))
  42.         (setq ins (list (car insp) ymin))
  43.         (command "insert" (strcat "ELUR") ins (/ (getvar "USERR1") 100.0) "" "0" (rtos (/ (fix (+ 0.005 (- (cadr ins) base))) 1000.0) 2 3))
  44.         (setq n (1+ n))
  45.       )
  46.     ))
  47.     (command "layer" "s" "0" "")
  48.     (setvar "CMDECHO" 1)
  49.     (setq *error* oer)
  50.     (princ)
  51. )
  52.