[编程交流] 提取三维多段线桩号an

(defun c:sz (/ ent fh fn hnd itm num obj pnt sset v vexx)
 ;; helper to get 3dpoly coordinates
 (defun 3dpoly-verts  (en / elist  lst vex)
 (if (member "AcDb3dPolyline"
      (mapcar 'cdr (entget en)))
   (progn
     (setq vex (entnext en))
     (setq elist (entget vex))
     (while (= (cdr (assoc 0 elist)) "VERTEX")
(setq lst (cons (trans (cdr (assoc 10 elist)) 1 0) lst))
(setq vex (entnext vex))
(setq elist (entget vex))
)
     )
   )
 (reverse lst)
 )
 
 ;;________________________________________________;;
 
 (setq sset (ssget '((-4 . "<OR")(0 . "POINT")
                     (0 . "POLYLINE")(-4 . "OR>"))))
 (if sset
   (progn
     (setq itm 0 num (sslength sset))
     (setq fn (getfiled "Αποθήκευση αρχείου station,Z" "" "txt" 1))
     (if (/= fn nil)
       (progn
         (setq fh (open fn "w"))
         (while (< itm num)
           (setq hnd (ssname sset itm))
           (setq ent (entget hnd))
           (setq obj (cdr (assoc 0 ent)))
           (cond
             ((eq obj "POINT")
               (setq pnt (cdr (assoc 10 ent)))
               (setq pnt (trans pnt 0 1));;**CAB
               (write-line (strcat (rtos (distance pnt pnt) 2 3) ","    ; i don't know how to give the distanse
                                      (rtos (caddr pnt) 2 3)) fh)
             )
             ((= obj "POLYLINE")
       (setq v hnd)
       (setq vexx (3dpoly-verts v ))
       (foreach pnt vexx
               (write-line (strcat (rtos (distance pnt pnt) 2 3) ","; i don't know how to give the distanse
                              (rtos (caddr pnt) 2 3)) fh)
)               
)
             (t nil)
           )
           (setq itm (1+ itm))
         )
         (close fh)
       )
     )
   )
 )
 (princ)
)
(princ)

; pline co-ords example
(defun getcoords (ent)
 (vlax-safearray->list
   (vlax-variant-value
     (vlax-get-property
   (vlax-ename->vla-object ent)
   "Coordinates"
     )
   )
 )
)
(defun co-ords2xy ()
; convert now to a list of xy as co-ords are x y x y x y if 3d x y z x y z
(setq numb (/ (length co-ords) 2))
(setq I 0)
(repeat numb
(setq xy (list (nth i co-ords)(nth (+ I 1) co-ords) ))
(setq co-ordsxy (cons xy co-ordsxy))
(setq I (+ I 2))
)
)
; program starts here
(setq co-ords (getcoords (car (entsel "\nplease pick pline"))))
(co-ords2xy) ; list of 2d or 3d points making pline
; list xy is 2d or 3d pts 

(defun c:demo (/ e fn fo lst par parpt poly pos pre pt s)
 (prompt "\nSelect a 3DPolyline to extract Stations and Elevations to txt file: ")
 (if
   (and (setq s (ssget "_+.:E:S" '((0 . "POLYLINE") (-4 . "&") (70 . )))
 (setq fn (getfiled "Enter the output filename:" (getvar 'DWGPREFIX) "txt" 1))
 (setq pre (strcase (getstring "\nEnter station prefix:")))
   );; and
    (progn
      (setq poly (vlax-ename->vla-object (ssname s 0))
     e          (fix (vlax-curve-getEndParam poly))
     pos  0
     par  0
     lst  nil
      );; setq
      (while (/= par (1+ e))
 (setq pt  (vlax-curve-getPointAtParam poly par)
       pos (1+ pos)
 );; setq
 (if (not parpt)
   (setq lst   (cons (strcat pre (itoa pos) "," "0.000," (rtos (caddr pt) 2 3)) lst)
         parpt pt
   );; setq
   (setq lst (cons (strcat pre (itoa pos) "," (rtos (distance (list (car pt) (cadr pt)) (list (car parpt) (cadr parpt))) 2 3) "," (rtos (caddr pt) 2 3)) lst)
         parpt pt
   );; setq
 );; if
 (setq par (1+ par))
      );; while
      (if lst
 (progn
   (setq lst (reverse lst)
         fo  (open fn "w")
   );; setq
   (foreach l lst
     (write-line l fo)
   );; foreach
   (close fo)
 );; progn
      );; if
    );; progn
 );; if
 (princ)
);; demo

(defun c:demo (/ acdist e fn fo lst par parpt pdist poly pos pre pt s)
 (prompt "\nSelect a 3DPolyline to extract Stations and Elevations to txt file: ")
 (if
   (and (setq s (ssget "_+.:E:S" '((0 . "POLYLINE") (-4 . "&") (70 . )))
 (setq fn (getfiled "Enter the output filename:" (getvar 'DWGPREFIX) "txt" 1))
 (setq pre (strcase (getstring "\nEnter station prefix:")))
   );; and
    (progn
      (setq poly (vlax-ename->vla-object (ssname s 0))
     e          (fix (vlax-curve-getEndParam poly))
     pos  0
     par  0
     acdist 0.0;; <--Start accumulated distance
     lst  nil
      );; setq
      (while (/= par (1+ e))
 (setq pt  (vlax-curve-getPointAtParam poly par)
       pos (1+ pos)
 );; setq
 (if (not parpt)
   (setq lst   (cons (strcat pre (itoa pos) "," "0.000,0.000," (rtos (caddr pt) 2 3)) lst)
         parpt pt
   );; setq
   (setq lst (cons (strcat pre (itoa pos) ","
                           ;; store the partial distance at the pdist variable
                           (rtos (setq pdist (distance (list (car pt) (cadr pt)) (list (car parpt) (cadr parpt)))) 2 3)
                           ;; adding acdist and pdist, and store the accumulated distance at acdist variable
                           "," (rtos (setq acdist (+ acdist pdist)) 2 3)
                           "," (rtos (caddr pt) 2 3)) lst)
         parpt pt
   );; setq
 );; if
 (setq par (1+ par))
      );; while
      (if lst
 (progn
   (setq lst (reverse lst)
         fo  (open fn "w")
   );; setq
   (foreach l lst
     (write-line l fo)
   );; foreach
   (close fo)
 );; progn
      );; if
    );; progn
 );; if
 (princ)
);; demo

; pline example listing various properties like pts and lengths
; By Alan H 2014
(defun getcoords (ent)
 (vlax-safearray->list
   (vlax-variant-value
     (vlax-get-property
   (vlax-ename->vla-object ent)
   "Coordinates"
     )
   )
 )
)
(defun getlength (ent)
     (vlax-get-property (vlax-ename->vla-object ent) "Length")
)
(defun co-ords2xy ()
; convert now to xyz
(setq xyprin "\n") ; new line
(if (= xyz 2)
(progn
(setq I 0)
(repeat (/ len 2)
(setq x (nth i co-ords))
(setq y (nth (+ I 1) co-ords))
(setq xy (list  x y))
(setq xyprin (strcat xyprin "\n" (rtos x 2 2) "," (rtos y 2 2 )))
(setq co-ordsxy (cons xy co-ordsxy))
(setq I (+ I 2))
) ; repeat
) ; progn
) ; if
(if (= xyz 3)
(progn
(setq xyprin "\n") ; new line
(setq I 0)
(repeat (/ len 3)
(setq x (nth i co-ords))
(setq y (nth (+ I 1) co-ords))
(setq z (nth (+ I 2) co-ords))
(setq xy (list x y z))
(setq xyprin (strcat xyprin "\n" (rtos x 2 2) "," (rtos y 2 2 ) "," (rtos z 2 2 )))
(setq co-ordsxy (cons xy co-ordsxy))
(setq I (+ I 3))
) ; repeat
) ; progn
) ; if
) ; defun
; program starts here
(setq ent (car (entsel "\nPlease pick pline")))
(setq co-ords (getcoords ent ))
(setq len (length co-ords))
; check for odd even list 2d v's 3d
(setq oddeven (- (fix (/ len 2.0))(/ len 2.0))) 
(if (= oddeven 0.5)
(setq xyz 3) ; 3d pline
(setq xyz 2) ; 2d pline
)
(setq numvert (/ len xyz))
(princ (strcat "\nNumber of vertices " (rtos numvert 2 0)))
(co-ords2xy)
(princ xyprin) ; prints out points co-ords
(setq pllen (getlength))
(princ (strcat "\nActual length of pline " (rtos pllen 2 2)))
; to be done (princ segment lengths 2d)
; tobe done (princ segment lengths 3d) if different
; to be done (princ angle of segments)
; to be done (princ delta angle of segments
(princ)

(if (not parpt);; tests for parpt existence, if not, initializes the lst list with the first string
 (setq lst (cons;; to add elements to the lst list
(strcat;; to concatenate multiple strings in one
pre;; first sting element, the prefix i.e D
(itoa pos);; the prefix index
"," "0.000,0.000,";; second and third string elements, the partial and accumulated distances
(rtos (caddr pt) 2 3);; the fourth string element, the Z value
);; strcat
lst);; cons
parpt pt;; sets parpt with the pt value
);; setq
;; if the lst list is already initialized, just continues to add strings to the lst list
 (setq lst (cons;; to add elements to the lst list
(strcat;; to concatenate multiple strings in one
pre;; first sting element, the prefix i.e D
(itoa pos);; the prefix index
",";; the first comma separator
;; store the partial distance at the pdist variable
(rtos (setq pdist (distance (list (car pt) (cadr pt)) (list (car parpt) (cadr parpt)))) 2 3)
",";; the second comma separator
;; the third string element adding acdist and pdist,
;; and store the accumulated distance at acdist variable
(rtos (setq acdist (+ acdist pdist)) 2 3)
",";; the third comma separator        
(rtos (caddr pt) 2 3);; the fourth string element, the Z value
);; strcat
lst);; cons
parpt pt;; sets parpt with the pt value
);; setq
 );; if

(defun c:demo (/ e fn fo lst par parpt poly pos pre pt s)
 (prompt "\nSelect a 3DPolyline to extract Stations and Elevations to txt file: ")
 (if
   (and (setq s (ssget "_+.:E:S" '((0 . "POLYLINE") (-4 . "&") (70 . )))
 (setq fn (getfiled "Enter the output filename:" (getvar 'DWGPREFIX) "txt" 1))
     );; and
    (progn
      (setq poly (vlax-ename->vla-object (ssname s 0))
     e          (fix (vlax-curve-getEndParam poly))
     pos  0
     par  0
     lst  nil
      );; setq
      (while (/= par (1+ e))
 (if (not parpt)
   (setq lst   (cons (strcat  "," "0.000," (rtos (caddr pt) 2 3)) lst)
         parpt pt
   );; setq
   (setq lst (cons (strcat "," (rtos (setq acdist (+ acdist pdist)) 2 3) "," (rtos (caddr pt) 2 3)) lst)
         parpt pt
   );; setq
 );; if
 (setq par (1+ par))
      );; while
      (if lst
 (progn
   (setq lst (reverse lst)
         fo  (open fn "w")
   );; setq
   (foreach l lst
     (write-line l fo)
   );; foreach
   (close fo)
 );; progn
      );; if
    );; progn
 );; if
 (princ)
);; demo