Leaderboard

Hope this helps with the error.

ssget F will only catch selections that are visible on the screen, which is why I added: (vla-ZoomWindow acadobj (progn (vla-GetBoundingBox vx 'minpt 'maxpt) minpt ) maxpt ) to zoom into each selected polyline temporarily, do the selection, and close it with: (vla-ZoomPrevious acadobj) Because it happened so fast, it didn't seem like your screen zoomed at all and stayed as is. Since your polyline is so many times a lot bigger than a very thin "on-screen" thickness, it shouldn't pose a problem for you. For a locked layer, at the very start of the code: (ssget "_:L" '((0 . "INSERT,*POLYLINE")))

It's actually highlighted, but hard to see. I didn't think I'd be using sssetfirst for this: (defun c:notinside ( / *error* acadobj activeundo adoc ains alaps bb blk dets ent i ins j laprect laps maxpt minpt msg msp obname oneb orgblk pl plpt ss ssnotbl str vx x y zdet zname znames) ;; Error handling function (defun *error* ( msg ) (sssetfirst nil nil) (vla-EndUndoMark adoc) (if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*")) (princ (strcat "Error: " msg)) ) ) (setq acadobj (vlax-get-acad-object) adoc (vla-get-ActiveDocument acadobj) msp (vla-get-ModelSpace adoc) activeundo nil) (if (= 0 (logand 8 (getvar "UNDOCTL"))) (vla-StartUndoMark adoc) (setq activeundo T)) ;; Start function (if (setq ss (ssget '((0 . "INSERT,*POLYLINE")))) (progn (repeat (setq i (sslength ss)) (if (eq (cdr (assoc 0 (entget (setq ent (ssname ss (setq i (1- i))))))) "INSERT") (setq blk (cons ent blk)) (setq pl (cons ent pl)) ) ) (setq orgblk (length blk)) (foreach x pl ;; Get zone name (setq vx (vlax-ename->vla-object x)) (sssetfirst nil (ssadd x)) (while (progn (initget 1 "Name") (setq zname (entsel "\nSelect text specifying zone name for highlighted line or [Name]: ")) (cond ((null zname) (princ "\nNothing selected")) ((eq zname "Name") (setq zname (getstring T "\nSpecify name for highlighted line: ")) (if (vl-position zname znames) (progn (princ (strcat "\nName \"" zname "\" already exist. Please enter a new name")) T) (progn (setq znames (cons zname znames)) nil) ) ) ((not (wcmatch (cdr (assoc 0 (entget (car zname)))) "TEXT,MTEXT")) (princ "\nObject is not a text")) ((setq zname (cdr (assoc 1 (entget (car zname))))) (if (vl-position zname znames) (progn (princ (strcat "\nName \"" zname "\" already exist. Please enter a new name")) T) (progn (setq znames (cons zname znames)) nil) ) ) ) ) ) ;; Get overlaps & Inside (vla-ZoomWindow acadobj (progn (vla-GetBoundingBox vx 'minpt 'maxpt) minpt ) maxpt ) (setq plpt (mapcar 'cdr (vl-remove-if-not '(lambda (y) (eq (car y) 10)) (entget x))) plpt (if (and (eq (cdr (assoc 70 (entget x))) 1) (null (equal (car plpt) (last plpt) 1))) (append plpt (list (car plpt))) plpt) laps (ssget "_F" plpt '((0 . "INSERT"))) ins (ssget "_CP" plpt '((0 . "INSERT"))) ains (cons ins ains) ) (mapcar '(lambda (x y / bb) (if (setq bb (ssget "_F" (list x y) '((0 . "INSERT")))) (repeat (setq j (sslength bb)) (if (ssmemb (setq ent (ssname bb (setq j (1- j)))) ss) (setq laprect (cons (apply 'JH:rectcorner (LM:ssboundingbox bb)) laprect)) ) ) ) ) (reverse (cdr (reverse plpt))) (cdr plpt) ) (vla-ZoomPrevious acadobj) (if laps (progn (repeat (setq i (sslength laps)) (if (ssmemb (setq ent (ssname laps (setq i (1- i)))) ss) (setq alaps (cons (cons zname ent) alaps)) ) ) ) ) (if ins (repeat (setq i (sslength ins)) (setq blk (vl-remove (ssname ins (setq i (1- i))) blk)) ) ) ) (sssetfirst nil nil) ;; Get Details (setq ssnotbl (JH:list-to-selset blk)) (while alaps (setq oneb (vl-remove-if-not '(lambda (x) (eq (cdr x) (cdar alaps))) alaps) dets (cons (cons (vla-get-EffectiveName (vlax-ename->vla-object (cdar alaps))) (LM:lst->str (vl-sort (mapcar 'car oneb) '(lambda (a b) (< a b))) ", ")) dets) alaps (vl-remove-if '(lambda (x) (eq (cdr x) (cdar alaps))) alaps) ) ) (setq obname (mapcar '(lambda (x) (vla-get-EffectiveName (vlax-ename->vla-object x))) blk) str (mapcar '(lambda (x) (strcat "\n" (itoa (JH:CountSpecific zdet x)) " blocks overlapping on boundaries " x " (" (LM:lst->str (mapcar '(lambda (y) (strcat (itoa (cdr y)) " " (car y))) (LM:CountItems (mapcar 'car (vl-remove-if-not '(lambda (y) (eq x (cdr y))) dets)))) ", ") ")" ) ) (LM:Unique (setq zdet (mapcar 'cdr dets))) ) msg (strcat "\nTotal number of blocks in selection: " (itoa orgblk) "\nTotal number of zones identified: " (itoa (length pl)) " (" (cond ((LM:lst->str (vl-sort znames '(lambda (a b) (< a b))) ", ")) ("")) ")" "\n" "\nNumber of blocks outside zones: " (itoa (length blk)) " (" (cond ((LM:lst->str (mapcar '(lambda (x) (strcat (itoa (cdr x)) " " (car x))) (LM:CountItems obname)) ", ")) ("")) ")" (apply 'strcat str) "\n" "\n" "\nNumber of blocks outside and overlapping: " (itoa (+ (length blk) (length dets) ) ) ) ) (entmake (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText") (cons 1 msg) (cons 10 (progn (initget 1) (getpoint "\nSpecify insertion point for text: "))) '(40 . 2200) ; <--- Set text height here '(50 . 0) ) ) (foreach x (LM:UniqueFuzz laprect 1) (entmake (append '( (0 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline") (90 . 4) (70 . 1) (62 . 2) ; <--- Set color here. In this case, it's yellow. Depends on color index (43 . 300) ; <--- Set thickness here ) (apply 'append (mapcar '(lambda (y) (list (cons 10 y) '(42 . 0) '(91 . 0) ) ) x ) ) ) ) ) (sssetfirst nil ssnotbl) (princ msg) ) ) ;; End function (if activeundo nil (vla-EndUndoMark adoc)) (princ) ) (defun JH:uniqueset (lst / fin) ; Returns a unique selection set from a list of selection sets (setq fin (ssadd)) (mapcar '(lambda (x / a ent) (repeat (setq a (sslength x)) (if (null (ssmemb (setq ent (ssname x (setq a (1- a)))) fin)) (setq fin (ssadd ent fin)) ) ) ) lst ) fin ) (defun JH:CountSpecific (lst itm) ; Returns the number of items itm is inside lst. (- (length lst) (length (vl-remove itm lst)) ) ) (defun JH:rectcorner (a b) (list a (list (car b) (cadr a) (last a)) b (list (car a) (cadr b) (last a)) ) ) (defun JH:list-to-selset (lst / final) (setq final (ssadd)) (mapcar '(lambda (x) (setq final (ssadd x final))) lst) final ) ;; List to String - Lee Mac ;; Concatenates each string in a supplied list, separated by a given delimiter ;; lst - [lst] List of strings to concatenate ;; del - [str] Delimiter string to separate each item (defun LM:lst->str ( lst del / str ) (setq str (car lst)) (foreach itm (cdr lst) (setq str (strcat str del itm))) str ) ;; Unique - Lee Mac ;; Returns a list with duplicate elements removed. (defun LM:Unique ( l / x r ) (while l (setq x (car l) l (vl-remove x (cdr l)) r (cons x r) ) ) (reverse r) ) ;; Unique with Fuzz - Lee Mac ;; Returns a list with all elements considered duplicate to ;; a given tolerance removed. (defun LM:UniqueFuzz ( l f / x r ) (while l (setq x (car l) l (vl-remove-if (function (lambda ( y ) (equal x y f))) (cdr l)) r (cons x r) ) ) (reverse r) ) ;; Count Items - Lee Mac ;; Returns a list of dotted pairs detailing the number of ;; occurrences of each item in a supplied list. (defun LM:CountItems ( l / c l r x ) (while l (setq x (car l) c (length l) l (vl-remove x (cdr l)) r (cons (cons x (- c (length l))) r) ) ) (reverse r) ) ;; Selection Set Bounding Box - Lee Mac ;; Returns a list of the lower-left and upper-right WCS coordinates of a ;; rectangular frame bounding all objects in a supplied selection set. ;; sel - [sel] Selection set for which to return bounding box (defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp ) (repeat (setq idx (sslength sel)) (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))) (if (and (vlax-method-applicable-p obj 'getboundingbox) (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp)))) ) (setq ls1 (cons (vlax-safearray->list llp) ls1) ls2 (cons (vlax-safearray->list urp) ls2) ) ) ) (if (and ls1 ls2) (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2)) ) ) Btw, the fence selection does not recognise by polyline width, so for example, if the below happens if the line is too thick, it won't catch it. For instance: See the yellow cursor, which is actually the vertex point. Therefore my crosshair denotes the fence selection. The blue block is not touching the yellow line (the calculated fence selection), but it's touching the green polyline, so this is another issue if your polyline becomes too thick.

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

