home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / PXW.LSP < prev    next >
Encoding:
Text File  |  1992-01-31  |  4.3 KB  |  121 lines
  1. (vmon)
  2.  
  3. (defun pxwerr(s)
  4.    (if (/= s "Function cancelled")
  5.        (princ (strcat "\nError:" s))
  6.    )
  7.    (command "layer" "s" olay "")
  8.    (setvar "cmdecho" 1)
  9.    (setq *error* oer)
  10.    (princ)
  11. )
  12.  
  13. (defun C:PXW(/ oer fname olay x ss ssl sn ename bn xx yy sn1 sn2 en en1 en2 wlength wwidth insp n)
  14.    (setvar "CMDECHO" 0)
  15.    (setq olay (getvar "CLAYER"))
  16.    (setq oer *error* *error* pxwerr)
  17.    (chkw) (setq winn fname)
  18.    (setq ss (ssget))
  19.    (command "layer" "m" "spwindow" "")
  20.    (if ss (progn
  21.       (setq ssl (sslength ss) n 0)
  22.       (repeat ssl
  23.         (setq sn (ssname ss n) en (entget sn))
  24.         (setq ename (cdr (assoc 0 en)) bn (cdr (assoc 8 en)))
  25.         (if (and (eq ename "POLYLINE") (eq bn "SPWINDOW"))
  26.             (progn
  27.             (setq sn1 (entnext sn) en1 (entget sn1))
  28.             (setq sn2 (entnext sn1) en2 (entget sn2))
  29.             (setq sn3 (entnext sn2) en3 (entget sn3))
  30.             (setq scal (cdr (assoc 40 en)))
  31.             (if (= (substr (rtos scal 2 4) (strlen (rtos scal 2 4)) 1) "1") (setq scal (- scal)))
  32.             (setq insp (cdr (assoc 10 en1)))
  33.             (setq wlength (fix (+ 0.5 (distance insp (setq insp1 (cdr (assoc 10 en2)))))))
  34.             (setq wwidth (fix (+ 0.5 (distance insp1 (cdr (assoc 10 en3))))))
  35.             (command "insert" winn "x" scal insp "0" wwidth)
  36.             )
  37.         )
  38.         (setq n (1+ n))
  39.      )
  40.    )) ;endif
  41.    (command "layer" "s" olay "")
  42.    (setvar "CMDECHO" 1)
  43.    (setq *error* oer)
  44.    (princ)
  45. )
  46. (defun chkw(/ fg loop xh oer ratio scr scr1 scr2 scrx scry sctr sctrx sctry dx dy ddx ddy dxx dyy p1 p2 q1 q2 pl ql n inp source lp pt prev m ll lr ul ur)
  47.    (setq loop t)
  48.    (while loop
  49.    (setq xh (strcase (getstring "\n╩Σ╚δ├┼┤░╨═║┼ <C1815>:")))
  50.    (if (= xh "") (setq xh "C1815"))
  51.    (if (or (setq fname (findfile (strcat xh ".dwg"))) (setq fname (findfile (strcat xh "a.dwg")))) (setq loop nil fg t))
  52.    (if (tblsearch "BLOCK" xh) (setq loop nil fg nil))
  53.    )
  54.    (if fg (progn
  55.    (cond ((= "C" (substr xh 1 1)) (setq xh0 "C"))
  56.          ((= "M" (substr xh 1 1))
  57.          (cond ((= "P" (substr xh 2 1)) (setq xh0 "MP"))
  58.                ((= "Z" (substr xh 2 1)) (setq xh0 "MZ"))
  59.                ((= "C" (substr xh 2 1)) (setq xh0 "MC"))
  60.                (t (setq xh0 "M"))
  61.          ))
  62.    )  
  63.    (command "vslide" (strcat xh0 "(" xh ")"))
  64.    (command "ucs" "view")
  65.    (setq ratio (getvar "userr5"))
  66.    (setq scr (getvar "screensize") scr1 (car scr) scr2 (cadr scr))
  67.    (setq scry (getvar "viewsize")) ;screen y size
  68.    (setq sctr (getvar "viewctr") sctrx (car sctr) sctry (cadr sctr)) ;screen centre
  69.    (setq scrx (/ (* scr1 scry) scr2 ratio)) ;screen x size
  70.    (setq dx (/ scrx 4.0) dy (/ scry 2.0) dy (- dy (* 0.164 dy)));one
  71.    (setq ddx (- dx (* 0.082 dx)) ddy (- dy (* 0.082 dy))) ;space
  72.    (setq dxx (* 0.041 dx) dyy (* 0.041 dy))
  73.    (setq p1 (polar sctr 0 (/ scrx 2.0)) q1 (polar p1 (* 1.5 pi) (/ scry 2.0)))
  74.    (setq pl nil pl (cons p1 pl) ql nil ql (cons q1 ql))
  75.    (setq n 1)
  76.    (repeat 4
  77.       (setq p2 (polar p1 pi (* n dx)) pl (cons p2 pl))
  78.       (setq q2 (polar q1 pi (* n dx)) ql (cons q2 ql))
  79.       (setq n (1+ n))
  80.    )
  81.    (setq n 0 p1 (nth n pl) p2 p1)
  82.    (defbox)
  83.    (setq loop t)
  84.    (while loop
  85.       (setq inp (grread t))
  86.       (setq source (car inp) pt (cadr inp))
  87.       (cond ((= source 3)
  88.             (drawbox)
  89.             (setq loop nil))
  90.             ((= source 5)
  91.             (if (not (equal prev pt 0.1))
  92.             (progn
  93.             (setq prev pt)
  94.             (setq lp t n 0)
  95.             (while (and lp (< n 4))
  96.             (if (and (>= (car pt) (car (nth n pl))) (<= (car pt) (car (nth (1+ n) pl)))) (setq lp nil) (setq n (1+ n)))
  97.             (if (> (cadr pt) sctry) (setq p1 (nth n pl) m 0) (setq p1 (nth n ql) m 1))
  98.             )
  99.             (if (not (equal p1 p2 0.1)) (progn (drawbox) (defbox) (setq p2 p1)))
  100.             )))
  101.       )
  102.     )
  103.    (if (and (= n 0) (= m 0)) (setq fname fname) (setq fname (strcat (strcase xh) (chr (+ 65 n (* m 4))) ".DWG")))
  104.    (command "ucs" "p")
  105.    (redraw))
  106.    (setq fname xh))
  107. )
  108.  
  109. (defun defbox(/ x1 x2 y1 y2)
  110.    (setq x1 (+ (car p1) dxx) x2 (+ x1 ddx))
  111.    (setq y1 (+ (cadr p1) dyy) y2 (+ y1 ddy))
  112.    (setq ll (list x1 y1) lr (list x2 y1))
  113.    (setq ul (list x1 y2) ur (list x2 y2))
  114.    (drawbox)
  115. )
  116.  
  117. (defun drawbox()
  118.    (grdraw ll lr -1) (grdraw lr ur -1)
  119.    (grdraw ur ul -1) (grdraw ul ll -1)
  120. )
  121.