Get Polyline segments

[cadplayer]

Hi!

Can you help me with this routine. It contains all polylinepoints in a exceltabell and insert koordinatpunkt-block on polylinepoints.
It would be nice to become the polylinesegments with line- or arc-length.
I don´t know how can I do this.

(setq num (getint "\nSelect start number: ")); continue point number
(setq num (- num 1))
(setq ss (ssget '((0 . "LWPOLYLINE"))))
(setq i1 0)
(setq csvf (strcat (getvar "dwgprefix") (vl-filename-base (getvar "dwgname")) ".csv"))
(setq z (open csvf "w"))
(write-line
  (strcat ";" "Nr" ";" "Definition" ";" "X-koord" ";" "Y-koord") z)
(repeat (sslength ss)
  (setq ename (ssname ss i1))
  (setq edata (entget ename))
  (cond
    ((= (cdr (assoc 0 edata)) "LWPOLYLINE")
    (foreach n1 edata
      (cond
    ((= (car n1) 10)
     (setq Punktliste (cons (cdr n1) Punktliste))
     (setq num (1+ num))
     (command "insert" "koordinatpunkt" (car Punktliste) 1 1 0 (itoa NUM))
     )
    )
      )
     )
    )
  (progn
    (write-line
      (apply 'strcat (mapcar '(lambda(X) (strcat (apply 'strcat (mapcar '(lambda(Y) (strcat ";" (vl-princ-to-string Y)))X))"\n")
                )
                 Punktliste
                 )
         )
      z)
    )
  (setq i1 (1+ i1))
  )
(close z)
(getstring "\nPress Enter: ")
(startapp "C:\\Program Files (x86)\\Microsoft Office\\Office12\\EXCEL.EXE" (strcat "\"" csvf "\""))

[Tom Beauford]

I've got an old routine that labels both line or arc lwpolyline segments. It copies the lwpolyline, explodes it, gets the info of the selected segment, deletes the exploded segments, and labels the segment using a block with attributes.

Check out: http://forums.augi.com/showthread.php?t=133869

[cadplayer]

Thanks
It´s much stuff to understand. In the beginning i like it little easier.
But it´s a very good idear to copy, explode, read entitys and delete it

[fixo]

Buggy code removed
Wat for changes, please
Sorry

~'J'~

[cadplayer]

Thanks for your effort. I can learn about and have to do something...

[fixo]

You're welcome
Cheers

~'J'~

[cadplayer]

@fixo
I´ve a question: If I have en polyline med arc-elements inserts function correctly var. coors, but it works not correctly in lin
(setq pline_data (trace-pline pln bulge_list))

var pline_data is nil
Have you a answer why function trace-pline not works

I know this function transfer coordinates to excel or?

[fixo]

Upload this polyline in simple drawing
and drop it to attachments to see where
I was mistaken
(I use 2009)

~'J'~

[cadplayer]

I can´t uppload dwg-file here. Can you send me your email-adress
cadplayer@gmail.com

PS: Have you test it with an normal Polyline with arc-and-line-segemts

[fixo]

I can´t uppload dwg-file here. Can you send me your email-adress
cadplayer@gmail.com

PS: Have you test it with an normal Polyline with arc-and-line-segemts

Ok, try again
Tested just very limited

 
;load ActieX library
(vl-load-com)
;; Local defuns
(defun startnumber () ; asks user for counter
;;save all globals
(if (not *init*)(setq *init* 1))
;; save *init* as *initsave*
(setq *initsave* *init*)
;; prompt for number
(princ "\nEnter a starting number: <")
(princ *init*)
(setq *init* (getint ">: "))
; if user accepted default 
(if(not *init*)(setq *init* *initsave*))
;; return
*init*
)
 
;; group list by number of items in the sublist
 
(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
  )
 
;; get polyline vertices
 