it has been a while to this page maybe 6 years after I am coming back but I made a typo it is "stop" but I am happy it made some to laugh during covid 19 ok here we go 2020 www.lee-mac.com :: :: "ctx" to Copy | "stx" to Swap :: Command: STX Formatting retained: Yes Select text to swap [Settings/Exit] <Exit>: se Retain mtext formatting? [Yes/No] <Yes>: n Formatting retained: No Select text to swap [Settings/Exit] <Exit>: Formatting retained: No And text to swap it with [Settings/Exit] <Exit>: Error: no function definition: VLAX-ENAME->VLA-OBJECT Command: this is the error message I am getting. my typing is bad if there is any error forgive me. thanks Stoop

Try this. Just seen the above post, so added a reset so you can change out. (defun _get_cur_lyr ( / ent lyr) (while (not ent) (setq ent (car (entsel "\nSelect Numeric Layer For Current : ")) lyr (cdr (assoc 8 (entget ent))) ) (cond ( (vl-every '(lambda (x) (< 47 x 58)) (vl-string->list lyr)) (setq lyr (atoi lyr))) (t (alert "Not a Numeric Layer") (setq ent nil)) );end_cond );end_while lyr );end_defun (defun c:lyr+ (/ lastlayer n1 n2 o) (or *c_lyrs* (setq *c_lyrs* (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))) (cond (*curlyr* (setq lastlyr (itoa *curlyr*) *curlyr* (+ *curlyr* 2) );end_setq (cond ( (tblsearch "layer" (itoa *curlyr*)) (if (= :vlax-false (vlax-get-property (setq o (vla-item *c_lyrs* (itoa *curlyr*))) 'layeron)) (vlax-put-property o 'layeron :vlax-true)) (setvar 'clayer (itoa *curlyr*)) (vlax-put-property (vla-item *c_lyrs* lastlyr) 'layeron :vlax-false) ) (t (alert (strcat "Layer " (itoa *curlyr*) " Not Found"))) );end_cond ) (t (setq *curlyr* (_get_cur_lyr)) (if *curlyr* (setvar 'clayer (itoa *curlyr*)) (alert "No Numeric Layer Selected"))) );end_cond (princ) );end_defun (defun c:resetlyr+ (/) (setq *curlyr* nil))

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

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.

