home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / EXW.LSP < prev    next >
Encoding:
Text File  |  1992-02-01  |  11.8 KB  |  331 lines
  1. (vmon)
  2.  
  3. (defun exwerr(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:EXW(/ 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* exwerr)
  17.    (chkw) (setq winn fname)
  18.    (setq ss (ssget))
  19.    (command "layer" "m" "ewindow" "")
  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 "EWINDOW"))
  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.  
  47. (defun C:INSW(/ oer olay fname x loop bn sn en ename elayer sp ep dang bn elay p10 p11 p12 d1 d2 xh)
  48.    (setvar "cmdecho" 0)
  49.    (setq olay (getvar "CLAYER"))
  50.    (setq oer *error* *error* exwerr)
  51.    (chkw) (setq bn fname)
  52.   (initget "Auto")
  53.   (setq x (getkword "Auto/<Single>: "))
  54.   (if (= x "Auto") (progn
  55.   (setq ss (ssget))
  56.   (if ss (progn
  57.    (setq ssl (sslength ss) n 0)
  58.    (repeat ssl
  59.    (setq sn (ssname ss n) en (entget sn))
  60.    (setq ename (cdr (assoc 0 en)) elay (cdr (assoc 8 en)))
  61.    (if (and (= ename "3DFACE") (member elay '("TWINDOW" "TDOOR"))) (progn
  62.    (setq p10 (cdr (assoc 10 en)) p11 (cdr (assoc 11 en)) p12 (cdr (assoc 12 en)))
  63.           (setq dang (/ (* 180 (angle p10 p11)) pi))
  64.    (setq d1 (* (fix (+ 0.5 (/ (distance p10 p11) 100.0))) 100) d2 (* (fix (+ 0.5 (/ (distance p11 p12) 100.0))) 100))
  65.   (if (< d1 1000) (setq d1 (strcat "0" (rtos (/ d1 100) 2 0))) (setq d1 (rtos (/ d1 100) 2 0)))
  66.   (if (< d2 1000) (setq d2 (strcat "0" (rtos (/ d2 100) 2 0))) (setq d2 (rtos (/ d2 100) 2 0)))
  67.    (if (= xh (strcat (substr xh 1 1) d1 d2)) (progn
  68.    (command "layer" "m" elay "")
  69.           (command "ucs" "w")
  70.           (command "ucs" "o" p10)
  71.           (command "ucs" "z" dang)
  72.           (command "ucs" "x" 90)
  73.           (command "insert" bn (trans p10 0 1) 1 "" 0 (rtos (angle p10 p11) 2 4))
  74.       ))
  75.     ))
  76.     (setq n (1+ n))
  77.     )
  78.    (command "ucs" "w")
  79.    ))
  80.    ) 
  81.    (progn
  82.    (setq loop t)
  83.    (while loop
  84.       (setq sn (car (entsel "\n╤í├┼┤░╢┤┐┌:")))
  85.       (if (/= sn nil) (progn
  86.       (setq en (entget sn) ename (cdr (assoc 0 en)) elayer (cdr (assoc 8 en)))
  87.       (if (and (member elayer '("TWINDOW" "TDOOR")) (= "3DFACE" ename)) (progn
  88.           (setq sp (cdr (assoc 10 en)) ep (cdr (assoc 11 en)))
  89.           (setq dang (/ (* 180 (angle sp ep)) pi))
  90.           (command "layer" "m" elayer "")
  91.           (command "ucs" "w")
  92.           (command "ucs" "o" sp)
  93.           (command "ucs" "z" dang)
  94.           (command "ucs" "x" 90)
  95.           (command "insert" bn (trans sp 0 1) 1 "" 0 (rtos (angle sp ep) 2 4))
  96.           (command "ucs" "w")
  97.           )
  98.           (princ "*╦∙╤í╩╡╠σ▓╗╩╟├┼┤░*")
  99.       )
  100.       )
  101.       (setq loop nil)
  102.       )
  103.    )
  104.    )) ;if
  105.    (command "layer" "s" olay "")
  106.    (setvar "cmdecho" 1)
  107.    (setq *error* oer)
  108.    (princ)
  109. )
  110.  
  111. (setq clay "TREE")
  112.  
  113. (defun C:BDINSW(/ oer olay fname x loop bn sn en ename elayer elay sp ep dang bn xh d1 d2 ssbl p10 p11 p12 iang)
  114.    (setvar "cmdecho" 0)
  115.    (setq olay (getvar "CLAYER"))
  116.    (setq oer *error* *error* exwerr)
  117.    (setq xh (strcase (getstring "\n╩Σ╚δ╛░╬∩┤·║┼ <C1815>:")))
  118.    (if (= xh "") (setq xh "C1815"))
  119.    (setq d1 (* 100 (atoi (substr xh 2 2))) d2 (* 100 (atoi (substr xh 4))))
  120.   (if (not (tblsearch "block" (setq bn (strcat xh "BD")))) (progn
  121.   (command "layer" "s" "0" "")
  122.   (command "color" 1)
  123.   (setq ssbl nil ssbl (ssadd))
  124.   (command "ucs" "w")
  125.   (setvar "thickness" 0)
  126.   (setvar "elevation" 0)
  127.   (command "line" '(0 0) (list 0 d2) "")(ssadd (entlast) ssbl)
  128.   (command "line" (list 0 d2) (list d1 d2) "")(ssadd (entlast) ssbl)
  129.   (command "line" (list d1 d2) (list d1 0) "")(ssadd (entlast) ssbl)
  130.   (command "line" (list d1 0) '(0 0) "") (ssadd (entlast) ssbl)
  131.   (command "line" '(20 20) (list (- d1 20) (- d2 20)) "")(ssadd (entlast) ssbl)
  132.   (setvar "aflags" 1)
  133.   (command "attdef" "" "B" "" "" "j" "m" (list (/ d1 2) (/ d2 2)) 500 0)
  134.   (ssadd (entlast) ssbl)
  135.   (setvar "expert" 2)
  136.   (command "block" (setq bn (strcat xh "BD")) '(0 0) ssbl "")
  137.   (setvar "expert" 0)
  138.   (command "color" "bylayer")
  139.   ))
  140.   (initget "Auto Insert")
  141.   (setq x (getkword "Insert/Auto/<Single>: "))
  142.   (cond ((= x "Insert")
  143.   (princ "\n▓π├√ <")(princ clay)
  144.   (setq x (getstring ">:"))
  145.   (if (/= x "") (setq clay x))
  146.   (setq loop t)
  147.   (while loop
  148.   (princ "\n▓σ╚δ╡π: ")
  149.    (command "insert" "border" "x" d1 "y" 200 pause pause)
  150.    (setq en (entget (setq sn (entlast))) sp (cdr (assoc 10 en)) iang (cdr (assoc 50 en)))
  151.    (command "erase" sn "")
  152.           (setq dang (/ (* 180 iang) pi))
  153.           (command "layer" "m" clay "")
  154.           (command "ucs" "w")
  155.           (command "ucs" "o" sp)
  156.           (command "ucs" "z" dang)
  157.           (command "ucs" "x" 90)
  158.           (command "insert" bn (trans sp 0 1) 1 "" 0 (rtos iang 2 4))
  159.           (command "ucs" "w")
  160.    (princ " ╝╠╨°▓σ╚δ<Y>:")
  161.    (initget "Yes No")
  162.    (setq x (getkword))
  163.    (if (= x "No") (setq loop nil))
  164.    ) ;endwhile
  165.           )
  166.   ((= x "Auto") 
  167.   (setq ss (ssget))
  168.   (if ss (progn
  169.    (setq ssl (sslength ss) n 0)
  170.    (repeat ssl
  171.    (setq sn (ssname ss n) en (entget sn))
  172.    (setq ename (cdr (assoc 0 en)) elay (cdr (assoc 8 en)))
  173.    (if (and (= ename "3DFACE") (member elay '("TWINDOW" "TDOOR"))) (progn
  174.    (setq p10 (cdr (assoc 10 en)) p11 (cdr (assoc 11 en)) p12 (cdr (assoc 12 en)))
  175.           (setq dang (/ (* 180 (angle p10 p11)) pi))
  176.    (setq d1 (* (fix (+ 0.5 (/ (distance p10 p11) 100.0))) 100) d2 (* (fix (+ 0.5 (/ (distance p11 p12) 100.0))) 100))
  177.   (if (< d1 1000) (setq d1 (strcat "0" (rtos (/ d1 100) 2 0))) (setq d1 (rtos (/ d1 100) 2 0)))
  178.   (if (< d2 1000) (setq d2 (strcat "0" (rtos (/ d2 100) 2 0))) (setq d2 (rtos (/ d2 100) 2 0)))
  179.    (if (= xh (strcat (substr xh 1 1) d1 d2)) (progn
  180.    (command "layer" "m" elay "")
  181.           (command "ucs" "w")
  182.           (command "ucs" "o" p10)
  183.           (command "ucs" "z" dang)
  184.           (command "ucs" "x" 90)
  185.           (command "insert" bn (trans p10 0 1) 1 "" 0 (rtos (angle p10 p11) 2 4))
  186.       ))
  187.     ))
  188.     (setq n (1+ n))
  189.     )
  190.    (command "ucs" "w")
  191.    ))
  192.    ) 
  193.    (T
  194.    (setq loop t)
  195.    (while loop
  196.       (setq sn (car (entsel "\n╤í├┼┤░╢┤┐┌:")))
  197.       (if (/= sn nil) (progn
  198.       (setq en (entget sn) ename (cdr (assoc 0 en)) elayer (cdr (assoc 8 en)))
  199.       (if (and (member elayer '("TWINDOW" "TDOOR")) (= "3DFACE" ename)) (progn
  200.           (setq sp (cdr (assoc 10 en)) ep (cdr (assoc 11 en)))
  201.           (setq dang (/ (* 180 (angle sp ep)) pi))
  202.           (command "layer" "m" elayer "")
  203.           (command "ucs" "w")
  204.           (command "ucs" "o" sp)
  205.           (command "ucs" "z" dang)
  206.           (command "ucs" "x" 90)
  207.           (command "insert" bn (trans sp 0 1) 1 "" 0 (rtos (angle sp ep) 2 4))
  208.           (command "ucs" "w")
  209.           )
  210.           (princ "*╦∙╤í╩╡╠σ▓╗╩╟├┼┤░*")
  211.       )
  212.       )
  213.       (setq loop nil)
  214.       )
  215.    )
  216.    )) ;cond
  217.    (command "layer" "s" olay "")
  218.    (setvar "cmdecho" 1)
  219.    (setq *error* oer)
  220.    (princ)
  221. )
  222.  
  223. (defun C:WTOPL(/ oer loop sn en ename elay bn p oen n)
  224.    (setvar "cmdecho" 0)
  225.    (setq oer *error* *error* exwerr)
  226.    (command "layer" "s" "0" "")
  227.    (setq loop t)
  228.    (while loop
  229.    (setq sn (car (entsel "\n╤í╘±╥¬╝╙┐φ╡─├┼┤░:")))
  230.    (setq en (entget sn) ename (cdr (assoc 0 en)) elay (cdr (assoc 8 en)))
  231.    (if (and (= ename "INSERT") (member elay '("TOTHER" "TWINDOW" "TDOOR"))) (progn
  232.    (setq bn (cdr (assoc 2 en)) oen (entlast))
  233.    (command "ucs" "w")
  234.    (command "insert" bn '(0 0) 1 1 0 "")
  235.    (setq ss nil ss (ssadd))
  236.    (command "explode" (entlast))
  237.    (while (/= (setq oen (entnext oen)) nil) (setq ss (ssadd oen ss)))
  238.    (setq ssl (sslength ss) n 0)
  239.    (repeat ssl
  240.       (setq sn (ssname ss n) en (entget sn) ename (cdr (assoc 0 en)))
  241.       (cond ((= ename "LINE") (command "pedit" sn "y" "w" 50 "") (ssadd (entlast) ss))
  242.             ((= ename "POLYLINE") (command "pedit" sn "w" 50 ""))
  243.       )
  244.       (setq n (1+ n))
  245.    )
  246.    (command "block" bn "y" '(0 0) ss "")
  247.    (setq loop nil)
  248.    ) (princ "*╦∙╤í╩╡╠σ▓╗╩╟├┼┤░*"))
  249.    )
  250.    (setvar "cmdecho" 1)
  251.    (setq *error* oer)
  252.    (princ)
  253. )
  254.  
  255. (defun chkw(/ fg loop 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)
  256.    (if (/= (+ fh78 fh65 fh72 fh85 fh70) 370) (tst))
  257.    (setq loop t)
  258.    (while loop
  259.    (setq xh (strcase (getstring "\n╩Σ╚δ├┼┤░╨═║┼ <C1815>:")))
  260.    (if (= xh "") (setq xh "C1815"))
  261.    (if (or (setq fname (findfile (strcat xh ".dwg"))) (setq fname (findfile (strcat xh "a.dwg")))) (setq loop nil fg t))
  262.    (if (tblsearch "BLOCK" xh) (setq loop nil fg nil))
  263.    )
  264.    (if fg (progn
  265.    (cond ((= "C" (substr xh 1 1)) (setq xh0 "C"))
  266.          ((= "M" (substr xh 1 1))
  267.          (cond ((= "P" (substr xh 2 1)) (setq xh0 "MP"))
  268.                ((= "Z" (substr xh 2 1)) (setq xh0 "MZ"))
  269.                ((= "C" (substr xh 2 1)) (setq xh0 "MC"))
  270.                (t (setq xh0 "M"))
  271.          ))
  272.    )  
  273.    (command "vslide" (strcat xh0 "(" xh ")"))
  274.    (command "ucs" "view")
  275.    (setq ratio (getvar "userr5"))
  276.    (setq scr (getvar "screensize") scr1 (car scr) scr2 (cadr scr))
  277.    (setq scry (getvar "viewsize")) ;screen y size
  278.    (setq sctr (getvar "viewctr") sctrx (car sctr) sctry (cadr sctr)) ;screen centre
  279.    (setq scrx (/ (* scr1 scry) scr2 ratio)) ;screen x size
  280.    (setq dx (/ scrx 4.0) dy (/ scry 2.0) dy (- dy (* 0.164 dy)));one
  281.    (setq ddx (- dx (* 0.082 dx)) ddy (- dy (* 0.082 dy))) ;space
  282.    (setq dxx (* 0.041 dx) dyy (* 0.041 dy))
  283.    (setq p1 (polar sctr 0 (/ scrx 2.0)) q1 (polar p1 (* 1.5 pi) (/ scry 2.0)))
  284.    (setq pl nil pl (cons p1 pl) ql nil ql (cons q1 ql))
  285.    (setq n 1)
  286.    (repeat 4
  287.       (setq p2 (polar p1 pi (* n dx)) pl (cons p2 pl))
  288.       (setq q2 (polar q1 pi (* n dx)) ql (cons q2 ql))
  289.       (setq n (1+ n))
  290.    )
  291.    (setq n 0 p1 (nth n pl) p2 p1)
  292.    (defbox)
  293.    (setq loop t)
  294.    (while loop
  295.       (setq inp (grread t))
  296.       (setq source (car inp) pt (cadr inp))
  297.       (cond ((= source 3)
  298.             (drawbox)
  299.             (setq loop nil))
  300.             ((= source 5)
  301.             (if (not (equal prev pt 0.1))
  302.             (progn
  303.             (setq prev pt)
  304.             (setq lp t n 0)
  305.             (while (and lp (< n 4))
  306.             (if (and (>= (car pt) (car (nth n pl))) (<= (car pt) (car (nth (1+ n) pl)))) (setq lp nil) (setq n (1+ n)))
  307.             (if (> (cadr pt) sctry) (setq p1 (nth n pl) m 0) (setq p1 (nth n ql) m 1))
  308.             )
  309.             (if (not (equal p1 p2 0.1)) (progn (drawbox) (defbox) (setq p2 p1)))
  310.             )))
  311.       )
  312.     )
  313.    (if (and (= n 0) (= m 0)) (setq fname fname) (setq fname (strcat  (strcase xh) (chr (+ 65 n (* m 4))) ".DWG")))
  314.    (command "ucs" "p")
  315.    (redraw))
  316.    (setq fname xh))
  317. )
  318.  
  319. (defun defbox(/ x1 x2 y1 y2)
  320.    (setq x1 (+ (car p1) dxx) x2 (+ x1 ddx))
  321.    (setq y1 (+ (cadr p1) dyy) y2 (+ y1 ddy))
  322.    (setq ll (list x1 y1) lr (list x2 y1))
  323.    (setq ul (list x1 y2) ur (list x2 y2))
  324.    (drawbox)
  325. )
  326.  
  327. (defun drawbox()
  328.    (grdraw ll lr -1) (grdraw lr ur -1)
  329.    (grdraw ur ul -1) (grdraw ul ll -1)
  330. )
  331.