[编程交流] 节点和距离提取

(defun c:Test (/ dir fNme pts coords)
 ; THARWAT Oct. 31.2010
 (defun *error* (msg)
  (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
   (princ (strcat "\nError: " msg))
 )
)
 (vl-load-com)
 (setq dir "D:\\My Folder")
 (vl-mkdir dir)
 (setq fNme (open "D:/My Folder/coordinates.txt" "w"))
   (while
     (setq pts (getpoint "\n Specify point :")
       )
   (setq coords
      (write-line
             (strcat (rtos (car pts) 2)
             ","
                 (rtos (cadr pts) 2)
                 ","
            (rtos (caddr pts) 2))
         fNme)
     )
     )
   (close fNme)
 (princ)
 )

(defun C:nod-out  (/ FILE FUNC ENTITY ENTTYP TEXTMT)
  (setq blank " ")
 (if (= FNAME NIL)
   (setq FNAME
          (getfiled
            "Select the text file for extract txt: "
            "c:/"
            "txt"
            1))
   (setq FUNC
          (getstring
            (strcat
              "[data to be stored in "
              FNAME
              "]"
              "/Change file/<press Enter or Right-click to proceed>:")))
   )
 (if (= FUNC "c")
   (setq FUNC "C"))
 (if (= FUNC "C")
   (setq FNAME
          (getfiled
            "Select the text file for extract txt: "
            "c:/"
            "txt"
            1)))
 (while (/= FNAME NIL)
   (setq ENTITY
          (car
            (entsel
              "\nPress `Esc` to exit, or select NODE.")))
   (if (/= ENTITY NIL)
     (progn
       (setq ENTTYP (cdr (assoc 0 (entget ENTITY))))
       (if (wcmatch ENTTYP "*TEXT*")
  (setq FILE (open FNAME "a"))
         (progn
           (setq TEXTMT (cdr (assoc 1 (entget ENTITY))))
           (write-line TEXTMT FILE)
           (prompt (strcat "\nLine- `" TEXTMT "` added to " FNAME))
           )
         (prompt "\nNOT A NODE POINT!")
         )
       )
     (prompt "\nNo node selected")
  (write-line blank file)
     (close FILE)
     )
   )
 )

(defun c:Test (/ ss)
 (if (setq ss (ssget '((0 . "LINE,*POLYLINE"))))
   ((lambda (i / pts lst)
      (repeat i
        (mapcar (function (lambda (a b) (setq lst (cons (list a b (distance a b)) lst))))
                (setq pts (AT:GetVertices (ssname ss (setq i (1- i)))))
                (cdr pts)
        )
      )
      (mapcar 'print lst)
    )
     (sslength ss)
   )
 )
 (princ)
)
(defun AT:GetVertices (e / p l)
 ;; Return point at each vertex of curve
 ;; e - curve to evaluate (Arc, Line, *Polyline, Spline)
 ;; Alan J. Thompson, 09.30.10
 (if e
   (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
     (repeat (setq p (1+ (fix p)))
       (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
     )
     (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e))
   )
 )
)