Tombu good idea use the drag over howmany lines 2+ does not matter, do a sort on order so find the outside 2 , get intersection and say mid point of outsides then fillet all lines. Note 2021 extend/trim is now built in as an option.

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 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

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

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

Good day to everyone. I hope the author of this Lisp does not bother me. I have added a couple of lines to the code to work bette ;;; DIVAREA.LSP Land division utility ;;; written by Yorgos Angelopoulos ;;; aggior@panafonet.gr ;;; ------------------------------------ ;;; Traducción del código original al español, por Miguel A. Lázaro Marín ;;; http://perso.wanadoo.es/lm2ark ;;; ------------------------------------ ;;; Citando al autor original, Sr. Angelopoulos, y su posterior traductor ;;; al Sr. Lázaro Marín he planteado una variante al programa en la cual ;;; si la solución es convergente, la va a encontrar con mayor velocidad ;;; que la rutina original. Lea atentamente las instrucciones, en las que ;;; hubo sutiles cambios ;;; por , Julio C. Jaramillo j_julio@hotmail.com ;;; ------------------------------------ ;;; ------------------------------------ ;;; Espero que el autor de este codigo no se moleste conmigo. Le he agregado ;;; un par de líneas a este lisp. ;;; José Hernández josehernandezd@gmail.com ;;; ------------------------------------ ;;; ------------------------------------ ;;; Suponga que usted tiene que dividir una parcela grande de terreno entre ;;; 2, 3, 4,...(¡o incluso dividirla entre 5.014!); o bien se desea cortar ;;; una porción de 2345 m2 para segregarla de la parcela matriz u original. ;;; ;;; Todo lo que usted necesita es tener dibujada una "polilínea optimizada" ;;; (entidad "LWPOLYLINE", incluída en AutoCAD a partir de su versión 14), ;;; que se encuentre CERRADA y que coincida con el perímetro del área total ;;; de la parcela a dividir. También una LÍNEA de DIVISIÓN en la cual comienza ;;; a iterar este rutina. ;;; ;;; Cargue la utilidad, después de ponerla en un directorio apropiado, por ;;; ejemplo el C:\Archivos de programa\AutoCAD\Support, bien sea ;;; invocando el comando _APPLOAD o bien mediante (LOAD "DIVAREA"), y tras ;;; la pertinente carga ejecutémosla escribiendo DIVAREA en la línea de ;;; comandos. ;;; ;;; Conteste a las escasas preguntas que la rutina le irá formulando y ;;; RECUERDE: ;;; ;;; Cuando le sea solicitado que SELECCIONE la línea de ;;; división aproximada inicial, tenga presente lo siguiente: ;;; ;;; 1. Esta LÍNEA de DIVISIÓN será trasladada (en paralelo a la inicial) ;;; o rotada (en función de la opción elegida) durante la ejecución de la ;;; rutina, de manera que sus puntos inicial y final que definen la misma ;;; deben marcarse teniendo en cuenta que, durante las aludidas traslación ;;; o rotación, no vayan a pasar hacia el interior del contorno definido ;;; por la LWPLYLINE (aunque debe resultar fácil superar este inconveniente). ;;; Por tanto se aconseja que los puntos que definen LÍNEA de DIVISIÓN ;;; inicial estén tan LEJANOS HACIA FUERA del perímetro como sea posible ;;; sin exceder, por supuesto, el área actual visible de pantalla. ;;; ;;; En cuanto al punto o polo FIJO, en caso de que se haya preferido la ;;; opción "F" en lugar de "P" (dirección PARALELA) como respuesta a la ;;; pregunta anterior sobre el modo de generación de la línea divisoria, ;;; dicho punto tiene que residir o bien sobre la polilínea o bien fuera ;;; de ella, nunca dentro de la superficie delimitada a dividir. ;;; ;;; 2. Al indicar el punto sobre la porción en donde se obtendrá el área ;;; deseada, habrá que señalarlo DENTRO de dicha porción y ALEJADA de la ;;; línea de división tanto como sea posible, de forma que ese punto no ;;; llegue a quedar fuera de la porción que se va obteniendo a medida que ;;; la línea divisoria se mueve durante su proceso de cálculo. ;;; ;;; 3. Finalmente usted tendrá que indicar exactamente de la misma manera ;;; un punto de la porción restante: DENTRO de ella y ALEJADA de la línea ;;; de división. ;;; ;;; Si se desea mayor precisión de cálculo en la división del área, se ;;; pueden AUMENTAR el valor de las variable local: STEP ;;; ;;;******************LA UTILIDAD COMIENZA AQUI*************************** (defun PRERR (S) (if (/= S "Function cancelled") (princ (strcat "\nError: " S))) (setq *error* OLDERR) (princ)) (defun C:DIVAREA (/ OSM STRPF STRDC EX STEP ARXSET ARX ARXON K OK D P1 P2 PTS PTB DELN AR PAR TEM PJ1 PJ2 PJ1X PJ2X PJ1Y PJ2Y DISX DISY PJN PTSS PTBB DIST DELNJ DELN1 LINEAD vcs) (vl-load-com) (setvar "cmdecho" 0) (setq OLDERR *error* *error* PRERR OSM (getvar "osmode") ) (command "layer" "m" "Area" "c" "3" "" "") (command "_-STYLE" "Romans" "romans.shx" 0 1 0 "NO" "NO" "") ;------------------------------------------------------- (setq dsc (getvar "dimscale")) (setq ht (* 0.18 dsc)) ;------------------------------------------------------- (setq ptt (getpoint "\nPique dentro de un area cerrada ")) (command "-boundary" "a" "i" "n" "" "" ptt "") (setq pl (entlast)) (setq poly (listpol pl)) (setq int (centroid poly)) (command "_area" "o" pl) (command "_erase" pl "") (setq AR (getvar "area")) (setq art AR) (setvar "clayer" "Area") (command "text" "j" "c" int ht "90" (strcat (rtos art 2 2) "m²")) (princ "\nArea Total ") (princ (rtos art 2 2)) (princ "\m²") (setq vcs 1) (setq k 1) (setq STEP 10) (setq EX 0) ;------------------------------------------------------------------------------ (if (= EX 0) (progn (command "_undo" "m" "_layer" "m" "Area_Division" "" "_area" "e" ARXON) (initget "Divide Cut") (setq STRDC (getkword "\nDIVIDE por número de partes o [CORTA una superficie conocida]? (D/C): ")) (if (= STRDC "Divide") (setq K (getreal "\nIntroduzca número por el que dividir el total: ") TEM (/ AR K))) (if (= STRDC "Cut") (progn (setq vcs 0) (setq TEM (getreal "\nIntroduzca el área a cortar del total (m2): ")) ;(setq k (getreal "\nIntroduzca número por el que dividir el total: ")) ) ) (initget "Parallel Fixed") (setq STRPF (getkword "\nLínea de corte PARALELA a una dirección o [por un polo FIJO]? (P/F) :")) (if (= STRPF "Fixed") (FIXPT)) (if (= STRPF "Parallel") (PARPT)))) (setq *error* OLDERR) (setvar "osmode" OSM) (setvar "cmdecho" 1) (setvar "blipmode" 0)) (setvar "clayer" "0") ;****************************************************************************** (defun FIXPT () (while (and (< vcs k) (not (= TEM nil))) (LNA) (setvar "osmode" OSM) (setvar "osmode" 0) (command "_line" P1 P2 "") (setq DELN (entlast) PTS (getpoint "\nEscoja un punto DENTRO de la porción a obtener y ALEJADO de la línea divisoria: ") PTB (getpoint "\nEscoja cualquier punto del RESTO del área y ALEJADO de la línea divisoria: ")) (setvar "blipmode" 0) (princ "\nPor favor, espere...") (setq PTSS PTS PTBB PTB) (command "_boundary" PTS "" "_area" "e" "l") (setq PAR (getvar "area") OK (if (< PAR TEM) 1 (if (> PAR TEM) -1 0))) (progn (while (/= OK 0) (SUPERIORF) (INFERIORF)) (entdel DELN)) (command "_change" "l" "" "p" "c" "green" "" "_boundary" PTBB "" "_change" "l" "" "p" "c" "red" "") (setq vcs (+ vcs 1)) (if (= STRDC "Cut") (progn (setq vcs (- vcs 1)) (setq art (- art TEM)) (princ "\nQuedan : ") (princ art) (setq TEM (getreal "\nIntroduzca el área a cortar del total (m2): ")) (if (> TEM art) (setq vcs k) ) ) ) ) (setvar "clayer" "0") ) ;****************************************************************************** (defun SUPERIORF () (if (= OK 1) (progn (entdel (entlast)) (setq PJ2 PTB PJ1 (inters P1 P2 PTS PTB) PJ1X (car PJ1) PJ2X (car PJ2) PJ1Y (cadr PJ1) PJ2Y (cadr PJ2) DISX (/ (+ PJ1X PJ2X) 2) DISY (/ (+ PJ1Y PJ2Y) 2) PJN (list DISX DISY)) (command "_rotate" DELN "" P1 "r" P1 P2 PJN "_boundary" PTSS "" "_area" "e" "l") (setq OK (if (> (getvar "area") TEM) -1 1) PTS PJ1 PTB PJ2 P2 PJN) (if (= (rtos (getvar "area") 2 STEP) (rtos TEM 2 STEP)) (setq OK 0)) (setq PAR (getvar "area"))))) ;****************************************************************************** (defun INFERIORF () (if (= OK -1) (progn (entdel (entlast)) (setq PJ2 PTS PJ1 (inters P1 P2 PTS PTB) PJ1X (car PJ1) PJ2X (car PJ2) PJ1Y (cadr PJ1) PJ2Y (cadr PJ2) DISX (/ (+ PJ1X PJ2X) 2) DISY (/ (+ PJ1Y PJ2Y) 2) PJN (list DISX DISY)) (command "_rotate" DELN "" P1 "r" P1 P2 PJN "_boundary" PTSS "" "_area" "e" "l") (setq OK (if (< (getvar "area") TEM) 1 -1) PTS PJ2 PTB PJ1 P2 PJN) (if (= (rtos (getvar "area") 2 STEP) (rtos TEM 2 STEP)) (setq OK 0)) (setq PAR (getvar "area"))))) ;****************************************************************************** (defun PARPT () (while (and (< vcs k) (not (= TEM nil))) (LNA) (setvar "osmode" OSM) (setvar "osmode" 0) (command "_line" P1 P2 "") (setq DELN (entlast) PTS (getpoint "\nEscoja un punto DENTRO de la porción a obtener y ALEJADO de la línea divisoria: ") PTB (getpoint "\nEscoja cualquier punto del RESTO del área y ALEJADO de la línea divisoria: ")) (setvar "blipmode" 0) (princ "\nPor favor, espere...") (setq PTSS PTS PTBB PTB) (command "_boundary" PTS "" "_area" "e" "l") (setq PAR (getvar "area") OK (if (< PAR TEM) 1 (if (> PAR TEM) -1 0))) (progn (while (/= OK 0) (SUPERIORP) (INFERIORP)) (entdel DELN)) (command "_change" "l" "" "p" "c" "green" "" "_boundary" PTBB "" "_change" "l" "" "p" "c" "red" "") (setq vcs (+ vcs 1)) (if (= STRDC "Cut") (progn (setq vcs (- vcs 1)) (setq art (- art TEM)) (princ "\nQuedan : ") (princ art) (setq TEM (getreal "\nIntroduzca el área a cortar del total (m2): ")) (if (> TEM art) (setq vcs k) ) ) ) ) (setvar "clayer" "0") ) ;****************************************************************************** (defun SUPERIORP () (if (= OK 1) (progn (entdel (entlast)) (setq PJ2 PTB PJ1 (inters P1 P2 PTS PTB) PJ1X (car PJ1) PJ2X (car PJ2) PJ1Y (cadr PJ1) PJ2Y (cadr PJ2) DISX (/ (+ PJ1X PJ2X) 2) DISY (/ (+ PJ1Y PJ2Y) 2) PJN (list DISX DISY) DIST (distance PJ1 PJN)) (command "_offset" DIST DELN PTBB "") (entdel DELN) (setq DELN (entlast)) (command "_boundary" PTSS "" "_area" "e" "l") (setq OK (if (> (getvar "area") TEM) -1 1) PTS PJ1 PTB PJ2 P2 PJN) (if (= (rtos (getvar "area") 2 STEP) (rtos TEM 2 STEP)) (setq OK 0)) (setq PAR (getvar "area"))))) ;****************************************************************************** (defun INFERIORP () (if (= OK -1) (progn (entdel (entlast)) (setq PJ2 PTS PJ1 (inters P1 P2 PTS PTB) PJ1X (car PJ1) PJ2X (car PJ2) PJ1Y (cadr PJ1) PJ2Y (cadr PJ2) DISX (/ (+ PJ1X PJ2X) 2) DISY (/ (+ PJ1Y PJ2Y) 2) PJN (list DISX DISY) DIST (distance PJ1 PJN)) (command "_offset" DIST DELN PTSS "") (entdel DELN) (setq DELN (entlast)) (command "_boundary" PTSS "" "_area" "e" "l") (setq OK (if (< (getvar "area") TEM) 1 -1) PTS PJ2 PTB PJ1 P2 PJN) (if (= (rtos (getvar "area") 2 STEP) (rtos TEM 2 STEP)) (setq OK 0)) (setq PAR (getvar "area"))))) ;****************************************************************************** (defun LNA () (princ) (setvar "osmode" 8200) (setq p1 (getpoint "\nPrimer punto de la linea:")) (setq p2 (getpoint p1 "\nSegundo punto de la linea:")) ) ;****************************************************************************** (defun centroid (poly / n) (setq n (length poly)) (mapcar '(lambda (a) (/ a n)) (apply 'mapcar (cons '+ poly))) ) ;****************************************************************************** (defun listpol (pl / pa pt lst) (vl-load-com) (setq pa (if (vlax-curve-IsClosed pl) (vlax-curve-getEndParam pl) (1+ (vlax-curve-getEndParam pl)) ) ) (while (setq pt (vlax-curve-getPointAtParam pl (setq pa (1- pa)))) (setq lst (cons (trans pt 0 1 ) lst)) ) ) ;******************************************************************************* Divarea.lsp