tente esta aqui
;This lisp is developed as part of Survey Drawing project, which aims to help people prepare survey drawings easily.
;You may find more such lisps at www.surveydrawing.net and www.esurveying.net
(defun C:RDgn()
(vl-load-com)
(cre_lay "LedMark" 3) ;Create 'LedMark' Layer with Green Color
(cre_lay "Working" 141) ;Create 'Working' Layer with Color Number 141
(setq rdSpeed(getstring "\nType the default Speed:"))
(setq cur_cntr 1)
(cond ((setq polysegs (getPolySegs))
(setq segCntr 0)
(foreach seg polysegs
(setq segCntr(1+ segCntr))
(cond ((not (zerop (cadr seg)))
(setq curSeg segCntr)
(if (blkExists "CDetails")
(princ)
(CCDetails)
)
(getArcDetails seg)
)
)
)
)
)
(princ)
)
(princ "\nType \"RDgn\" at the command prompt") (princ)
(defun getPolySegs(/ ent entl p1 pt bulge seg ptlst)
(setvar "ERRNO" 0)
(while (and (not ent) (/= (getvar "ERRNO") 52))
(if (and (setq ent (car (entsel "\nSelect polyline: "))) (/= (cdr (assoc 0 (setq entl (entget ent)))) "LWPOLYLINE"))
(setq ent nil)
)
)
(cond (ent
(setq obj(vlax-ename->vla-object ent))
(if (= (logand (cdr (assoc 70 entl)) 1) 1) (setq p1 (cdr (assoc 10 entl))))
(while (setq entl (member (assoc 10 entl) entl))
(if (and pt bulge)
(setq seg (list pt bulge))
)
(setq pt(cdr (assoc 10 entl)))
(setq bulge (cdr (assoc 42 entl)))
(if seg
(progn
(setq seg(append seg (list pt)))
(setq ptlst(cons seg ptlst))
)
)
(setq entl (cdr entl)
seg nil
)
)
)
)
(if p1 (setq ptlst (cons (list pt bulge p1) ptlst)))
(reverse ptlst)
)
(defun getArcDetails (segment)
(mapcar 'set '(p1 bulge p2) segment)
(setq stPt p1)
(setq enPt p2)
(setq theta (* 4.0 (atan (abs bulge))))
(setq c (distance p1 p2))
(setq s (* (/ c 2.0) (abs bulge)))
(cond ((not (equal bulge 0.0 1E-6))
(setq cby2 (/ c 2.0))
(setq r(/ (+ (expt cby2 2.0) (expt s 2.0)) (* s 2.0)))
(setq gamma (/ (- pi theta) 2.0))
(setq phi(if (>= bulge 0) (+ (angle p1 p2) gamma) (- (angle p1 p2) gamma)))
(setq p(polar p1 phi r))
(setq ins_Pt(FindTanPoint p stPt enPt))
(setq find_1(strcat "Curve: " (itoa cur_cntr)))
(setq cur_cntr(1+ cur_cntr))
(setq find_2(GetExtAngle stPt p enPt))
(setq find_2(rtos (/ (* find_2 180) pi) 2 3))
(setq find_3(rtos r 2 3))
(setq find_4 "0")
(setq stDist(vlax-curve-getDistAtParam obj (1- curSeg)))
(setq find_5(rtos stDist 2 3))
(setq enDist(vlax-curve-getDistAtParam obj curSeg))
(setq find_6(rtos enDist 2 3))
(setq tot_dist(- enDist stDist))
(setq find_7(rtos tot_dist 2 3))
(command "._INSERT" "CDetails" ins_Pt "1" "1" "0" find_1 find_2 find_3 find_4 find_5 find_6 find_7 rdSpeed)
(setq leadPt(polar ins_Pt (* pi 1.5) 20))
(setq leadPt2(polar leadPt 0 2))
(setq leadPt(polar leadPt 0 -6))
(CLeader leadPt2 leadPt p)
)
(T (princ "\n Segment has no arc info"))
)
(princ)
)
;Function to find Intersection of Tangents point
(defun FindTanPoint(cent start end)
(command "._line" cent start "")
(cpl (entlast) "Working")
(command "._line" cent end "")
(cpl (entlast) "Working")
(setq fe_ang1 (+ (angle cent start)(/ pi 2)))
(setq fe_p1 (polar start fe_ang1 1))
(setq fe_ang2 (- (angle cent end)(/ pi 2)))
(setq fe_p2 (polar end fe_ang2 1))
(setq fe_pc (inters start fe_p1 end fe_p2 nil))
(command "._line" start fe_pc "")
(cpl (entlast) "Working")
(command "._line" end fe_pc "")
(cpl (entlast) "Working")
(setq return fe_pc)
)
;Fuction to Create Leader Line
(defun CLeader(inP firLPo secLPo)
(setq ang1(angle firLPO secLPo))
(setq angPrint(/ (* ang1 180) pi))
(command "._Leader" inP firLPo secLPo "A" "" "N")
(cpl (entlast) "LedMark")
)
;Function to Create Attribute Block to Insert Curve Details
(defun CCDetails()
(ReadAndSetInsUnits)
(Setvar "AFLAGS" 0)
(cre_lay_set "CDetails" "7")
(command "._ATTDEF" "" "CNAME" "CNAME" 0 "J" "BL" "50,-5" "2.50" 0)
(setq 1ent(entlast))
(command "._ATTDEF" "" "DANGLE" "DANGLE" 0 "J" "BL" "50,-11" "2.50" 0)
(setq 2ent(entlast))
(command "._ATTDEF" "" "CRADIUS" "CRADIUS" 0 "J" "BL" "50,-17" "2.50" 0)
(setq 3ent(entlast))
(command "._ATTDEF" "" "TLENGTH" "TLENGTH" 0 "J" "BL" "50,-23" "2.50" 0)
(setq 4ent(entlast))
(command "._ATTDEF" "" "STARTCH" "STARTCH" 0 "J" "BL" "50,-29" "2.50" 0)
(setq 5ent(entlast))
(command "._ATTDEF" "" "ENDCH" "ENDCH" 0 "J" "BL" "50,-35" "2.50" 0)
(setq 6ent(entlast))
(command "._ATTDEF" "" "CLENGTH" "CLENGTH" 0 "J" "BL" "50,-41" "2.50" 0)
(setq 7ent(entlast))
(command "._ATTDEF" "" "RSPEED" "RSPEED" 0 "J" "BL" "50,-47" "2.50" 0)
(setq 8ent(entlast))
(PlaceTextH "5,-5" 0 "Curve Name" 0 "BL" 2.5)
(setq 21ent(entlast))
(PlaceTextH "5,-11" 0 "Deflection Angle" 0 "BL" 2.5)
(setq 22ent(entlast))
(PlaceTextH "5,-17" 0 "Circular Radius" 0 "BL" 2.5)
(setq 23ent(entlast))
(PlaceTextH "5,-23" 0 "Transition Length" 0 "BL" 2.5)
(setq 24ent(entlast))
(PlaceTextH "5,-29" 0 "Starting Chainage" 0 "BL" 2.5)
(setq 25ent(entlast))
(PlaceTextH "5,-35" 0 "Ending Chainage" 0 "BL" 2.5)
(setq 26ent(entlast))
(PlaceTextH "5,-41" 0 "Circular Curve Length" 0 "BL" 2.5)
(setq 27ent(entlast))
(PlaceTextH "5,-47" 0 "Road Speed" 0 "BL" 2.5)
(setq 28ent(entlast))
(Command "Line" "2,0" "72,0" "")
(setq 41ent(entlast))
(Command "Line" "2,-6" "72,-6" "")
(setq 42ent(entlast))
(Command "Line" "2,-12" "72,-12" "")
(setq 43ent(entlast))
(Command "Line" "2,-18" "72,-18" "")
(setq 44ent(entlast))
(Command "Line" "2,-24" "72,-24" "")
(setq 45ent(entlast))
(Command "Line" "2,-30" "72,-30" "")
(setq 46ent(entlast))
(Command "Line" "2,-36" "72,-36" "")
(setq 47ent(entlast))
(Command "Line" "2,-42" "72,-42" "")
(setq 48ent(entlast))
(Command "Line" "2,-48" "72,-48" "")
(setq 49ent(entlast))
(Command "Line" "2,0" "2,-48" "")
(setq 61ent(entlast))
(Command "Line" "47,0" "47,-48" "")
(setq 62ent(entlast))
(Command "Line" "72,0" "72,-48" "")
(setq 63ent(entlast))
(command "._Block" "CDetails" "0,0" 1ent 2ent 3ent 4ent 5ent 6ent 7ent 8ent 21ent 22ent 23ent 24ent 25ent 26ent 27ent 28ent 41ent 42ent 43ent 44ent 45ent 46ent 47ent 48ent 49ent 61ent 62ent 63ent "")
(command "._layer" "s" 0 "")
(SetInsUnitsBack)
(princ)
)
;Function to Find Exerior Angle
(defun GetExtAngle ( pnt1 pnt2 pnt3 )
( (lambda ( a ) (min a (- (+ pi pi) a)))
(rem (+ pi pi (- (angle pnt2 pnt1) (angle pnt2 pnt3))) (+ pi pi))
)
)
;Function to Create a Layer with given color
(defun Cre_Lay(lay_layn lay_laycol)
(if (= (tblsearch "Layer" lay_layn) nil)
(command "._Layer" "n" lay_layn "c" lay_laycol lay_layn "")
(command "._Layer" "t" lay_layn "on" lay_layn "c" lay_laycol lay_layn "")
)
(princ)
)
;Function to Create a Layer and set it as current Layer
(defun Cre_Lay_Set(lay_layn lay_laycol)
(if (= (tblsearch "Layer" lay_layn) nil)
(command "._Layer" "n" lay_layn "c" lay_laycol lay_layn "s" lay_layn "")
(command "._Layer" "t" lay_layn "on" lay_layn "c" lay_laycol lay_layn "s" lay_layn "")
)
)
;Function to Find wheather a Particular Block Exists in the current drawing
(defun blkExists(blk_name)
(setq blklist(tblsearch "Block" blk_name))
(if (= blklist nil)
(setq return nil)
(setq return T)
)
)
;Function to Change the Layer of Specified Entity to Specified Layer
(defun CPL(ent entlay)
(command "._change" ent "" "p" "layer" entlay "")
)
;Function to Read Insertion Units
(defun ReadAndSetInsUnits()
(setq inU(getvar "INSUNITS"))
(if (= inU nil)
(setq oldInsUnit 99)
(progn
(setq oldInsunit inU)
(setvar "INSUNITS" 0)
)
)
(setq return oldInsUnit)
)
;Function to Set Back the Original Insertion Units
(defun SetInsUnitsBack()
(if (= oldInsUnit nil)
(progn
)
(progn
(if (= oldInsUnit 99)
(progn
)
(progn
(setvar "INSUNITS" oldInsUnit)
)
)
)
)
(princ)
)
;Function to place the text at given point
(Defun PlaceTextH(InIns InAng InText InLay InJust txtHe)
(setq ang(* (/ InAng pi) 180))
(if (and (>= ang 90) (<= ang 270))
(setq ang(+ ang 180))
)
(setq ang(rtos ang))
(setq txg (cdr (assoc 40 (tblsearch "STYLE" (GETVAR "TEXTSTYLE")))))
(if (> txg 0)
(command "._Text" "j" InJust InIns ang InText)
(command "._Text" "j" InJust InIns txtHe ang InText)
)
(setq laEnt(entlast))
(command "._Change" laEnt "" "P" "La" InLay "")
)
