lisp to scale by moving only one side

March 30, 2020

LISP is correct in both cases: boundary is LWPOLYLINE or LINE

(defun DXF (code en) (cdr (assoc code (entget en))))
;;;=========================================================================
(defun Line (p1 p2) (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2))))
(defun Ray (po V)
    (entmakex (list (cons 0 "RAY")
                    (cons 100 "AcDbEntity")
                    (cons 100 "AcDbRay")
                    (cons 10 po)
                    (cons 11 v)
              )
    )
)
;;;=========================================================================
(defun sysvar-set (lst_setvar / strN var var_oldname n)
    (setq n 0
          lstvar_thiep nil
          lstValue_thiep nil
    )
    (repeat (/ (length lst_setvar) 2)
        (setq var         (nth n lst_setvar)
              var_oldname (strcat "oldvar_thiep" (itoa n))
        )
        (setq lstvar_thiep (append lstvar_thiep (list var)))
        (set (read var_oldname) (getvar var))
        (setq lstValue_thiep (append lstValue_thiep (list (read var_oldname))))
        (setvar var (nth (+ n 1) lst_setvar))
        (setq n (+ 2 n))
    )
)
(defun Get-Area (lst )
    (/ (apply
           '+
           (mapcar '(lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
                   lst
                   (cons (last lst) lst)
           )
       )
       2
    )
)
;;;=========================================================================
(defun SYSVAR-RESTORE ()
    (mapcar '(lambda (var value) (setvar var (eval value)))
            lstvar_thiep
            lstValue_thiep
    )
)
;;;=========================================================================
(defun CalcZ (Pt1 Pt2 Pt3 / v w)
    (setq v (mapcar '- Pt1 Pt2)
          w (mapcar '- Pt3 Pt2)
    )
    (- (* (car v) (cadr w)) (* (cadr v) (car w)))
)

;;;=========================================================================
(defun calcThiep (po1 po2 po3 po4 / bit dis m anpha beta h obj_top poS poE)
    (setq anpha_org (LM:GetInsideAngle po4 po1 po2)
          beta_org  (LM:GetInsideAngle po1 po2 po3)
    )
    (if (< dt 0)
        (setq anpha anpha_org
              beta  beta_org
        )
        (setq anpha (- pi anpha_org)
              beta  (- pi beta_org)
        )
    )
    (Setq bit (CalcZ po1 po4 po2))
    (setq dis (distance po1 po2)
          ang (angle po1 po2)
    )
    (setq m (+ (/ (cos anpha) (sin anpha)) (/ (cos beta) (sin beta))))
    (setq h  (abs (/ (- dis (sqrt (abs (- (* dis dis) (* 2 m (abs dt)))))) m)))

    
       (cond ((or (and (> bit 0) (> dt 0)) (and (< bit 0) (< dt 0)))
              (setq po5 (polar po2 (- ang (/ pi 2)) h)
                    po6 (polar po1 (- ang (/ pi 2)) h)
              )
             )
             ((or (and (> bit 0) (< dt 0)) (and (< bit 0) (> dt 0)))
              (setq po5 (polar po2 (+ ang (/ pi 2)) h)
                    po6 (polar po1 (+ ang (/ pi 2)) h)
              )
             )
       )
       (setq po_in1 (inters po5 po6 po1 po4 nil)
             po_in2 (inters po5 po6 po2 po3 nil)
       )
)
(defun makeLWPoly (lst)
    (entmakex (append (list (cons 0 "LWPOLYLINE")
                            (cons 100 "AcDbEntity")
                            (cons 100 "AcDbPolyline")
                            (cons 90 (length lst))
                      )
                      (mapcar (function (lambda (p) (cons 10 p))) lst)
              )
    )
)
(defun limS (po1 po2 po3 po4 / objL1 objL2 objR iplist)
    (line po4 po1)
    (setq objL1 (vlax-ename->vla-object (entlast)))
    (line po3 po2)
    (setq objL2 (vlax-ename->vla-object (entlast)))
    (cond ((> dt 0)
           (setq
               iplist (vlax-safearray->list
                          (vlax-variant-value (vla-intersectwith objL1 objL2 3))
                      )
           )
           (vla-delete objL1)
           (vla-delete objL2)
           (SETQ A (Get-Area (list po1 po2 iplist po1)))
          )
          ((< dt 0)
           (ray po4 (mapcar '- po2 po1))
           (setq objR (vlax-ename->vla-object (entlast)))
           (if (null (vlax-invoke objR 'IntersectWith objL2 acExtendNone))
               (PROGN (setq iplist (vlax-invoke objR
                                                'IntersectWith
                                                objL2
                                                acExtendOtherEntity
                                   )
                      )
                   (SETQ A (Get-Area (list po1 po2 iplist po4 po1)))
               )
               (PROGN (vla-delete objR)
                      (ray po3 (mapcar '- po1 po2))
                      (setq objR (vlax-ename->vla-object (entlast)))
                      (setq iplist (vlax-invoke objR
                                                'IntersectWith
                                                objL1
                                                acExtendOtherEntity
                                   )
                      )
                   (SETQ A (Get-Area (list po1 po2 po3 iplist  po1)))
               )
           )
           (vla-delete objL1)
           (vla-delete objL2)
           (vla-delete objR)
           
          )
    )
    (abs A)
)
;;;=========================================================================
(defun c:dht (/ ent1_lst        ent1    ent2    ent3    po1     po2     po3
                po4     ang1    ang2    ang3    dis     m       lstpo1  lstpo2
                lstpo3  lstpo-int1      lstpo-int2      anpha   beta    pS1
                pS2     pS3     pE1     pE2     pE3     h       bit     obj_top
                poS     poE     po_in1  po_in2  prom    Alim
               )
    (command "undo" "be")
    (sysvar-set '("cmdecho" 0 "osmode" 0))
    (defun *error* (msg)
        (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
            (princ (strcat "\n** Error: " msg " **"))
        )
        (setq dt nil)
        (acet-ui-status)
        (sysvar-restore)
        (command "undo" "en")
        (princ)
    )
    (or dt (setq dt (getcfg "AppData/trapezoid/area")) (setq dt 1000))
    (acet-ui-status (setq prom
                             (acet-str-format
                                 "\nEnter Area given for to expand (+S) or to trim (-S) <%1> : "
                                 (if (numberp dt)
                                     (rtos dt 2 3)
                                     dt
                                 )
                                 "LOOK AT"
                             )
                    )
    )
    (setq olddt dt)
    (setq dt (getreal prom))
    (if (null dt)
        (setq dt olddt)
    )
    (if (not (numberp dt))
        (setq dt (atof dt))
    )
    (acet-ui-status (setq prom
                             "\nPick a LINE (or LWPOLYLINE) edge for to expand (or to trim) area "
                    )
                    "LOOK AT"
    )
    (while
        (OR (NOT (setq ent1_lst (entsel prom)))
            (NOT (wcmatch (DXF 0 (setq ent1 (car ent1_lst))) "LINE,LWPOLYLINE"))
        )  (acet-ui-status (setq prom "Pick a LINE is not right, Please pick again")
                           "LOOK AT"
           )
           (prompt prom)
    )
    (acet-ui-status)
    (cond
        ((eq (DXF 0 ent1) "LINE")
         (acet-ui-status (setq prom "\nPick a LINE 1st edge of the trapezoid ")
                         "LOOK AT"
         )
         (while (OR (NOT (setq ent2 (car (entsel prom))))
                    (NOT (wcmatch (DXF 0 ent2) "LINE"))
                )
             (acet-ui-status
                 (setq prom "Pick a LINE is not right, Please pick again")
                 "LOOK AT"
             )
             (prompt prom)
         )
         (acet-ui-status (setq prom "\nPick a LINE 2nd edge of the trapezoid ")
                         "LOOK AT"
         )
         (while (OR (NOT (setq ent3 (car (entsel prom))))
                    (NOT (wcmatch (DXF 0 ent3) "LINE"))
                )
             (acet-ui-status
                 (setq prom "Pick a LINE is not right, Please pick again")
                 "LOOK AT"
             )
             (prompt prom)
         )
         (acet-ui-status)
         (setq po1 (vlax-curve-getStartpoint ent1) ;_bottom edge
               po2 (vlax-curve-getEndpoint ent1)
         )
         (setq pS2 (vlax-curve-getStartpoint ent2) ;_ 1st side
               pE2 (vlax-curve-getEndpoint ent2)
         )
         (setq pS3 (vlax-curve-getStartpoint ent3) ;_ 2nd side
               pE3 (vlax-curve-getEndpoint ent3)
         )
         (cond ((Equal po1 ps3 1e-2)
                (setq po4 pE3)
                (cond ((Equal po2 ps2 1e-2) (setq po3 pE2))
                      ((Equal po2 pE2 1e-2) (setq po3 pS2))
                )
               )
               ((Equal po1 pE3 1e-2)
                (setq po4 pS3)
                (cond ((Equal po2 ps2 1e-2) (setq po3 pE2))
                      ((Equal po2 pE2 1e-2) (setq po3 pS2))
                )
               )
               ((Equal po1 ps2 1e-2)
                (setq po4 pE2)
                (cond ((Equal po2 ps3 1e-2) (setq po3 pE3))
                      ((Equal po2 pE3 1e-2) (setq po3 pS3))
                )
               )
               ((Equal po1 pE2 1e-2)
                (setq po4 pS2)
                (cond ((Equal po2 ps3 1e-2) (setq po3 pE3))
                      ((Equal po2 pE3 1e-2) (setq po3 pS3))
                )
               )
         )
        )
        ((eq (DXF 0 ent1) "LWPOLYLINE")
         (setq po_pick (cadr ent1_lst))
         (setq po_closest (vlax-curve-getClosestPointTo ent1 po_pick))
         (setq para1 (fix (vlax-curve-getParamatpoint ent1 po_closest)))
         (setq paraE (vlax-curve-getEndParam ent1))
         (setq paraS (vlax-curve-getStartParam ent1))
         (setq po1 (vlax-curve-getPointAtParam ent1 para1))
         (cond ((= para1 0)
                (setq po4 (vlax-curve-getPointAtParam ent1 paraE)
                      po2 (vlax-curve-getPointAtParam ent1 (+ para1 1))
                      po3 (vlax-curve-getPointAtParam ent1 (+ para1 2))
                )
                (if (equal po1 po4 1e-3)
                    (setq po4 (vlax-curve-getPointAtParam ent1 (- paraE 1)))
                )
               )
               ((< (1+ para1) paraE)
                (setq po4 (vlax-curve-getPointAtParam ent1 (- para1 1))
                      po2 (vlax-curve-getPointAtParam ent1 (+ para1 1))
                      po3 (vlax-curve-getPointAtParam ent1 (+ para1 2))
                )
               )
               ((= (1+ para1) paraE)
                (setq po4 (vlax-curve-getPointAtParam ent1 (- para1 1))
                      po2 (vlax-curve-getPointAtParam ent1 (+ para1 1))
                      po3 (vlax-curve-getPointAtParam ent1 paraS)
                )
                (if (equal po2 po3 1e-3)
                    (setq po3 (vlax-curve-getPointAtParam ent1 (+ paraS 1)))
                )
               )
         )
        )
    )
    (setq Alim (limS po1 po2 po3 po4))
    (calcThiep po1 po2 po3 po4)
    (setvar "cecolor" "1")
    (makeLWPoly (list po1 po2 po_in2 po_in1 po1))
    (setvar "cecolor" "256")
    (if (> (abs dt) Alim)
        (cond
            ((> (+ anpha_org beta_org) pi)
             (alert
                 (acet-str-format
                     "area to expand is too large (max = %1), so this case results in an area error"
                     (rtos Alim 2 3)
                 )
             )
            )
            ((< (+ anpha_org beta_org) pi)
             (alert
                 (acet-str-format
                     "area to trim is too large (max = %1), so this case results in an area error"
                     (rtos Alim 2 3)
                 )
             )
            )
        )
    )
    (setcfg "AppData/trapezoid/area" (rtos dt 2 3))
    (SYSVAR-RESTORE)
    (command "undo" "en")
    (princ "ok")
    (princ)
)
(defun LM:GetInsideAngle ( p1 p2 p3 )
    (   (lambda ( a ) (min a (- (+ pi pi) a)))
        (rem (+ pi pi (- (angle p2 p1) (angle p2 p3))) (+ pi pi))
    )
)

Extend_Trim_Area(DHT).lsp

March 30, 2020

4 hours ago, hanhphuc said:
IMO, you can manually trim that 1st picked segment.

or some coding, store the picked point, p1 in extra variable, eg: xp
(setq xp p1 p  (trans p1 1 0) ;...snippet...;
then at the end of the code, add extra command, entmod, addvertices etc..
 (vl-cmdf "_trim" s "" (list en xp) "")
maybe has some glitches?

so i just let it as simple as possible, another problem is bulged polyline..

p/s: math formula: new area, A' = A x S² ,S=scale factor, A= max area (triangle)

try to adopt it

Sorry, but I couldn't resist this. Attached takes care of displaying the overall area and a final polyline. I've used VL as it retains all the properties of the original polyline, but would also work entmaking a new polyline, transfering properties then deleting the old.

Bulges could be a problems and also the need to stop stretching once the intersection point is reached/ the segment length is zero.

aaa-v2.lsp

March 30, 2020

15 hours ago, tranthiep said:

LISP is correct in both cases: boundary is LWPOLYLINE or LINE

(defun c:DHT ... <snippet> ...

Extend_Trim_Area(DHT).lsp 12.19 kB · 1 download

hi, this looks promising to OP's request

it can be optimized working in UCS

another math function

;; sub function for divarea
(defun area:3side ( area x p a b c  / d e f g h i j k l p ) 
;; hanhphuc 30.03.2020
;; adopted from an old programmable calculator fx-603p
;; area    - minor area to split
;; x       - distance of segment to be extended as base line 
;; p       - point of end segment 
;; a       - segment angle direction
;; b       - angle at 'p' direction
;; c       - angle direction (firstderiv) close back to segment
;; direction a -> b -> c must be CCW
;; returns 3 sides as : b -> d -> c

  (if
    (<	0.0
	(setq d	(+ pi a)
	      e	(- c b)
	      e	(- (if (>= e 0.0)
		     e
		     (+ e (* 2 pi))
		   )
		   pi
		)
	      f	(if (minusp e)
		  (- e)
		  e
		)
	      g	(/ x (sin f))

	      h	(/ (* (-	
			(* (* g (sin (- a c)))  
			    x
			    (* (sin (- b a)) 0.5)
			 )
			
			((if (minusp e) + -) Area) 
		      )
		      2.0
		      (sin (- d b))
		   )
		   (sin f)
		   (sin (- c d))
		)
	)
    )
     (progn (setq h (sqrt h)
		  i (/ h (sin (- d b)))
		  j (mapcar
		      '(lambda (k l) (list k (abs l)))
		      (list b d c)
		      (list
			(- (* i (sin (- c d))) (* g (sin (- a c))))
			(* i (sin f))
			;(- h (* g (sin (- b a))))
		      )
		    )
		  k (mapcar '(lambda (x)
			       (setq p (apply 'polar (cons p x)))
			      )
			    j
		    )
	    )
     )
  )
)

minimal tested

@dlanorh

Quote

Bulges could be a problems and also the need to stop stretching once the intersection point is reached/ the segment length is zero.

yes, known bug which parallel lines don't inters. purge or remove extra vertices

if you insist dynamic $0.02

1.update object properties using vla-get-area , vlax-curve-getarea faster? then can replace math:area

2.perhaps LM:grtext

Edited March 31, 2020 by hanhphuc
rename sub as it's part of routine 'divarea'

April 1, 2020

On 3/30/2020 at 4:39 PM, tranthiep said:

LISP is correct in both cases: boundary is LWPOLYLINE or LINE

Extend_Trim_Area(DHT).lsp 12.19 kB · 4 downloads

sorry for the late response.

thanks a lot @tranthiep for this great lisp, i've tested this lisp it work as intended most of the time but & sometime it gives error, below i'll try to explain the issues i encountered.

1. It's a minor inconvenience, this 'look at' window appears right at the centre of the screen. Plz remove it. All the command related info is already there on the commandline.

2. It works perfectly on irregular shapes. Ex. Fig A & B. But when i draw a square or rectangle with 'rectangle' command or with polyline command, lisp doesn't work instead it creates two overlapping lines adjacent to the line i picked, like in fig. C (i've moved the overlapping lines sideways so that you could see them). And gives this error

** Error: ActiveX Server returned an error: Invalid index **
Cannot invoke (command) from *error* without prior call to (*push-error-using-command*).

Converting (command) calls to (command-s) is recommended.

i hope you'll look into these issues and fix them.

once again thanks a million times this lisp will help me a lot.

Edited April 1, 2020 by xpr0
edit

April 1, 2020

This appears to have various functions re land development https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/what-is-the-problem-of-this-lisp-why-it-does-not-select-the/td-p/9414006

April 1, 2020

3 hours ago, xpr0 said:

sorry for the late response.

thanks a lot @tranthiep for this great lisp, i've tested this lisp it work as intended most of the time but & sometime it gives error, below i'll try to explain the issues i encountered.

1. It's a minor inconvenience, this 'look at' window appears right at the centre of the screen. Plz remove it. All the command related info is already there on the commandline.

2. It works perfectly on irregular shapes. Ex. Fig A & B. But when in draw a square or rectangle with 'rectangle' command or with polyline command, lisp doesn't work instead it creates two overlapping lines adjacent to the line i picked, like in fig. C (i've moved the overlapping lines sideways so that you could see them). And gives this error

** Error: ActiveX Server returned an error: Invalid index **
Cannot invoke (command) from *error* without prior call to (*push-error-using-command*).

Converting (command) calls to (command-s) is recommended.

i hope you'll look into these issues and fix them.

once again thanks a million times this lisp will me a lot.

Wow, I didn't anticipate the case of the top and bottom edges be parallel. I have fixed this lisp. But, I will check it again so that there are no more cases.

The "messages" window appears right at the centre of the screen.

If you drag the title bar of the "message" window into a any other corner, it will remember the location. The next time, it will appear there, without hindering your view.

I’ll remove, it if you don’t like

April 1, 2020

2 hours ago, tranthiep said:

Wow, I didn't anticipate the case of the top and bottom edges be parallel. I have fixed this lisp. But, I will check it again so that there are no more cases.

The "messages" window appears right at the centre of the screen.

If you drag the title bar of the "message" window into a any other corner, it will remember the location. The next time, it will appear there, without hindering your view.

I’ll remove, it if you don’t like

Thanks for the swift response.

I think the the message window is redundant because, as i said in my previous post all the necessary information is available on the command line. I request you to remove the message window.

Edited April 1, 2020 by xpr0
Edit

April 1, 2020

Sometimes, autoCad are silly!!!. A parallelogram with two adjacent angles: a + b = pi.

If you rotate this parallelogram , (at a 120 degree angle), then a + b ≠ pi ???

Ok, I have fixed them, ex condition: (equal (+ anpha beta) pi 1e-6)

or ex: (if (> (+ anpha_org beta_org) (+ pi 1e-6))

April 1, 2020

@xpr0, Lisp here:

(defun DXF (code en) (cdr (assoc code (entget en))))
;;;=========================================================================
(defun Line (p1 p2) (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2))))
(defun Ray (po V)
    (entmakex (list (cons 0 "RAY")
                    (cons 100 "AcDbEntity")
                    (cons 100 "AcDbRay")
                    (cons 10 po)
                    (cons 11 v)
              )
    )
)
;;;=========================================================================
(defun sysvar-set (lst_setvar / strN var var_oldname n)
    (setq n 0
          lstvar_thiep nil
          lstValue_thiep nil
    )
    (repeat (/ (length lst_setvar) 2)
        (setq var         (nth n lst_setvar)
              var_oldname (strcat "oldvar_thiep" (itoa n))
        )
        (setq lstvar_thiep (append lstvar_thiep (list var)))
        (set (read var_oldname) (getvar var))
        (setq lstValue_thiep (append lstValue_thiep (list (read var_oldname))))
        (setvar var (nth (+ n 1) lst_setvar))
        (setq n (+ 2 n))
    )
)
(defun Get-Area (lst )
    (/ (apply
           '+
           (mapcar '(lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
                   lst
                   (cons (last lst) lst)
           )
       )
       2
    )
)
;;;=========================================================================
(defun SYSVAR-RESTORE ()
    (mapcar '(lambda (var value) (setvar var (eval value)))
            lstvar_thiep
            lstValue_thiep
    )
)
;;;=========================================================================
(defun CalcZ (Pt1 Pt2 Pt3 / v w)
    (setq v (mapcar '- Pt1 Pt2)
          w (mapcar '- Pt3 Pt2)
    )
    (- (* (car v) (cadr w)) (* (cadr v) (car w)))
)
;;=========================================================================
(defun calcThiep (po1 po2 po3 po4 / bit dis m anpha beta h obj_top poS poE)
    (setq anpha_org (LM:GetInsideAngle po4 po1 po2)
          beta_org  (LM:GetInsideAngle po1 po2 po3)
    )
    (if (< dt 0)
        (setq anpha anpha_org
              beta  beta_org
        )
        (setq anpha (- pi anpha_org)
              beta  (- pi beta_org)
        )
    )
    (Setq bit (CalcZ po1 po4 po2))
    (setq dis (distance po1 po2)
          ang (angle po1 po2)
    )
    (cond ((not (equal (+ anpha_org beta_org) pi 1e-6))
           (setq m (+ (/ (cos anpha) (sin anpha)) (/ (cos beta) (sin beta))))
           (setq h  (abs (/ (- dis (sqrt (abs (- (* dis dis) (* 2 m (abs dt)))))) m))
           )
           (cond ((or (and (> bit 0) (> dt 0)) (and (< bit 0) (< dt 0)))
                  (setq po5 (polar po2 (- ang (/ pi 2)) h)
                        po6 (polar po1 (- ang (/ pi 2)) h)
                  )
                 )
                 ((or (and (> bit 0) (< dt 0)) (and (< bit 0) (> dt 0)))
                  (setq po5 (polar po2 (+ ang (/ pi 2)) h)
                        po6 (polar po1 (+ ang (/ pi 2)) h)
                  )
                 )
           )
          )
          ((equal (+ anpha_org beta_org) pi 1e-6)
           (setq h (/ dt dis))
           (cond ((or (and (< bit 0) (< dt 0)) (and (< bit 0) (> dt 0)))
                  (setq po5 (polar po2 (+ ang (/ pi 2)) h)
                        po6 (polar po1 (+ ang (/ pi 2)) h)
                  )
                 )
                 ((or (and (> bit 0) (> dt 0)) (and (> bit 0) (< dt 0)))
                  (setq po5 (polar po2 (- ang (/ pi 2)) h)
                        po6 (polar po1 (- ang (/ pi 2)) h)
                  )
                 )
           )
          )
    )
    (setq po_in1 (inters po5 po6 po1 po4 nil)
          po_in2 (inters po5 po6 po2 po3 nil)
    )
)
(defun makeLWPoly (lst)
    (entmakex (append (list (cons 0 "LWPOLYLINE")
                            (cons 100 "AcDbEntity")
                            (cons 100 "AcDbPolyline")
                            (cons 90 (length lst))
                      )
                      (mapcar (function (lambda (p) (cons 10 p))) lst)
              )
    )
)
(defun limS (po1 po2 po3 po4 / objL1 objL2 objR iplist)
    (line po4 po1)
    (setq objL1 (vlax-ename->vla-object (entlast)))
    (line po3 po2)
    (setq objL2 (vlax-ename->vla-object (entlast)))
    (cond ((> dt 0)
           (setq
               iplist (vlax-invoke objL1 'IntersectWith objL2 acExtendBoth)
           )
           (vla-delete objL1)
           (vla-delete objL2)
           (if iplist
           (SETQ A (Get-Area (list po1 po2 iplist po1))))
          )
          ((< dt 0)
           (ray po4 (mapcar '- po2 po1))
           (setq objR (vlax-ename->vla-object (entlast)))
           (if (null (vlax-invoke objR 'IntersectWith objL2 acExtendNone))
               (PROGN (setq iplist (vlax-invoke objR
                                                'IntersectWith
                                                objL2
                                                acExtendOtherEntity
                                   )
                      )
                   (SETQ A (Get-Area (list po1 po2 iplist po4 po1)))
               )
               (PROGN (vla-delete objR)
                      (ray po3 (mapcar '- po1 po2))
                      (setq objR (vlax-ename->vla-object (entlast)))
                      (setq iplist (vlax-invoke objR
                                                'IntersectWith
                                                objL1
                                                acExtendOtherEntity
                                   )
                      )
                   (if iplist (SETQ A (Get-Area (list po1 po2 po3 iplist po1))))
               )
           )
           (vla-delete objL1)
           (vla-delete objL2)
           (vla-delete objR)
           
          )
    )
    (if A (abs A))
)
;;;=========================================================================
(defun c:dht (/       ent1_lst        ent1    ent2    ent3    po1     po2
              po3     po4     ang1    ang2    ang3    dis     m       lstpo1
              lstpo2  lstpo3  lstpo-int1      lstpo-int2      anpha   beta
              pS1     pS2     pS3     pE1     pE2     pE3     h       bit
              obj_top poS     poE     po_in1  po_in2  prom    Alim
             )
    (command "undo" "be")
    (sysvar-set '("cmdecho" 0 "osmode" 0))
    (defun *error* (msg)
        (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
            (princ (strcat "\n** Error: " msg " **"))
        )
        (setq dt nil)
        (sysvar-restore)
        (command "undo" "en")
        (princ)
    )
    (or dt (setq dt (getcfg "AppData/trapezoid/area")) (setq dt 1000))
    (setq prom
             (acet-str-format
                 "\nEnter Area given for to expand (+S) or to trim (-S) <%1> : "
                 (if (numberp dt)
                     (rtos dt 2 3)
                     dt
                 )
             )
    )
    (setq olddt dt)
    (setq dt (getreal prom))
    (if (null dt)
        (setq dt olddt)
    )
    (if (not (numberp dt))
        (setq dt (atof dt))
    )
    (while
        (OR (NOT (setq ent1_lst
                          (entsel
                              "\nPick a LINE (or LWPOLYLINE) edge for to expand (or to trim) area "
                          )
                 )
            )
            (NOT (wcmatch (DXF 0 (setq ent1 (car ent1_lst))) "LINE,LWPOLYLINE"))
        )  (prompt "\nPick a LINE is not right, Please pick again")
    )
    (cond ((eq (DXF 0 ent1) "LINE")
           (while (OR (NOT (setq ent2
                                    (car (entsel
                                             "\nPick a LINE 1st edge of the trapezoid "
                                         )
                                    )
                           )
                      )
                      (NOT (wcmatch (DXF 0 ent2) "LINE"))
                  )
               (prompt "\nPick a LINE isn't right, Please pick again")
           )
           (while (OR (NOT (setq ent3
                                    (car (entsel
                                             "\nPick a LINE 2nd edge of the trapezoid "
                                         )
                                    )
                           )
                      )
                      (NOT (wcmatch (DXF 0 ent3) "LINE"))
                  )
               (prompt "\nPick a LINE isn't right, Please pick again")
           )
           (setq po1 (vlax-curve-getStartpoint ent1) ;_bottom edge
                 po2 (vlax-curve-getEndpoint ent1)
           )
           (setq pS2 (vlax-curve-getStartpoint ent2) ;_ 1st side
                 pE2 (vlax-curve-getEndpoint ent2)
           )
           (setq pS3 (vlax-curve-getStartpoint ent3) ;_ 2nd side
                 pE3 (vlax-curve-getEndpoint ent3)
           )
           (cond ((Equal po1 ps3 1e-2)
                  (setq po4 pE3)
                  (cond ((Equal po2 ps2 1e-2) (setq po3 pE2))
                        ((Equal po2 pE2 1e-2) (setq po3 pS2))
                  )
                 )
                 ((Equal po1 pE3 1e-2)
                  (setq po4 pS3)
                  (cond ((Equal po2 ps2 1e-2) (setq po3 pE2))
                        ((Equal po2 pE2 1e-2) (setq po3 pS2))
                  )
                 )
                 ((Equal po1 ps2 1e-2)
                  (setq po4 pE2)
                  (cond ((Equal po2 ps3 1e-2) (setq po3 pE3))
                        ((Equal po2 pE3 1e-2) (setq po3 pS3))
                  )
                 )
                 ((Equal po1 pE2 1e-2)
                  (setq po4 pS2)
                  (cond ((Equal po2 ps3 1e-2) (setq po3 pE3))
                        ((Equal po2 pE3 1e-2) (setq po3 pS3))
                  )
                 )
           )
          )
          ((eq (DXF 0 ent1) "LWPOLYLINE")
           (setq po_pick (cadr ent1_lst))
           (setq po_closest (vlax-curve-getClosestPointTo ent1 po_pick))
           (setq para1 (fix (vlax-curve-getParamatpoint ent1 po_closest)))
           (setq paraE (vlax-curve-getEndParam ent1))
           (setq paraS (vlax-curve-getStartParam ent1))
           (setq po1 (vlax-curve-getPointAtParam ent1 para1))
           (cond ((= para1 0)
                  (setq po4 (vlax-curve-getPointAtParam ent1 paraE)
                        po2 (vlax-curve-getPointAtParam ent1 (+ para1 1))
                        po3 (vlax-curve-getPointAtParam ent1 (+ para1 2))
                  )
                  (if (equal po1 po4 1e-3)
                      (setq po4 (vlax-curve-getPointAtParam ent1 (- paraE 1)))
                  )
                 )
                 ((< (1+ para1) paraE)
                  (setq po4 (vlax-curve-getPointAtParam ent1 (- para1 1))
                        po2 (vlax-curve-getPointAtParam ent1 (+ para1 1))
                        po3 (vlax-curve-getPointAtParam ent1 (+ para1 2))
                  )
                 )
                 ((= (1+ para1) paraE)
                  (setq po4 (vlax-curve-getPointAtParam ent1 (- para1 1))
                        po2 (vlax-curve-getPointAtParam ent1 (+ para1 1))
                        po3 (vlax-curve-getPointAtParam ent1 paraS)
                  )
                  (if (equal po2 po3 1e-3)
                      (setq po3 (vlax-curve-getPointAtParam ent1 (+ paraS 1)))
                  )
                 )
           )
          )
    )
    (calcThiep po1 po2 po3 po4)
    (setvar "cecolor" "1")
    (makeLWPoly (list po1 po2 po_in2 po_in1 po1))
    (setvar "cecolor" "256")
    (if (> (abs dt) Alim)
        (cond ((> (+ anpha_org beta_org) (+ pi 1e-6))
             (setq Alim (limS po1 po2 po3 po4))
             (alert
                 (acet-str-format
                     "area to expand is too large (max = %1), so this case results in an area error"
                     (rtos Alim 2 3)
                 )
             )
            )
            ((< (+ anpha_org beta_org 1e-6) pi)
             (setq Alim (limS po1 po2 po3 po4))
             (alert
                 (acet-str-format
                     "area to trim is too large (max = %1), so this case results in an area error"
                     (rtos Alim 2 3)
                 )
             )
            )
        )
    )
    (setcfg "AppData/trapezoid/area" (rtos dt 2 3))
    (SYSVAR-RESTORE)
    (command "undo" "en")
    (princ "ok")
    (princ)
)
(defun LM:GetInsideAngle ( p1 p2 p3 )
    (   (lambda ( a ) (min a (- (+ pi pi) a)))
        (rem (+ pi pi (- (angle p2 p1) (angle p2 p3))) (+ pi pi))
    )
)

Edited April 1, 2020 by tranthiep
add words

April 2, 2020

14 hours ago, tranthiep said:

@xpr0, Lisp here:

@tranthiep thankyou for making corrections in the lisp. now it is working perfectly fine for all shapes & figures, although there is a tiny glitch, at the end of the command its showing this window with an error message. but lisp is working correctly there is no error in the end result. plz take a look at it.

April 2, 2020

15 hours ago, tranthiep said:

Sometimes, autoCad are silly!!!. A parallelogram with two adjacent angles: a + b = pi.

If you rotate this parallelogram , (at a 120 degree angle), then a + b ≠ pi ???

Ok, I have fixed them, ex condition: (equal (+ anpha beta) pi 1e-6)

or ex: (if (> (+ anpha_org beta_org) (+ pi 1e-6))

$0.02

if both sides parallel 90d, manually calculation, Area= Width x Height, where A = W x H,

eg: required A= 20M ,known Height=4, ie: offset, W=A/H = 20/4 = 5.00

either offset or move along axis ortho ...

(defun c:tt ( / )
  (initget 7)
  (and
  (setq a (getreal "\nEnter Area ")) 					; input area
  (setq s (ssget "_:S:E+." '((0 . "LWPOLYLINE,LINE")))) 		; pick line single selection
  (setq en (ssname s 0))				         
  (setq p (getpoint "\npick side.. ")) 					; pick offset side 	
  (if (< (setq ep (vlax-curve-getEndParam en)) 2) 	    		; check whether only 2 points
    (progn (vl-cmdf "_OFFSET"				            	; offset the line
	      (/ a (vlax-curve-getDistAtParam en ep))       		; calculate X , A divided Y
		    en p ""
	       )
      (princ "\nDone.")
    )
    (princ "\nSingle line!!")
  )
  )
  (princ)
)

another 2 different scenarios which open & close polyline

April 2, 2020

another offset concept 2 options

;; Offset segment for polyline 

(defun c:OFFSEG ( / *error* $ aa aa* _angle ang ax en ep force_closed
		 	i ip k l l1 lst n p p1 px s sc sp vs )
            
  ;;hanhphuc 01.04.2020
  			
  ;*offseg_area* -  global variable

  (setq	force_closed 1 ;; setting closed=1 , open=0   

	*error* '((msg) (princ " *cancel*")) 

	_angle	'((en x) (angle '(0. 0. 0.) (vlax-curve-getFirstDeriv en x)))

  )


(while
  
  (setq s (ssget "_:S:E:L+." '((0 . "LWPOLYLINE"))))

  
  (and
    
    (setq en (ssname s 0)
	  
          p1 (osnap (cadr (grread t 13)) "_nea"))
    
    (not (vla-put-closed (vlax-ename->vla-object en) force_closed ))
    
    (setq p  (trans p1 1 0)
	  
	  i  (fix (vlax-curve-getparamatpoint en p))
	  
          ep (vlax-curve-getEndParam en))
    
    (>= ep 2)
    
    (setq ang (mapcar

		'(lambda (x) (_angle en x)

		   )
		
		   (cond
		     
		     ( (< i 1)(list (1- ep) (1+ i))  )
		     
		     ( (>= i (1- ep)) (list (1- i) 0))
		     
		     ( (list (1- i) (1+ i)) )
		     
		   )
	   )
    )

    (setq *offseg_area*

	    	(ureal  5  ""  "\nEnter area "
			       
                        (cond
			      ( *offseg_area* )
			  
                              ( 0.000 )
			  
                        )
			       
                   )
	  
     )

    (princ "\nStretching segment.. \n")
    
    (while
      
    (and p
	   (mapcar 'set '(k p) (grread t 13))
	 
	   (= 5 k) (vl-consp p)
	 
	   (setq p1 (trans p 1 0))
	 
      )
      
       (redraw)

      (if

       (vl-some 'not
		
          (setq l (mapcar
		    
		    '(lambda (a b / p)
			     
                                   (list (setq p (vlax-curve-getPointAtParam en b))
					 
                                         (inters p (polar p a 1.0)
						 
                                                 p1 (polar p1 (_angle en i)
                                                      
                                                           1.0
                                                    )
						 
                                                 nil
						 
                                         )
					 
                                   )
		       
                           )
		    
                          ang
		    
                          (list i (1+ i))
		    
                  )
		
                l1 (apply 'append l)
		
                n (length l1)
		
                lst (mapcar '(lambda (x) (nth x l1)) '(0 1 3 2))
		
                )
		
	    )

     (setq p nil)

     (if (= *offseg_area* 0.0)

       (progn
	 
            (grvecs
	      
              (apply 'append
		     
                     (mapcar
		       
                       '(lambda (x)
			  
                                (cons (car x)
				      
                                      (mapcar

					'(lambda (x)

					   (trans x 0 1)

					  )

					(cdr x)

				    )
				      
                                )
			  
                          )
		       
                          (cons
			    
                               (cons 2 (mapcar 'cadr l))
			       
                               (mapcar '(lambda (x) (cons 2 x))
				       
                                       l
				       
                               )
			       
                           )
		       
                     )
		     
              )
	      
            )

     (princ
       
       (apply 'strcat
	      
               (setq $
		      
                     (list "\rArea = "
			   
                           (rtos

			     (setq AA* (abs (math:area lst)))

			     2

			     2

			     )
			   
                            " M\U+00B2 "
			   
                      )
		     
                )
	      
         )
       
       )
    	 
      )
       
       (princ (strcat "\rSelect offset side..              "))
       
     )

   )

  ); while

    (if
      
      (and (/= *offseg_area* 0.00)
	   
        (setq ip
	       
	       (apply 'inters
		      
		      (apply 'append (reverse (cons '(nil) l)))
		      
		      )
	      )

        (setq AA
	       
	       (abs (math:area (list (car l1) ip (caddr l1)))
		      
		 )
	      )

        (setq Ax ((if (minusp

			(- AA (abs

				(math:area (list (cadr l1) ip (cadddr l1))))

			   )

			)
		    
                    +
		    
                    -
		    
                  )
                    AA
		    
                    *offseg_area*
		    
                 )
	      
              sc (sqrt (/ (abs Ax) AA))
	      
              lst (cons (car l1)
			
                        (append
			  
                          (mapcar

			    '(lambda (x)

			       (polar ip

				      (angle ip (x l1))

				      (* (distance ip (x l1)) sc )

				 )

			      )
				  
                             (list car caddr)
				  
                          )
			  
			  (list (caddr l1))
			  
                        )
			
                  )

              AA* (abs (math:area lst))
              
              $   (list "\rArea = "
			
                       (rtos AA* 2 2)
			
                       " M\U+00B2 "
			
                    )
               
        )

	  (equal AA* *offseg_area* 1e-6)

	   ) ;and

      (princ
	
	(apply
	       'strcat
	       
	       $
	       
	  )

        )

	  (progn  

	    (setq sp

		   (mapcar

		     '(lambda (x)

			(vlax-curve-getPointAtParam en x)

			)
		     
			(list i (1+ i))
		     
		     )
		  
	         px

		     (mapcar

			     '(lambda (` p a)
				
                		(polar p a
				       
                       			(` (/ *offseg_area*

					      (abs (* (sin (- (cadr ang) (_angle en i)))
							     
                                            		(apply 'distance sp)
                                         	   )
						   
                                    		)
					      
                          		   )
					   
                       			)
				       
                		)
				
			     )
			     
			(if
			  
			  (LM:Inside-p p en ) ;;; UCS some not working 
			  
			  (list - +) (list + -))
			     
			   sp
			     
			   ang
			     
		         )
			
		      )

        
        (setq
	  
	      lst (if (= *offseg_area* 0.0) lst

		    (list (car sp) (car px) (cadr px) (cadr sp) )

		    )

              AA* (abs (math:area lst))
	      
              $   (list "\rArea = "
			
                           (rtos AA* 2 2)
			
                            " M\U+00B2 "
                  )
	      
              )
        
	    ) 
      
  ) ;if

 (if

   (or

     (equal AA* *offseg_area* 1e-6)

     (= *offseg_area* 0.0)

     )
      
      (entmakex
	
      	(vl-list* '(0 . "LWPOLYLINE")
		
                '(100 . "AcDbEntity")
		
                '(100 . "AcDbPolyline")
		
                '(70 . 0)
		
                (cons 90 (length lst))
		
		(mapcar '(lambda (x) (cons 10 x)) lst)
      	)
	
      )
      


	(if (not (= *offseg_area* 0))
	  
           (alert

	     (strcat "Exceed chamfer limit!\nMax = " (if ip (rtos AA 2 2) "???") "\ M\U+00B2"
		   
	     )

	    )

	  )
   
    )
    
   )

  )
  
  (princ)
  
)


;This function is freeware courtesy of the author's of "Inside AutoLisp" for rel. 10
;published by New Riders Publications.
;This credit must accompany all copies of this function.
;;;October 19, 2004 added function chkkwds (see description at end of file)

;* UREAL User interface real function 
;* BIT (0 for none) and KWD key word ("" for none) are same as for INITGET.
;* MSG is the prompt string, to which a default real is added as <DEF> (nil
;* for none), and a : is added.
;*
(defun ureal (bit kwd msg def / inp)
  (if def
    (setq msg (strcat "\n"
		      msg
		      " <"
		      (if (eq (type def) 'REAL)
			(rtos def 2)
			(if (eq (type def) 'INT)
			  (itoa def)
			  def
			)
		      )
		      ">: "
	      )
	  bit (* 2 (fix (/ bit 2)))
    )
    (setq msg (strcat "\n" msg ": "))
  )
  (initget bit kwd)
  (setq inp (getreal msg))
  (if inp
    inp
    def
  )
)					




;;----------------------=={ Inside-p }==----------------------;;
;;                                                            ;;
;;  Predicate function to determine whether a point lies      ;;
;;  inside a supplied LWPolyline.                             ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac - www.lee-mac.com                         ;;
;;  Using some code by gile (as marked below), thanks gile.   ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  pt  - 3D WCS point to test                                ;;
;;  ent - LWPolyline Entity against which to test point       ;;
;;------------------------------------------------------------;;
;;  Returns:  T if supplied point lies inside supplied LWPoly ;;
;;------------------------------------------------------------;;

(defun LM:Inside-p ( pt ent / _GroupByNum lst nrm obj tmp )

 (defun _GroupByNum ( l n / r)
   (if l
     (cons
       (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r))
       (_GroupByNum l n)
     )
   )
 )
 
 (if (= (type ent) 'VLA-OBJECT)
   (setq obj ent ent (vlax-vla-object->ename ent))
   (setq obj (vlax-ename->vla-object ent))
 )
 
 (setq lst
   (_GroupByNum
     (vlax-invoke 
       (setq tmp
         (vlax-ename->vla-object
           (entmakex
             (list
               (cons 0 "RAY")
               (cons 100 "AcDbEntity")
               (cons 100 "AcDbRay")
               (cons 10 pt)
               (cons 11 (trans '(1. 0. 0.) ent 0))
             )
           )
         )
       )
       'IntersectWith obj acextendnone
     )
     3
   )
 )
 (vla-delete tmp)
 (setq nrm (cdr (assoc 210 (entget ent))))
 
 ;; gile:
 (and lst (not (vlax-curve-getparamatpoint ent pt))
   (= 1
     (rem
       (length
         (vl-remove-if
           (function
             (lambda ( p / pa p- p+ p0 s1 s2 ) (setq pa (vlax-curve-getparamatpoint ent p))
               (or
                 (and (equal (fix (+ pa (if (minusp pa) -0.5 0.5))) pa 1e-7)
                   (setq p-
                     (cond
                       ( (setq p- (vlax-curve-getPointatParam ent (- pa 1e-7)))
                         (trans p- 0 nrm)
                       )
                       ( (trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-7)) 0 nrm) )
                     )
                   )
                   (setq p+
                     (cond
                       ( (setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-7)))
                         (trans p+ 0 nrm)
                       )
                       ( (trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-7)) 0 nrm) )
                     )
                   )
                   (setq p0 (trans pt 0 nrm))
                   (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
                 )
                 (and
                   (/= 0. (vla-getBulge obj (fix pa)))
                   (equal '(0. 0.) (cdr (trans (vlax-curve-getFirstDeriv ent pa) 0 nrm)) 1e-9)
                 )
               )
             )
           )
           lst
         )
       )
       2
     )
   )
 )
)


;math formula 			  
;	  | x1  x2  x3  x4  xn.. |
;	1 |   \/  \/  \/  \/     |
;Area=	/ |   /\  /\  /\  /\     |
;	2 | y1  y2  y3  y4  yn.. |
;				  

(defun math:area (l) ;hanhphuc 
  (* (apply '-
	    (mapcar '(lambda (x y)
		       (apply '+
			      (mapcar '* (mapcar x l)
				(mapcar y (append (cdr l) (list (car l)))))
			      ) 
		       ) 
		    '(car cadr)
		    '(cadr car)
		    ) 
	    ) 
     0.5
     )
  
  )

1. if user input any value <> 0 the routine emulates just like OFFSET command does, just move the mouse which side to offset saving typing -ve

2. if user input zero, i.e= 0, activate dynamic mode like my previous post which has no restriction, free style

parallel solution, W=A/H

offset solution, scale A'=A x S²

checking bug...

1.not for lines, convert+join+ purge vertices

2.single line N/A

3.not support bulged polyline or 3dpoly

Edited April 2, 2020 by hanhphuc

April 2, 2020

3 hours ago, xpr0 said:

@tranthiep thankyou for making corrections in the lisp. now it is working perfectly fine for all shapes & figures, although there is a tiny glitch, at the end of the command its showing this window with an error message. but lisp is working correctly there is no error in the end result. plz take a look at it.

I'm afraid, you would put in an area that is too large, large area for expansion (case two adjacent angles: α + β > pi), or trim area (case two adjacent angles: α + β < pi). So, I added a warning. I have fixed this lisp.

Extend_Trim_Area(DHT).lsp

April 2, 2020

6 hours ago, tranthiep said:

I'm afraid, you would put in an area that is too large, large area for expansion (case two adjacent angles: α + β > pi), or trim area (case two adjacent angles: α + β < pi). So, I added a warning. I have fixed this lisp.

Extend_Trim_Area(DHT).lsp 11.33 kB · 4 downloads

After final corrections, lisp is working perfectly fine without any issues.

I can't thank you enough for the time and effort you put into making this wonderful lisp, this will be of great help to me.

Take care of yourself and your family and stay safe.

April 2, 2020

these are some bugs of last update .

Interested? test drawing attached.

offseg bugs.dwg

hint: inside-p ray vs ucs

Edited April 4, 2020 by hanhphuc
drawing

April 3, 2020

11 hours ago, xpr0 said:

After final corrections, lisp is working perfectly fine without any issues.

I can't thank you enough for the time and effort you put into making this wonderful lisp, this will be of great help to me.

Take care of yourself and your family and stay safe.

@xpr0, No problem, may your family and all the world over the Wuhan coronavirus epidemic
Take care!

8 hours ago, hanhphuc said:

these are some bugs of last update .

Interested? test drawing attached.

offseg bugs.dwg 355.81 kB · 1 download

hint: inside-p ray vs ucs

Thank @hanhphuc, for found the shortcomings of lisp

1. Use funstion trans for transfer coordinate system point

2. Case: (bugled edge): I can't fix lisp.

3. Case: node ≡ node or 3 points on a line (v12//v23): I will fix lisp

4. Case: 3 points on a line (v12//v23) and polyline not closed: handcuffs.com, I can't fix lisp, But I'll add 1 message: "Lisp can't be done"

July 18, 2020

Just have to say that this lisp really helped me this week to adjust a layout of a parking lot and I didn't know where to start.

Thank you guys for your efforts and sharing with us.

Very greatful,

~Greg

Sign In

lisp to scale by moving only one side

Recommended Posts

tranthiep

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

tranthiep

tranthiep

hanhphuc

Posted Images

dlanorh

hanhphuc

xpr0

BIGAL

tranthiep

xpr0

tranthiep

tranthiep

xpr0

hanhphuc

hanhphuc

tranthiep

xpr0

hanhphuc

tranthiep

troggarf

Join the conversation

tranthiep

tranthiep

hanhphuc

Tutorials

Forums

Activity