Computing Area of a Polygon with Text Label

(defun c:car ( / o1 ipt opp parea)
(setq clyer(getvar"clayer"))
(command "layer" "m" "polyline boundary" "")
(command "layer" "c" "2" "polyline boundary" "")
(command "color" "bylayer")
(setq ipt (getpoint "\n Select Internal Point: "))
(command "-Boundary" ipt"" "")
(setq o1 (entlast))
(redraw o1 3)
(command "area" "O" "L")
(setq opp (getvar "area"))
(initget 1)
(setq parea(getpoint"\n where to put area text"))
(command "layer" "m" "area text" "")
(command "layer" "c" "81" "area text" "")
(command "color" "bylayer")
(initget 1)
(command "text" parea "1"0 (rtos opp 2 2))
(setq elast(entlast))
(command "scale" elast"" parea)
(setvar"clayer"clyer)

)

Subdividing a Polygon Parallel to a Line

(defun ang_between (p10 p11 p20 p21 / px p1 p2 l_pt l_d p ang)
(setq px (inters p10 p11 p20 p21 nil))
(cond
(px
(if (> (distance px p10) (distance px p11)) (setq p1 p10) (setq p1 p11))
(if (> (distance px p20) (distance px p21)) (setq p2 p20) (setq p2 p21))
(setq
l_pt (list px p1 p2)
l_d (mapcar 'distance l_pt (append (cdr l_pt) (list (car l_pt))))
p (/ (apply '+ l_d) 2.0)
ang (* (atan (sqrt (/ (* (- p (car l_d)) (- p (caddr l_d))) (* p (- p (cadr l_d)))))) 2.0)
)
)
(T
nil
)
)
)
(defun c:divpar ( / pt1 pt2 pt3 pt4 S1 ang1 ang2 x1 x2 ptx1 ptx2)
  (setq pt1 (getpoint "\nFirst point of baseline: "))
  (setq pt2 (getpoint pt1 "\nSecond point of baseline: "))
  (setq pt3 (getpoint pt1 "\nPoint of first adjacent side: "))
  (setq pt4 (getpoint pt2 "\nPoint of second adjacent side: "))
  (setq S1 (getreal "\nWanted area: "))
  (setq ang1 (ang_between pt1 pt2 pt1 pt3))
  (setq ang2 (ang_between pt2 pt1 pt2 pt4))
  (setq ang1 (- pi ang1) ang2 (- pi ang2))
  (setq x1
    (*
      (/
        (* (distance pt1 pt2) (sin ang1))
        (sin (+ ang1 ang2))
      )
      (1-
        (+ ;or can be "-"
          (sqrt
            (1+
              (/
                (* 2.0 S1 (sin (+ ang1 ang2)))
                (* (distance pt1 pt2) (distance pt1 pt2) (sin ang1) (sin ang2))
              )
            )
          )
        )
      )
    )
  )
  (setq x2 (/ (* x1 (sin ang2)) (sin ang1)))
  (setq ptx1 (polar pt1 (angle pt1 pt3) x2))
  (setq ptx2 (polar pt2 (angle pt2 pt4) x1))
  (command "_.line" "_none" ptx1 "_none" ptx2 "")
)

Creating Polyline from Points

(vl-load-com)
 ;;; to make a 3d polyline*******************************************
 (defun c:pol (/ adoc spc ss cnt plst 3dline)
 (setq adoc(vla-get-activedocument(vlax-get-acad-object)))
 (setq spc(vlax-get adoc
 (if (equal (getvar "cvport") 1)
 'PaperSpace
 'ModelSpace
 );_if
 )
 );_setq
 (setq ss (ssget '((0 . "POINT"))));_select only point objects
 (if ss
 (progn
 (setq cnt 0);_loop counter
 (setq plst '());_empty list
   (while (< cnt (sslength ss))
 (setq plst (cons(cdr(assoc 10(entget (ssname ss cnt))))plst));_make point list
 (setq cnt (1+ cnt));_incerase counter
     );_while
 (setq 3dline (vla-add3dpoly ;_make 3d polyline
       spc
       (vlax-safearray-fill
  (vlax-make-safearray vlax-vbDouble
  (cons 0 (1- (length (apply 'append plst)))))
  (apply 'append plst)))
       );_setq add 3dpoly
 );_progn
 );_if
 (princ)
   );_defun
 ;;; to make a 3d  spline******************************************
 (defun c:spl (/ adoc spc ss cnt plst 3dline stpt ept)
 (setq adoc(vla-get-activedocument(vlax-get-acad-object)))
 (setq spc(vlax-get adoc
 (if (equal (getvar "cvport") 1)
 'PaperSpace
 'ModelSpace
 );_if
 )
 );_setq
 (setq ss (ssget '((0 . "POINT"))))
 (if ss
 (progn
 (setq cnt 0);_loop counter
 (setq plst '());_empty list
   (while (< cnt (sslength ss))
 (setq plst (cons(cdr(assoc 10(entget (ssname ss cnt))))plst))
 (setq cnt (1+ cnt));_incerase counter
     );_while
 (setq stpt (vlax-3d-point '(0.0 0.0 0.0)));_start pt for spline
 (setq ept (vlax-3d-point '(0.0 0.0 0.0)));_end pt for spline
 (setq cline (vla-addspline
       spc
       (vlax-safearray-fill
  (vlax-make-safearray vlax-vbDouble
  (cons 0 (1- (length (apply 'append plst)))))
  (apply 'append plst))
       stpt
       ept
       )
       );_setq add 3d spline
 );_progn
 );_if
 (princ)
   );_defun

Summation of All Polylines

(defun c:PolySum ( / SelSet Item SumLength EntName )
  (if (setq SelSet (ssget '((0 . "*POLYLINE" ))))
    (progn
      (vl-load-com)
      (setq Item 0 SumLength 0 )
      (repeat (sslength SelSet )
        (setq EntName (ssname SelSet Item ) )
        (setq SumLength (+ SumLength (vlax-curve-getDistAtParam EntName (vlax-curve-getEndParam EntName ))) )
        (setq Item (1+ Item ) )
      )
      (princ (strcat "\n" (itoa Item ) " polylines, total length = " (rtos SumLength )) )
    )
    (princ "..no POLYLINE selected " )
  )
  (princ)
)

Creating Traverse Line Using Bearing,Distance

; func dms final out put variable is strdeg
; convert angles in degs to rads
(defun dtr (a)
(* pi (/ a 180.00))
)

(defun rtd (a)
(/ (* a 180.00) pi)
)
(defun arl (/ ang ctrpt dist doc endpt ent half obj pick space ss1 ss2 stpt delta endang startang)
(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object))
space (if (= (getvar "cvport") 1)
(vla-get-paperspace doc)
(vla-get-modelspace doc)
)
)

(setq ss2 (ssget "L" '((0 . "LINE"))))


(setq obj (vlax-ename->vla-object (ssname ss2 0))
pick (vlax-get obj 'endpoint)
)

(setq half (/ (vla-get-length obj) 2.0)
dist (vlax-curve-getdistatpoint obj
(vlax-curve-getclosestpointto obj pick)))
(if (< half dist)
(setq stPt (vlax-get obj 'startpoint)
endPt (vlax-get obj 'endpoint)
)
(setq stPt (vlax-get obj 'endpoint)
endPt (vlax-get obj 'startpoint)
)
)
(setq rad (getdist endPt "\nRadius of arc: ")
ang (angle stPt endPt)
ctrPt (polar endPt (- ang (/ pi 2)) rad)
startang (+ pi (- ang (/ pi 2)))
delta (getangle "\nDelta or Enter to input arc length: ")
)
(if (= delta nil)
(progn
(setq arc (getreal "\nEnter Arc Length: ")
delta (* (/ arc rad) (/ 180 pi))
delta(abs (* pi (/ delta 180.0))))))


(if (minusp rad)
(setq startang (angle ctrPt endPt)
endang (+ startang delta))
(setq endang (angle ctrPt endPt)
startang (- startang delta))
)
(vlax-invoke space 'addarc ctrPt (abs rad) startang endang)
(setq curveobj (vlax-ename->vla-object (entlast))
endpoint (vlax-curve-getStartPoint curveobj)
startpoint (vlax-curve-getendPoint curveobj))
)

(princ)






(defun dms ()
(setq deg (getreal "\nEnter degs: "))
(if (= deg nil)
(setq deg 0))
(setq mins (getreal "\nEnter mins: "))
(if (= mins nil)
(setq mins 0))
(setq sec (getreal "\nEnter secs: "))
(if (= sec nil)
(setq sec 0))
(setq ang_degs (+ deg (/ mins 60.0) (/ sec 3600.0))))

;error trapper
(defun c:trav (/ *error*)
(setq b (getvar "osmode"))

(defun *Error* (Err)
(cond
(or
(not Err)
(member Err (quote ("console break" "Function cancelled" "quit
/ exit abort")))
)
)
(princ (strcat "\nError: " Err))

(if b
(setvar "osmode" b)
)

(princ)
)



(setq b (getvar "osmode"))
(setvar "osmode" 0)
(graphscr)
(setq Stpt (Getpoint "\nPick starting point or Enter for Lastpoint: "))
(if (null stpt)(setq stpt (getvar "LASTPOINT")))

(while (setq d (getstring "\nEnter Distance or [Arc]: "))
(if (= (strcase d) "A")
(progn
(arl)
(if (minusp rad)
(setvar "lastpoint" startpoint)
(setvar "lastpoint" endpoint))
(c:trav))
(progn
(setq d (atof d))
(print "4=NW | 1=NE")
(print "-----+----- 5=Last bearing")
(print "3=SW | 2=SE Enter quadrant: ")
(initget "1 2 3 4 5")
(setq quad (atof (getKword)))
(if (= quad 5)(setq bear bear)
(progn
(dms)
(cond ((= quad 1)(setq bear (- 90.0 ang_degs)))
((= quad 2)(setq bear (+ 270.0 ang_degs)))
((= quad 3)(setq bear (- 270.0 ang_degs)))
((= quad 4)(setq bear (+ 90.0 ang_degs)))
); end cond
); end progn
); end if
))




(setq newpt (polar stpt (dtr bear) d))
(command "LINE" stpt newpt "")
(setq stpt newpt)
(setvar "LASTPOINT" newpt)

(cond
((= quad 1) (princ (strcat "N" (rtos deg 2 0) "-" (rtos mins 2 0) "-" (rtos sec 2 0) "E" " " "Dist=" (rtos d 2 2))))
((= quad 2) (princ (strcat "S" (rtos deg 2 0) "-" (rtos mins 2 0) "-" (rtos sec 2 0) "E" " " "Dist=" (rtos d 2 2))))
((= quad 3) (princ (strcat "S" (rtos deg 2 0) "-" (rtos mins 2 0) "-" (rtos sec 2 0) "W" " " "Dist=" (rtos d 2 2))))
((= quad 4) (princ (strcat "N" (rtos deg 2 0) "-" (rtos mins 2 0) "-" (rtos sec 2 0) "W" " " "Dist=" (rtos d 2 2))))
((= quad 5) (princ "\nUsed Last Bearing" ))
(t nil)

)

) ; end while
(*error* nil)
)

Labeling Elevation of a Point

(defun c:Pointlabel (/ #SS #Ent)
(and (setq #SS (ssget '((0 . "POINT"))))
(foreach x (vl-remove-if 'listp (mapcar 'cadr (ssnamex #SS)))
(setq #Ent (entget x))
(entmakex (list
'(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
'(71 . 4)
;;(cons 50 (/ pi 4.))
(assoc 10 #Ent)
(cons 1 (rtos (caddr (cdr (assoc 10 #Ent))) (getvar "lunits") 2))
) ;_ list
) ;_ entmakex
) ;_ foreach
) ;_ and
(princ)
) ;_ defun