home *** CD-ROM | disk | FTP | other *** search
/ BUG 15 / BUGCD1998_06.ISO / aplic / felixcad / fcaddata.z / TEXTOUT.LSP < prev    next >
Lisp/Scheme  |  1996-09-23  |  4KB  |  115 lines
  1. ;;; TEXTOUT.LSP
  2. ;;; ======================================================================
  3. ;;; Text Utilility TEXTOUT. Write drawing text lines to text file.
  4. ;;; Provided by Felix Computer Aided Technologies GmbH 1996 as Lisp Sample
  5. ;;; ======================================================================
  6. ;;; DESCRIPTION:
  7. ;;; The utility TEXTOUT allows to write text selected in the drawing to
  8. ;;; an ASCII file.
  9. ;;; The routine checks, if the specified file already exists. In the case
  10. ;;; that it exists, the selected text may be appended to the file, if 
  11. ;;; desired. 
  12. ;;; ======================================================================
  13. ;;; SAMPLE FOR:
  14. ;;;   alert, gefiled, open, close
  15. ;;;   ssget, sslength, ssname, entget, ...
  16. ;;; ======================================================================
  17.  
  18.  
  19. (defun C:TEXTOUT ( / *ERROR* write_mode ss n e pf fn msg1 msg2 t_lines)
  20.  
  21.   (if (> (getvar "ACTDB") -1) (progn
  22.     ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
  23.     (defun *ERROR* (msg)        
  24.         (setq *ERROR* nil)
  25.         (princ) 
  26.     ) 
  27.     ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
  28.     (setq fn (GETFILED "Export Text" "" "txt" 4))
  29.     (if fn (progn
  30.       (if (setq pf (OPEN fn "R"))
  31.         (progn
  32.           (CLOSE pf)    ;;; close file if open
  33.           (setq msg1 (strcat 
  34.                "File already exists: "
  35.                fn
  36.                "\n\nReplace file?"
  37.           ))
  38.           (setq msg2 (strcat 
  39.                "File already exists: "
  40.                fn
  41.                "\n\nAppend lines to file?"
  42.           ))
  43.           (if (ALERT msg1 "Export Text" "QUESTION")   ;;; returns T or nil
  44.               (setq write_mode "W")
  45.               (if (ALERT msg2 "Export Text" "QUESTION")
  46.                   (setq write_mode "A")
  47.                   (progn
  48.                     (setq write_mode nil)
  49.                     (ALERT
  50.                       "Text Export canceled.\nFile left unchanged!"
  51.                       "Export Text"
  52.                       "INFORMATION"
  53.                     )
  54.                   )
  55.                )
  56.            )
  57.         )
  58.         ;;; ### ELSE: Open filename in write mode - to check if filename is valid
  59.         (if (setq pf (open fn "W"))
  60.              (progn
  61.                (close pf)
  62.                (setq write_mode "W")
  63.              )
  64.              (progn
  65.                 (ALERT
  66.                    (strcat 
  67.                       "Invalid filename or path specification: \n" 
  68.                       fn
  69.                    )
  70.                    "Export Text"
  71.                    "EXCLAMATION"
  72.                 )
  73.                 (setq write_mode nil)
  74.              )
  75.         )
  76.       )
  77.       ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  78.       (if write_mode (progn
  79.           (princ "Select text lines... ")
  80.           (if (setq ss (ssget))
  81.              (progn
  82.                (if (setq pf (open fn write_mode)) (progn
  83.                    (setq n 0 t_lines 0)
  84.                    (repeat (sslength ss)
  85.                      (setq e (entget (ssname ss n)))
  86.                      (if (member (cdr (assoc 0 e)) '("TEXT" "ATTRIB"))
  87.                          (progn
  88.                            (write-line (cdr (assoc 1 e)) pf)
  89.                            (setq t_lines (1+ t_lines))
  90.                          )
  91.                      )                              
  92.                      (setq n (1+ n))             
  93.                    )
  94.                    (close pf)
  95.                    (princ (strcat 
  96.                       (itoa t_lines) " lines written to file: " 
  97.                       fn "!"
  98.                    ))
  99.                  ))  ; if
  100.              )      ; progn
  101.              (princ "No text has been selected!")
  102.           ) ; if
  103.        ))   ; if progn
  104.     ))      ; if progn
  105.     (setq *ERROR* nil)  ;;; Restore System Error Handling
  106.   )) ;; ACTDB
  107.   (princ)
  108. )
  109. ;;; =========================================================================
  110. (princ "Command TEXTOUT loaded.") 
  111. (setfunhelp "C:TEXTOUT" "TEXTOUT" "fcad")
  112. (terpri)
  113. (princ)
  114.  
  115.