Экспорт координат X Y Z точек из AutoCada в Excel (Страница 2 из 2)

;;ptxk.lsp
;; программа снимает координаты мест пересечения полилиний
;; fixo © 2010 * all rights released
;; edited with help of 'qwerty'
(vl-load-com)
(defun C:PTXL    (/ *error*  countp datafile decs en ent filename fst hgt lstobj nump par points sp ss  textp txt_points tmp)
  (defun *error*    (msg)
  (if datafile
    (close datafile))
  
  (if msg
    (princ (strcat "\nError! " msg)))
    (command "_undo" "_end")
  
  (princ)
  )
  
  (defun emake-pt  (pt)
    (entmake
      (list
    (cons 0 "POINT")
    (cons 100 "AcDbEntity")
    (cons 100 "AcDbPoint")
    (cons 10 (trans pt 1 0));<--WCS
    (cons 8 "0")
    )
      )
    )

  (defun emake-mtext  (p1 p2 txt hgt)
    (entmake
      (list
    (cons 0 "MTEXT")
    (cons 100 "AcDbEntity")
    (cons 100 "AcDbMText")    
    (cons 10 (trans p1 1 0) )
    (cons 40 hgt)
    (cons 41 (abs (- (car p2) (car p1))))
    (cons 7 (getvar "TEXTSTYLE"))
    (cons 1 txt)
    (cons 71 4)
    (cons 72 5)
    (cons 73 1)

    )
      )
    )
(defun group-by-num (lst num / ls ret)
  (if (= (rem (length lst) num ) 0)
    (progn
      (setq ls nil)
      (repeat (/ (length lst) num)
    (repeat num (setq ls 
            (cons (car lst) ls)
          lst (cdr lst)))
    (setq ret (append ret (list (reverse ls)))
          ls nil)))
    )
ret
  )

  (command "_undo" "_begin")

  (if (setq ent (entsel "\nSelect first entity >> "))
    (if (setq ss (ssget ))
      (progn
    (vl-load-com)
    (setq fst (vlax-ename->vla-object (setq en (car ent))))
    (setq sp (vlax-curve-getclosestpointto fst (cadr ent))
          par (vlax-curve-getparamatpoint fst sp))
    (setq lstobj (mapcar 'vlax-ename->vla-object
                (vl-remove en (vl-remove-if 'listp
                   (mapcar 'cadr (ssnamex ss))))))

(setq points nil)    
  
  (setq filename (getfiled "Select a Points Data File"
                 (getvar "dwgprefix")
                 "csv"
                 1)
         )
    (if (not filename) (setq filename (strcat (getvar "dwgprefix")
               (vl-filename-base (getvar "dwgname"))
               ".csv")));<-- ( or .TXT)
    
(foreach obj lstobj
     (setq tmp (vlax-invoke obj 'intersectwith fst 0))

     (if tmp
       (if (>(length tmp) 3)
       (setq points (append points (group-by-num tmp 3) ))
       (setq points (cons tmp points))
       ))
     )
(setq points (mapcar '(lambda(pt)(trans pt 0 1))     points))
  (initget 6)
  (setq decs (getint (strcat "\nPrecision <"(rtos (getvar 'dimdec)) "> : ")))
    (if (not decs)(setq decs (getvar 'dimdec))
  )
  (setq cnt nil start nil nump nil drawp nil)
  
  (initget "Yes No")
  (setq num (getkword "\nAdd numbering? [Yes/No] <N> : "))

    (if (eq "Yes" num)
      (progn
  (initget 6)
  (setq countp (getint "\nInitial number <1> : "))
    (if (not countp)   (setq cnt 1)(setq cnt countp))
    (setq start cnt)
  (setq nump T))
      (setq cnt nil)
  )
  
 (initget "Yes No")
  (setq textp (getkword "\nDraw the text? [Yes/No] <N> : "))
  (if (eq "Yes" textp)
      (progn
    (setq drawp T)
(initget 6)
  (setq hgt (getreal (strcat "\nText height <"(rtos (getvar 'dimtxt)) "> : ")))
    (if (not hgt)  (setq hgt (getvar 'dimtxt))))
    )


    
   (setq points  (vl-sort points '(lambda (a b)
               ((if (< par (/ (vlax-curve-getendparam fst) 2))
              >
              <
              )
            (vlax-curve-getdistatpoint fst(vlax-curve-getclosestpointto fst a))
            (vlax-curve-getdistatpoint fst(vlax-curve-getclosestpointto fst b)))))
         )
    
(setq datafile (open filename "W"))

(if nump
  (progn
    (setq start cnt)
    (setq cnt (1- cnt))
    
 (setq txt_points (mapcar '(lambda(x)(setq cnt (1+ cnt))(append (list cnt) x)) points)))
  (setq txt_points points))
    
(foreach pt  txt_points
  (cond ((= 3 (length pt))
  (write-line
    
    (strcat 
        (rtos (car pt) 2 decs)
        (chr 9)
        (rtos (cadr pt) 2 decs)
        (chr 9)
        (rtos (caddr pt) 2 decs))
    datafile))
    ((= 4 (length pt))
  (write-line
    
    (strcat (itoa (car pt))
        (chr 9)
        (rtos (cadr pt) 2 decs)
        (chr 9)
        (rtos (caddr pt) 2 decs)
        (chr 9)
        (rtos (last pt) 2 decs))
    datafile)))

  )        
(close datafile)
  
(gc)
(princ "\n Records were added..")   
(alert (strcat "The point records were saved into the file:\n" filename ))
(if drawp
  (progn
(setq cnt start)

(foreach pt  points

      (emake-pt (trans (trans pt  1 0) 0 1 t))
    (emake-mtext
     (trans (trans (polar pt 0 (* hgt 0.5)) 1 0) 0 1 t)
      (trans(trans (polar pt (/ pi 4) (* hgt 10)) 1 0)0 1 t)
      (itoa cnt)
     hgt
    )

  (setq cnt (1+ cnt))
  )


 
      (vl-cmdf "_.zoom" "_O" en ""
           "_.zoom" ".5x")
    )
  )
      )
    )
      )

  (princ)
  )
(prompt "\n\t***\tType PTXL to run program")

(prin1)