(defun c:BAPK (/ *error* AT:GetSel AT:DrawX _getDist ent pnt cmd undo total add dist break)
(vl-load-com)
(defun *error* (msg)
(and cmd (setvar 'CMDECHO cmd))
(and *AcadDoc* (vla-endundomark *AcadDoc*))
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
(princ (strcat "\nError: " msg))
)
)
(defun AT:GetSel (meth msg fnc / ent)
(setvar 'ERRNO 0)
(while
(progn (setq ent (meth (cond (msg)
("\nOBJEYI SECINIZ: ")
)
)
)
(cond ((eq (getvar 'ERRNO) 7) (princ "\nHATALI SECIM,TEKRAR DENEYINIZ"))
((eq (type (car ent)) 'ENAME)
(if (and fnc (not (fnc ent)))
(princ "\nHATALI OBJE SECIMI!OBJE POLYLINE OLMALI")
)
)
)
)
)
ent
)
(defun AT:DrawX (P C)
(if (vl-consp P)
((lambda (d)
(grvecs (cons C
(mapcar (function (lambda (n) (polar P (* n pi) d)))
'(0.25 1.25 0.75 1.75)
)
)
)
P
)
(* (getvar 'viewsize) 0.02)
)
)
)
(defun _getDist (total point / dist)
(and undo (initget "Undo"))
(cond ((not (setq dist (getdist (AT:DrawX point 4)
(strcat
"\nKESILECEK ARALIGI GIRINIZ (TOPLAM= "
(rtos total)
(if undo
") [Undo]: "
"): "
)
)
)
)
)
nil
)
((eq dist "Undo") dist)
((not (< 0. dist total))
(princ (strcat "\nGIRILEN DEGER 0.0 VE " (rtos total) " ARALIGINDA OLMALIDIR!"))
(_getDist total point)
)
(dist)
)
)
(vla-startundomark
(cond (*AcadDoc*)
((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
)
)
(if (setq ent (AT:GetSel
entsel
"\nKESILECEK OBJEYI SECINIZ: "
(lambda (x)
(and (wcmatch (cdr (assoc 0 (entget (car x))))
"ARC,LINE,*POLYLINE,SPLINE"
)
(not (vlax-curve-isClosed (car x)))
)
)
)
)
(progn
(setq pnt (trans (cadr ent) 1 0)
ent (car ent)
cmd (getvar 'CMDECHO)
)
(setvar 'CMDECHO 0)
(while
(setq
dist (_getDist (setq total (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
(setq pnt
(trans (if (> (vlax-curve-getParamAtPoint
ent
(vlax-curve-getClosestPointToProjection ent pnt '(0. 0. 1.))
)
(vlax-curve-getParamAtDist ent (/ total 2.))
)
(progn (setq add total) (vlax-curve-getEndPoint ent))
(progn (setq add 0.) (vlax-curve-getStartPoint ent))
)
0
1
)
)
)
)
(if (eq dist "Undo")
(progn (vl-cmdf "_.U")
(setq ent (caar undo)
pnt (cadar undo)
undo (cdr undo)
)
)
(progn
(setq break (trans (vlax-curve-getPointAtDist ent (abs (- add dist))) 0 1))
(vl-cmdf "_.break" ent "_F" "_non" break "_non" break)
(setq undo (cons (list ent pnt) undo))
(and (zerop add) (setq ent (entlast)))
)
)
(redraw)
(foreach p (vl-remove (last undo) undo) (AT:DrawX (cadr p) 1))
)
)
)
(*error* nil)
(princ)
)