Topic: calculate an area with a parallel line

[gile]

Hi,

Here's a quick and dirty, l1 and l2 have to be vla-objects (IAcadLine)

Code: [Select]

(defun area (l1 l2)
  (vl-load-com)
  (/
    (*
      (+ (vla-get-Length l1) (vla-get-Length l2))
      ((lambda (p)
(distance p (vlax-curve-getClosestPointTo l2 p T))
       )
(vlax-curve-getStartPoint l1)
      )
    )
    2.
  )
)

[TopoWAR]

hello, here asking for your valuable help.
routine does not work well when calculating 5000m2
anyone can help me to correct it?
thanks

Code: [Select]

(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:divarea ( / 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 "")
)
Please see the example

[jvillarreal]

Here's a rewrite, hopefully avoiding several errors:
*EDIT* - Added Comments

Code: [Select]

;; Local defun: angle from three points, as interior value (dgorsman)
(defun get< ( pt1 vertex pt2 / return_angle angle1 angle2 )
 (if
  (< (setq return_angle (- (angle vertex pt1) (angle vertex pt2))) 0)
   (setq return_angle (+ (* pi 2) return_angle)))
 (min (- (* pi 2) return_angle) return_angle)
)

(defun AddLWPline (spc pts);(cmwade77)
 (setq pts (apply 'append (mapcar '(lambda (pt) (list (car pt) (cadr pt))) pts))
   pts (vlax-make-variant
    (vlax-safearray-fill
     (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pts))))
     pts)))
 (vla-addlightweightpolyline spc pts)
)
;-----------------------------------------------------------------------------------------
;(jvillarreal)
(defun c:CA ( / Doc Mspc pt1 pt2 pt3 pt4 ang1 tanang1 ang2 tanang2
                a b num1 DesiredArea div AreaNumber a1 a2 PerpDist)
(vl-load-com)
(while (not pt1)
       (setq pt1 (getpoint "\nSelect 1st Base Point:")))
;Require distance btwn base pts
(while (or (not pt2)(zerop (setq b (* 2 (distance pt1 pt2)))))
       (setq pt2 (getpoint "\nSelect 2st Base Point:")))
;Require distance/angle btwn pt1&pt3
(while (or (not pt3)(zerop (distance pt1 pt3))
       (zerop (rem (- (angle pt1 pt2)(angle pt1 pt3)) pi)))
       (setq pt3 (getpoint pt1 "\nPoint on 1st Adjacent Side:")))
;Require distance/angle btwn pt2&pt4
(while (or (not pt4)(zerop (distance pt2 pt4))
       (zerop (rem (- (angle pt2 pt1)(angle pt2 pt4)) pi)))
       (setq pt4 (getpoint pt2 "\nPoint on 2nd Adjacent Side:")))

(setq Doc (vla-get-activedocument (vlax-get-acad-object))
      Mspc (vla-get-modelspace Doc)
;save angles for polar projection
      a1 (angle pt1 pt3) a2 (angle pt2 pt4)
;Use interior angle to determine addition or subtraction of triangular area(s)
      ang1 (- (get< pt3 pt1 pt2)(/ pi 2))
      tanang1  (/ (sin ang1)(cos ang1));right triangle base/height
      ang2 (- (get< pt1 pt2 pt4)(/ pi 2))
      tanang2 (/ (sin ang2)(cos ang2))
      a (+ tanang1 tanang2)
      num1 (if (not (equal a 0 1e-10))(/ (expt b 2) (* -8 a)));trapezoid?
;If not trapezoid or rectangle, area is a parallelogram
;Area of a parallelogram = base * height
;Calculate perpedicular distance from pt2 to "pt1->pt3 line" as base,
; height will then be required distance along "pt1->pt3 line"
      PerpDist (if (and (not num1)(not (zerop (- ang1 ang2))))(* b 0.5 (sin (- (/ pi 2)(abs ang1))))))
;Require valid Area
;Area greater than 0 entered?
(while (or (not DesiredArea)(zerop DesiredArea)
;within limit if one exists?
       (not (if (< num1 0)(> DesiredArea num1)(< DesiredArea num1))))
 (setq DesiredArea nil
       DesiredArea
        (getreal
          (if num1;if limit exists, notify user
            (strcat "\nEnter Area" (if (< num1 0) " GREATER than " " LESS than ")
              (rtos num1 2 20) ":")
            "\nEnter Area:"))))
;Prompt for valid Number of areas
(setq AreaNumber
;Check for limit
 (if (or (not num1)(< DesiredArea 0 num1)(< num1 0 DesiredArea)(>= (setq div (/ num1 DesiredArea)) 2))
   (getint
    (strcat "\nEnter Number of Areas to create:"
     (if (>= div 2);if limit exists, notify user
       (strcat "(1-" (itoa (fix div))")")
       ""))) 1))
;Require valid Number of areas
(if div
;prompt while limit is exceeded or invalid Number is entered
   (while (not (>= (fix div) AreaNumber 1))
          (setq AreaNumber (getint (strcat "\nMust be 1-" (itoa (fix div))":")))))

(vla-endundomark doc)
(vla-startundomark doc)
(repeat AreaNumber
  (setq b (* 2 (distance pt1 pt2))
        c (* -2 DesiredArea)
;if trapezoid, use quadratic formula to determine height
        x (if num1 (/ (- (sqrt (- (expt b 2) ( * 4 a c))) b)(* 2 a)))
;if trapezoid, calc distance along legs, else calc rectang height by area/base
        p1 (if num1 (/ x (cos ang1))(/ DesiredArea b 0.5))
;if parallelogram, acquire height by area/perpdist
        p1 (if perpdist (/ DesiredArea perpdist) p1)
        p2 (if num1 (/ x (cos ang2)) p1)
        p1 (polar pt1 a1 p1);project point
        p2 (polar pt2 a2 p2)
        ptlst (mapcar '(lambda (pt)(trans pt 1 0)) (list p1 pt1 pt2 p2))
        pt1 p1 pt2 p2)
  (vla-put-closed (AddLwpline Mspc ptlst) :vlax-true)
)
(vla-endundomark doc)
(princ)
)


[jvillarreal]

TopoWAR,

Just looked at your dwg and apparently the code works for the 90 degree angles but needs work for the parallelogram..

[TopoWAR]

jvillarreal , thank you very much for helping me, it works excellent

[jvillarreal]

No problem. I've also revised the code provided to work with your parallelogram.

[TopoWAR]

jvillarreal , I realized, works great.
use a translator from Spanish to English, blame the translator for errors