(defun get-vexs (pline_obj / verts)
      (setq verts (vlax-get pline_obj 'Coordinates)
     verts
    (cond
      ((wcmatch (vlax-get pline_obj 'Objectname )
        "AcDb2dPolyline,AcDb3dPolyline") 
       (group-by-num verts 3)
      )
      ((eq (vlax-get pline_obj 'Objectname )
        "AcDbPolyline") 
       (group-by-num verts 2)
      )
      (T nil)
    )
)
  )
;; get bulge radius
;; math by Juergen Menzi
(defun get-radii  (p1 p2 bulge)
  (abs (/ (distance p1 p2) 2 (sin (/ (* 4 (atan (abs bulge))) 2)))))
;;get segment arc center
;;math by John Uhden
(defun get-segm-center  (pline p1 p2 bulge / cpt midc midp rad)
(setq rad (get-radii p1 p2 bulge)
      midp (vlax-curve-getpointatparam pline
       (+ (fix (vlax-curve-getparamatpoint pline p1)) 0.5))
      midc (mapcar (function (lambda (x y)(/ (+ x y) 2))) p1 p2)
      cpt (trans (polar midp (angle midp midc) rad) 0 1)
)
cpt
)
 
;;*** list to csv readable string ***777777777777777777777777777
(defun list->csv(lst sep / join)
;;arguments
;; lst -list of string like: '("CENTER" "-4612.43" "5043.47" "1787.77")
;;sep - string (separator, i.e: ",")
;;return string like "CENTER,-4612.43,5043.47,1787.77"
  (setq join (apply 'strcat (mapcar  '(lambda (x)(strcat x  sep)) lst))
              join (vl-string-right-trim sep join))
  join
  )
;;   ===============================   main part   =============================;;
(defun C:KOORPTS (/  *error* atd atq blg center cnt coords csvf csv_data datafile dirty
                      ent first firstbulge firstp i itm lastbulge lastp num pln pos prec rad)
 
  (defun *error* (msg)
  (if (and msg (not (wcmatch msg "Function cancelled,quit / exit abort,console break")))
    (princ (strcat "\nError: " msg))
  )
  (command)
  (command "_.undo" "_end")
  (setvar 'attdia 1)
  (if atq (setvar 'attreq atq))
)
  ;; change block name below
  (if (not (tblsearch "block" "koordinatpunkt"))
    (progn
    (alert "Block \"koordinatpunkt\" does not exist")
    (exit)(princ))
    )
 
(command "_.undo" "_begin")
 (setq atq (getvar 'attreq))
(setq atd (getvar 'attdia))
 
(startnumber)
 
(setq num *init*); continue point number returned from global
 
(setq cnt num);<-- store for future use
 
;; select single entity
  (setq ent (entsel "\n\t>>>\tSelect polyline\t<<<\n"))
  (if (not ent)
    (while (or (not ent)(not (eq (strcase (cdr (assoc 0 (entget (car ent))))T )"lwpolyline")))
      (princ "\nNothing or wrong object type selected, try again... ")
      (setq ent (entsel  "\n\t>>>\tYou have to pick single LWPOLYLINE only\t<<<\n")))
    )
  ;; if Esc pressed
   (if (not ent)
     (progn
       (exit)
       (princ))
    )
;; if selected, convert it to VLA-object
(setq pln (vlax-ename->vla-object (car ent)))
 
 ;; get coordinates
(setq coords (get-vexs pln))
 
  (setq closed (if (eq :vlax-true (vla-get-closed pln))
                 t
                 nil)
        )
;;insert labels
(setvar 'attreq 1)
(setvar 'attdia 0)
  ;; change block name below
(foreach pt coords
(command "insert" "koordinatpunkt" (trans pt 1 0) "1"  "0" (itoa num))
(setq num (1+ num))
 
  )
(setq prec 3) ;<-- set number of decimals (precision) for csv here
(setq dirty nil);debug only
(setq i 0)
(foreach p coords
  (setq blg (vla-getbulge pln i))
  (setq dirty (cons (if (not closed)
                             (if (and (< i (1- (length coords))) (> (abs (setq blg (vla-getbulge pln i))) 0))
                      (cons p blg)
                      p
                    )
                          (if (> (abs (setq blg (vla-getbulge pln i))) 0)
                      (cons p blg)
                      p
                    ))  
                    dirty
              )
  )
  (setq i (1+ i))
)
 
(setq *init* (+ *init* i));<-- store last number to global for the next polyline, if that's needs
(setq dirty (reverse dirty))
(setq dirty (apply 'append
                   (mapcar (function (lambda (x)
                                       (if (listp (cdr x))
                                         (list x)
                                         (append (list (car x)) (list (list nil (cdr x))))
                                       )
                                     )
                           )
                           dirty
                   )
            )
)
(setq *first* dirty);debug only
;; to add some formatting for inforamtive csv data
(cond
  ;; If opened polyline
  ((not closed)
   (if (not (car (car dirty)))
     (progn
        (setq firstbulge T)
     (setq dirty (append (append (list (cadr dirty))(list (cadr dirty))) (cddr dirty)))
     ))
   (if (not (car (last dirty)))
     (progn
        (setq lastbulge T)
    (setq dirty (append (append  (reverse (cddr (reverse dirty)))(list (last dirty)))(list (nth (- (length dirty) 2) dirty))))
     ))
 
   )
   ;; If closed polyline
 (T
  (cond
   ;; If the first closed segment has bulge
  ((not (car (car dirty)))
       (setq dirty (append  (list (last  dirty))dirty)) 
       (setq firstbulge T)
;;;       (setq lastbulge nil)
   )
 
  ;;  If the last closed segment has bulge
      ((not (car (nth(- (length dirty) 1) dirty)))
       (setq dirty (append dirty (list (car dirty)))) 
       (setq lastbulge T)
;;;       (setq firstbulge nil)
       )
  )
  )
  (T nil)
   )
(setq *second* dirty);debug only
  ;;calculate radius and center of an arc, then rebuild the data list
  (setq dirty (mapcar (function
                        (lambda (x)
                          (if (not (car x))
                            (progn (setq pos (vl-position x dirty))
                                   (setq center (get-segm-center pln (nth (1- pos) dirty) (nth (1+ pos) dirty) (last x)))
                                   (setq rad (get-radii (nth (1- pos) dirty) (nth (1+ pos) dirty) (last x)))
                                   (setq x (subst (list (car center) (cadr center)) nil x))
                                   (subst rad (last x) x)
                            )
                            x
                          )
                        )
                      )
                      dirty
              )
  )
;; build csv data
(setq i (1- cnt))
(setq csv_data nil)
(foreach tmp dirty
  (if (numberp (car tmp))
    (progn (setq itm (append (list (itoa (1+ i))) (list (rtos (car tmp) 2 prec) (rtos (cadr tmp)))))
           (setq i (1+ i))
    )
    (setq itm (append (list "CENTER")
                      (list (rtos (caar tmp) 2 prec) (rtos (cadar tmp) 2 prec) (rtos (last tmp) 2 prec))
              )
    )
  )
  (setq csv_data (cons itm csv_data))
) 
   (setq csv_data (reverse csv_data))
 
;; swap vertices numbers of bulged segment as it will be written in csv
 
  (if closed
    (progn
(if firstbulge
   (progn (setq first (car (last csv_data)))
     (setq firstp  (subst first (caar csv_data)(car csv_data)))
     (setq  csv_data (subst firstp (car csv_data)csv_data))))
 
 (if lastbulge
   (progn (setq first (caar csv_data))
     (setq lastp  (subst first (car (last csv_data))(last csv_data)))
     (setq  csv_data (subst lastp (last csv_data)csv_data))))
  )
    )
 
  ;; write data list info to excel csv
 
   (setq csvf (strcat (getvar "dwgprefix") (vl-filename-base (getvar "dwgname")) ".csv"));<-- may be change on .xls?
  (setq datafile (open csvf "W"))
  (write-line "No;X;Y;Radius"  datafile);<-- change headers here
 
 (foreach p csv_data
 
  (write-line (list->csv p ";")  datafile)
 
  )
 
       (close datafile)
  (getstring "\nPress Enter: ")
(startapp "C:\\Program Files\\Microsoft Office\\Office12\\EXCEL.EXE" (strcat "\"" csvf "\"")) ;<-- path here
(*error* nil)
  (princ)
  )
(prompt "\n\t   >>> Start command with KOORPTS   <<<")
(prin1)
;;;(C:KOORPTS);debug from console