Originally Posted by
diroscan198177
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
Code:
;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