home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / autocad / smaker22.arj / BLOKLOC.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1989-08-21  |  3.0 KB  |  108 lines
  1. ;BLOKLOC.LSP - AZCAD Melbourne Australia
  2. ;Program to list blocks with insertion points, scale factors, 
  3. ;rotation angles (in degrees) and layers out to file suitable for use as a 
  4. ;LST file with SCRIPTmaker.
  5. ;
  6. ;TEXTLOC.LSP does the same thing for text items.
  7. ;
  8. (defun C:BLOKLOC (/ P M S N F CDATE E IP)
  9.   (setq P (ssget))
  10.   (if P
  11.     (progn
  12.       (setq M 0
  13.         S 0
  14.         N (sslength P)
  15.         F (open "Blox.LST" "w")
  16.         CDATE (rtos (getvar "cdate")))
  17.       (write-line
  18.         (strcat
  19.           ";BLOX.LST - created "
  20.           (substr CDATE 7 2)
  21.           "-"
  22.           (substr CDATE 5 2)
  23.           "-"
  24.           (substr CDATE 1 4)
  25.           " at "
  26.           (substr CDATE 10 2)
  27.           ":"
  28.           (substr CDATE 12 2))
  29.         F)
  30.       (write-line "#5" F)
  31.       (while (< M N)
  32.         (if (= "INSERT" (cdr (assoc 0 (setq E (entget (ssname P M))))))
  33.           (progn
  34.             (setq IP (strcat
  35.                 (cdr (assoc 2 E))
  36.                 ","
  37.                 (chr 34)
  38.                 (rtos (cadr (assoc 10 E)))
  39.                 ","
  40.                 (rtos (caddr (assoc 10 E)))
  41.                 ","
  42.                 (rtos (cadddr (assoc 10 E)))
  43.                 (chr 34)
  44.                 ","
  45.                 (rtos (cdr (assoc 41 E)))
  46.                 ","
  47.                 (rtos (cdr (assoc 42 E)))
  48.                 ","
  49.                 (rtos (/ (* (cdr (assoc 50 E)) 180.0) pi))
  50.                 ","
  51.                 (cdr (assoc 8 E))))
  52.             (princ (strcat "\n" IP))
  53.             (write-line IP F)
  54.             (setq S (1+ S) M (1+ M)))
  55.           (setq M (1+ M))))
  56.       (close F)))
  57.   (princ (strcat "\n" (itoa S) " blocks data extracted."))
  58.   (setq P ())
  59.   (prin1))
  60. ;
  61. ;Program to list text and X,Y insertion points out to file
  62. ;
  63. (defun C:TEXTLOC (/ P M S N F CDATE E IP)
  64.   (setq P (ssget))
  65.   (if P
  66.     (progn
  67.       (setq M 0
  68.         S 0
  69.         N (sslength P)
  70.         F (open "text.LST" "w")
  71.         CDATE (rtos (getvar "cdate")))
  72.       (write-line
  73.         (strcat
  74.           ";Text.LST - created "
  75.           (substr CDATE 7 2)
  76.           "-"
  77.           (substr CDATE 5 2)
  78.           "-"
  79.           (substr CDATE 1 4)
  80.           " at "
  81.           (substr CDATE 10 2)
  82.           ":"
  83.           (substr CDATE 12 2))
  84.         F)
  85.       (write-line "#4" F)
  86.       (while (< M N)
  87.         (if (= "TEXT" (cdr (assoc 0 (setq E (entget (ssname P M))))))
  88.           (progn
  89.             (setq IP (strcat
  90.                 (cdr (assoc 1 E))
  91.                 ","
  92.                 (chr 34)
  93.                 (rtos (cadr (assoc 10 E)))
  94.                 ","
  95.                 (rtos (caddr (assoc 10 E)))
  96.                 (chr 34)
  97.                 ","
  98.                 (rtos (cdr (assoc 40 E)))
  99.                 ","
  100.                 (rtos (/ (* (cdr (assoc 50 E)) 180.0) pi))))
  101.             (princ (strcat "\n" IP))
  102.             (write-line IP F)
  103.             (setq S (1+ S) M (1+ M)))
  104.           (setq M (1+ M))))
  105.       (close F)))
  106.   (princ (strcat "\n" (itoa S) " text data extracted."))
  107.   (setq P ())
  108.   (prin1))