[编程交流] LISP程序读取csv文件

(defun C:ImpDes ( /
                ;;All Functions declared locally
                ImpDes:err ImpDes:sav ImpDes:res
                parsestring layouts layers
                ;;Saved variables for restore
                ocmd olderr
                ;;Local Variables
                data file fileline objad lay
                )
 (vl-load-com)
 (setq objad (vla-get-activedocument (vlax-get-acad-object)))
 ;*******************************************************************
 ; Error Handling, Save and Restore
 ;*******************************************************************
 (defun ImpDes:err (s / )
   (if (/= s "Function cancelled")
     (if (= s "quit / exit abort")
       (princ)
       (princ (strcat "\nError < " s " >"))
       );if
     );if
   (ImpDes:res);restore environment
   (princ)
   )
 ;---------------------------------------------------------
 (defun ImpDes:sav ( / )
   (vla-StartUndoMark objad)
   (setq ocmd (getvar "cmdecho")
         olderr *error*
         *error* ImpDes:err
         )
   (setvar "cmdecho" 0)
   )
 ;---------------------------------------------------------
 (defun ImpDes:res ( / )
   (setvar "cmdecho" ocmd)
   (setq *error* olderr); restore old *error* handler
   (gc);garbage collection
   (vla-EndUndoMark objad)
   (princ)
   )
 ;;******************************************************************
 ;; Local Functions
 ;;******************************************************************
 (defun parsestring ( str / res found previous)
   (setq str (vl-string-right-trim "," str)
         found (vl-string-position 44 str 0)
         previous -1
         )
   (while (and found (< found (strlen str)))
     (setq res (cons (substr str (+ 2 previous) (- found previous 1)) res)
           previous found
           found (vl-string-position 44 str (1+ previous))
           )
     )
   (setq res (cons (substr str (+ 2 previous)) res))
   (reverse res)
   )
 ;;******************************************************************
 (defun layouts ( layout )
   (if (and (not (member layout (layoutlist)))
            (/= layout "Model")
            )
     (vla-add (vla-get-layouts objad) layout)
     )
   )
 ;;******************************************************************
 (defun layers ( lay / objlay actlyr )
   (if (null (tblsearch "LAYER" lay))
     (vla-add (vla-get-layers objad) lay)
     (progn
       (setq objlay (vla-item (vla-get-layers objad) lay)
             actlyr (vla-get-name (vla-get-activelayer objad))
             )
       (vla-put-layeron objlay :vlax-true)
       (vla-put-lock objlay :vlax-false)
       (if (/= lay actlyr)
         (vla-put-freeze objlay :vlax-false)
         )
       )
     );if
   )
 ;;******************************************************************
 ;; Main Program Code
 ;;******************************************************************
 (ImpDes:sav);Save variables for error handling
 (if (and (setq file (getfiled "Design File To Import" "" "csv" 4))
          (setq file (open file "r"))
          )
   (progn
     (read-line file) ;ignore header info
     (while (setq fileline (read-line file)) ;read whole file
       (if (/= fileline "")
         (setq data (append data (list (parsestring fileline)))) ;store data
         )
       )
     (close file)
     (foreach line data
       (if (and (>= (length line) 6)
                (apply 'and
                       (mapcar
                         (function
                           (lambda ( x )
                             (> (strlen x) 0)
                             )
                           )
                         line
                         )
                       )
                );and
         (progn
           (layouts (car line))
           (layers (cadr line))
           (if (= (strcase (caddr line)) "BLOCK")
             (if (tblsearch "BLOCK" (nth 5 line))
               ;LAYOUT,LAYER,BLOCK,X-CORD,Y-CORD,BLOCKNAME
               (entmake (list '(0 . "INSERT")
                              (cons 410 (car line)) ;layout
                              (cons 8 (cadr line)) ;layer
                              (cons 2 (nth 5 line)) ;blockname
                              (cons 10 (list (atof (nth 3 line)) (atof (nth 4 line)) 0)) ;insert point
                              )
                        )
               (princ "\nBlockname does not exist in the drawing.")
               )
             ;LAYOUT,LAYER,TEXTSTYLE,X-CORD,Y-CORD,TEXTSTRING
             (entmake (list '(0 . "MTEXT")
                            '(100 . "AcDbEntity")
                            (cons 410 (car line)) ;layout
                            (cons 8 (cadr line)) ;layer
                            '(100 . "AcDbMText")
                            (cons 10 (list (atof (nth 3 line)) (atof (nth 4 line)) 0)) ;insert point
                            [color=red](cons 40 (getvar "TEXTSIZE")) ;is textheight needed?[/color]
                            (cons 1 (nth 5 line)) ;textstring
                            (cons 7 (if (tblsearch "STYLE" (caddr line)) (caddr line) (getvar "TEXTSTYLE"))) ;textstyle
                            '(90 . 3)
                            '(63 . 256)
                            '(45 . 1.15)
                            )
                      )
             );if
           );progn
         );if
       );foreach
     );progn
   );if
 (ImpDes:res);Restore variables for error handling
 );defun
(Prompt "\nTHIS ROUTINE IMPORTS DESIGN DATA FROM CSV FILE (VERSION 0.0) by C.WAKEFIELD.")
(Prompt "\nType ImpDes to run.")
(princ)

(defun c:demo (/ _delFinder collect _remd file data)
 ;;        pBe Dec 2013        ;;
[color="#006400"](defun _delFinder( str n / a b lst )
     (while (/= "" str)
           (while
         (and (<= n (strlen str))    
         (not (wcmatch (Setq a (substr str 1 n)) "*`,*")))
                      (setq n (1+ n) b a))
                     (setq lst (cons b lst)
                     str (substr str (1+ n)) 
                     n 1)
           )
     (reverse lst)
     )[/color]
;;;        cwakes' idea        ;;;
[color="#006400"](defun _layoutlist  (/ lyt ll)
(Setq lyt (dictsearch (namedobjdict) "ACAD_LAYOUT"))
(while (setq a (assoc 3 lyt))
     (setq ll  (cons (cdr a) ll)
           lyt (cdr (member a lyt))))
(cdr ll)
)    [/color]
 (setq        collect        (lambda        (f / a b opf)
          (setq opf (open f "r"))
          (read-line opf)
          (while (setq a (read-line opf))
            (setq b (cons (_delfinder a [color="#006400"][b]1[/b][/color]) b))
          )
          (close opf)
          b
        )
 )
 (setq        _remd (lambda (lst / a b)
        (while (setq a (car lst))
          (setq        b   (if        (not (member a b))
                      (cons a b)
                      b
                    )
                lst (cdr lst)
          )
        )
        b
      )
 )
 (and
   (setq
     file (getfiled "Select Data file" (getvar 'dwgprefix) "csv" 16)
   )
   (setq data (collect file))
   (foreach itm (_remd (mapcar 'car data))
     (if (and (not (member itm (_layoutlist)))
       (snvalid itm)
  )
(command "_.layout" "_New" itm)
     )
     itm
   )
   (foreach itm (_remd (mapcar 'cadr data))
     (if (and (not (tblsearch "Layer" itm))
       (snvalid itm)
  )
(entmake (list (cons 0 "LAYER")
               (cons 100 "AcDbSymbolTableRecord")
               (cons 100 "AcDbLayerTableRecord")
               (cons 2 itm)
               (cons 70 0)
         )
)
itm
     )
   )
   (foreach itm (_remd (mapcar 'caddr data))
     (if (and (not (tblsearch "Style" itm))
       (snvalid itm)
  )
(entmake (list '(0 . "STYLE")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbTextStyleTableRecord")
               (cons 2 itm)
               '(70 . 0)
               '(40 . 0.0125)        ;<-- Text height for style 
               '(41 . 0.
               '(50 . 0.0)
               '(71 . 0)
               '(3 . "ARIAL.TTF")
               '(4 . "")
         )
)
itm
     )
   )
   (foreach info data
     (entmakex
(list
  (cons 0 "TEXT")
  (cons
    10
    (setq p (list (distof (nth 3 info)) (distof (nth 4 info))))
  )
  (cons 11 p)
  (cons 8 (cadr info))
  (cons 7 (caddr info))
  '(40 . 0.0125)
  (cons 1 (nth 5 info))
  '(71 . 0)
  '(72 . 1)
  '(73 . 2)
  (cons 410 (car info))
)
     )
   )
 )
(princ)
)

(defun c:helpme ()(alert "This is debug location number 1"))