Leaderboard

Try this rework. Tested on your provided drawing. (defun c:hat (/ ss cnt obj ar tot) (setq tot 0 ss (ssget '((0 . "HATCH")))) (cond (ss (repeat (setq cnt (sslength ss)) (setq obj (vlax-ename->vla-object (setq ent (ssname ss (setq cnt (1- cnt)))))) (if (vl-catch-all-error-p (setq ar (vl-catch-all-apply 'vlax-get (list obj 'area)))) (progn (vl-cmdf "hatchgenerateboundary" ent "") (setq ar (getpropertyvalue (entlast) "area"))(entdel (entlast))) ) (setq tot (+ tot ar)) ) (alert (strcat "Total Area : "(rtos tot 2 3))) ) ) (princ) ) The hatch in question had three duplicate points at the start of the reinstated boundary polyline.

these are some bugs of last update . Interested? test drawing attached. offseg bugs.dwg hint: inside-p ray vs ucs

Not an answer to your question, but correction (remark)... ... (setq kk -1) (setq tot 0.0) (repeat ... ...

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

$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

Hope this helps with the error.

Here's another .. no fancy reporting: (defun c:foo (/ _s2l pts s) (defun _s2l (s) (if s (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))) ) (foreach x (_s2l (setq s (ssget '((0 . "insert,lwpolyline"))))) (if (= "LWPOLYLINE" (cdr (assoc 0 (entget x)))) (progn (setq pts (mapcar 'cdr (vl-remove-if '(lambda (p) (/= 10 (car p))) (entget x)))) (foreach y (_s2l (ssget "_WP" pts '((0 . "insert")))) (ssdel y s)) (ssdel x s) ) ) ) (sssetfirst nil s) (princ) )

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

IMO geometry algorithm (tips: quadrilateral area) is faster than "guessing", but coding with iteration inters is much easier here i have a simple concept, just pick at one segment leg then slide. the rest you can optimize.. (defun c:aaa ( / ang en i k l p p1 ep ) (and (mapcar 'set '(en p) (entsel "Pick segment on LWPOLYLINE.. ")) (setq p1 (osnap p "nea")) (setq p (trans p1 1 0) i (fix (vlax-curve-getparamatpoint en p))) (setq ep (vlax-curve-getEndParam en)) (>= ep 3) (< 0 i (1- ep)) (setq ang (mapcar ''((x) (angle '(0. 0. 0.) (vlax-curve-getFirstDeriv en x))) (list (1- i) (1+ i)) ) ) (while (and p (mapcar 'set '(k p) (grread t 13)) (= 5 k) (setq p1 (trans p 1 0)) ) (redraw) (setq l (mapcar ''((a b / p) (list (setq p (vlax-curve-getPointAtParam en b)) (inters p (polar p a 1.0) p1 (polar p1 (angle '(0. 0. 0.) (vlax-curve-getFirstDeriv en i)) 1.0 ) nil ) ) ) ang (list i (1+ i)) ) ) (grvecs (apply 'append (mapcar ''((x) (cons (car x) (mapcar ''((x) (trans x 0 1)) (cdr x))) ) (cons (cons 2 (mapcar 'cadr l)) (mapcar ''((x) (cons 2 x)) l ) ) ) ) ) ) ) (princ) )

Hint: (-4 . "<OR") ... (-4 . "OR>")

(setq ss1 (ssget '((0 . "text,mtext") (-4 . "<NOT") (1 . "Screw") (-4 . "NOT>") ) ) )

OK, try this. It works in my test. (defun LM:unique (l) (if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l)))))) (defun BB:setByBlock (nam / blc blk) (setq blc (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))) (setq blk (vla-item blc nam)) (vlax-for x blk (if (= "AcDbBlockReference" (vlax-get-property x 'objectname)) (BB:setByBlock (vlax-get-property x 'effectivename))) (if (= "0" (vlax-get-property x 'layer)) (vlax-put-property x 'lineweight acLnWtByBlock)) ) ) (vl-load-com) (defun c:bf ( / c_doc sel cnt obj col) (setq c_doc (vla-get-activedocument (vlax-get-acad-object))) (princ "\nSelect blocks : ") (setq sel (ssget '((0 . "INSERT")))) (cond (sel (repeat (setq cnt (sslength sel)) (setq obj (vlax-ename->vla-object (ssname sel (setq cnt (1- cnt))))) (cond ( (= :vlax-true (vlax-get-property obj 'isdynamicblock)) (setq col (cons (vla-get-effectivename obj) col) col (cons (vla-get-name obj) col) ) ) (t (setq col (cons (vla-get-effectiveName obj) col))) );end_cond );end_repeat (setq col (LM:unique col)) (foreach x col (BB:setByBlock x)) ) ( (princ "\nNothing Selected")) );end_cond (vla-regen c_doc acActiveViewport) (princ) );end_defun

Hopefully this is 2010. Pretty simple pline shape. QQ 2010.dwg

I would recommend you draw all the dimensions first (rotated or aligned), then upon executing the command, select all the dimensions, and AutoLISP will determine all common intersecting points. Here's my solution for you: ;; Get arrowhead location for the dimension --> Jonathan Handojo ;; dim - dimension entity ;; Returns a list of two points denoting the arrowhead location (defun JH:getarrowpt (dim / dimang pt1 pt2 pt3 pt4) (setq dimang (angle (setq pt1 (cdr (assoc 10 (entget dim)))) (setq pt2 (cdr (assoc 11 (entget dim)))) ) ) (list (inters pt1 pt2 (setq pt3 (cdr (assoc 13 (entget dim)))) (polar pt3 (+ (* 0.5 pi) dimang) 1) nil ) (inters pt1 pt2 (setq pt4 (cdr (assoc 14 (entget dim)))) (polar pt4 (+ (* 0.5 pi) dimang) 1) nil ) ) ) ;; Gets a list of duplicated points with a certain fuzz in a list of points ;; lst - list of points to check for ;; fuz - tolerance between points ;; Returns a list of duplicate points (defun JH:commonpts (lst fuz / tst rtn) (while lst (setq tst (car lst) lst (cdr lst) ) (if (and (vl-some '(lambda (x) (equal tst x fuz) ) lst ) (not (vl-some '(lambda (x) (equal tst x fuz) ) rtn ) ) ) (setq rtn (cons tst rtn)) ) ) (reverse rtn) ) ;; ------------------------------------------- ;; (defun JH:selset-to-list (selset / lst iter) ; Returns all entities within a selection set into a list. (setq iter 0) (repeat (sslength selset) (setq lst (cons (ssname selset iter) lst) iter (1+ iter)) ) (reverse lst) ) ;; ------------------------------------------- ;; (defun c:putblk ( / *error* activeundo acadobj adoc arrpt blk DegToRad fuz msp rot ss) (defun *error* ( msg ) (vla-EndUndoMark adoc) (if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*")) (princ (strcat "Error: " msg)) ) ) (defun DegToRad (x) (* x (/ pi 180))) (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)) (setq ss (ssget '((0 . "DIMENSION"))) blk "Tem_Sense" ; <--- Block name to insert fuz 1e-4 ; <--- Intersection tolerance ) (if ss (progn (setq arrpt (apply 'append (mapcar 'JH:getarrowpt (JH:selset-to-list ss))) rot (progn (initget 1) (getreal "\nSpecify rotation in degrees: ")) ) (if (tblsearch "BLOCK" blk) (mapcar '(lambda (x) (vla-InsertBlock msp (apply 'vlax-3d-point x) blk 1 1 1 (DegToRad rot)) ) (JH:commonpts arrpt fuz) ) ) ) ) (if activeundo nil (vla-EndUndoMark adoc)) (princ) )

I think what he's asking is something like (getstring T "\nSpecify tag name: ") and then list all the blocks with that specific tag name. Unfortunately of all the posts I've done here and with my knowledge, I don't have a idea how to do that

The obvious answer given the existing code provided by the OP would be to simply iterate over the list of files returned by the vl-directory-files function using a foreach loop, and evaluate the read_only user-defined function for every file within the loop, e.g.: (setq dir "C:\\TX Cad Config\\Block\\") (foreach dwg (vl-directory-files dir "*.dwg" 1) (read_only (strcat dir dwg)) ) However, this approach is highly inefficient, as the code is instantiating the File System Object (FSO) and then testing the existence of every file processed, when only one instance of the FSO is required, and the files are already known to exist given that they are being returned by the vl-directory-files function. With this in mind, a slightly more efficient approach might be: (defun c:test ( / dir fob fso lst ) (if (and (setq dir "C:\\TX Cad Config\\Block\\" lst (vl-directory-files dir "*.dwg" 1) ) (setq fso (vlax-create-object "scripting.filesystemobject")) ) (progn (foreach dwg lst (setq fob (vlax-invoke fso 'getfile (strcat dir dwg))) (vlax-put-property fob 'attributes (logior 1 (vlax-get fob 'attributes))) (vlax-release-object fob) ) (vlax-release-object fso) ) ) (princ) ) You could alternatively use the FSO for all of the file manipulation, including obtaining the set of files within the given folder, e.g.: (defun c:test ( / dir flc fld fso ) (if (setq dir "C:\\TX Cad Config\\Block" fso (vlax-create-object "scripting.filesystemobject") ) (progn (vl-catch-all-apply '(lambda ( ) (setq fld (vlax-invoke fso 'getfolder dir) flc (vlax-get fld 'files) ) (vlax-for fob flc (if (wcmatch (strcase (vlax-get fob 'name) t) "*.dwg") (vlax-put-property fob 'attributes (logior 1 (vlax-get fob 'attributes))) ) ) ) ) (if flc (vlax-release-object flc)) (if fld (vlax-release-object fld)) (vlax-release-object fso) ) ) (princ) ) However, the following simple solution is likely to be far more efficient, especially for large folders of files: (defun c:test ( ) (command "_.shell" "attrib +r \"C:\\TX Cad Config\\Block\\*.dwg\"") (princ) ) Aside - I can't understand why you replied knowing that the advice offered was inaccurate?

Wrap your tot in a if so if not exist area skip.

Idk if it will solve your problem but... (defun c:hat ( / ss) (if (setq ss (ssget '((0 . "HATCH")))) (alert (strcat "Total Area: " (rtos (apply '+ (mapcar 'vla-get-Area (JH:selset-to-list-vla ss))) 2 3))) ) ) (defun JH:selset-to-list-vla (selset / lst i) ; Returns all entities within a selection set into a list of vla-objects. (repeat (setq i (sslength selset)) (setq lst (cons (vlax-ename->vla-object (ssname selset (setq i (1- i)))) lst)) ) (reverse lst) )

Makes sense now, although (eq 2 2) or (eq "str" "str") returns T. Oh, please don't make me any dizzier than I already am

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

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

It's not a bug, it's user error for selecting an entity on a layer with the suffix "-DEMO" A belt and braces lisp. You can't select a layer with "-DEMO" in the layer name If the layer already has an associated "-demo" layer it moves it to that layer Otherwise it creates the demo layer and moves it. (defun change_layer_color_ltp ( ent / dlname) (setq dlname (cdr (assoc 8 (entget ent)))) (cond ( (and (not (wcmatch (strcase dlname) "*-DEMO")) (setq dlname (strcat dlname "-DEMO")) (not (tblsearch "layer" dlname)) ) (command "_.layer" "_make" dlname "_color" 40 "" "_ltype" "HIDDEN2" "" "" "_.chprop" ent "" "_layer" DLname "" ) ) ( (tblsearch "layer" dlname) (command "_.chprop" ent "" "_layer" dlname "")) ) (princ) ) (defun c:clcl ( / ss i) ;; selection (princ "\nMake selection: ") (setq ss (ssget '((-4 . "<NOT") (8 . "*DEMO") (-4 . "NOT>")))) ;; now perform the function for every selected entity (setq i 0) (repeat (sslength ss) (change_layer_color_ltp (ssname ss i)) (setq i (+ i 1)) ) (princ) )

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

Very nice @hanhphuc. You cannot select the first or last segment though, perhaps (defun c:aaa ( / ang en i k l p p1 ep pp np) (and (mapcar 'set '(en p) (entsel "Pick segment on LWPOLYLINE.. ")) (setq p1 (osnap p "nea")) (setq p (trans p1 1 0)) (setq i (fix (vlax-curve-getparamatpoint en p))) (setq ep (vlax-curve-getEndParam en)) (setq np (if (= i (1- ep)) 0 (1+ i))) (setq pp (if (zerop i) (1- ep) (1- i))) (>= ep 3) ;(< 0 i (1- ep)) (setq ang (mapcar ''((x) (angle '(0. 0. 0.) (vlax-curve-getFirstDeriv en x))) (list pp np))) (while (and p (mapcar 'set '(k p) (grread t 13)) (= 5 k) (setq p1 (trans p 1 0)) ) (redraw) (setq l (mapcar ''((a b / p) (list (setq p (vlax-curve-getPointAtParam en b)) (inters p (polar p a 1.0) p1 (polar p1 (angle '(0. 0. 0.) (vlax-curve-getFirstDeriv en i)) 1.0 ) nil) ) ) ang (list i np);(1+ i)) ) ) (grvecs (apply 'append (mapcar ''((x) (cons (car x) (mapcar ''((x) (trans x 0 1)) (cdr x)))) (cons (cons 2 (mapcar 'cadr l)) (mapcar ''((x) (cons 2 x)) l))))) ) ) (princ) )

As regards your concerns, you have not included the raster image, so I cannot see what is happening. The previous comments are helped by a crystal ball.

Try this (repeat (setq x (length lst)) (setq pt (nth (setq x (- x 1)) lst)) (command "circle" pt 3.0) )

try this AD-Automatic Dimension Autocad.LSP

dlanorh I was having problem with angle 0.0 draw a rectang, (> azi 0.0) what about 0.0 in cond, good idea using vlax-curve. ;simple clock wise test by Gile (defun gc:clockwise-p ( p1 p2 p3 ) (< (sin (- (angle p1 p3) (angle p1 p2))) -1e-14))

@hosneyalaa are you after a solution or just ideas?

For me pick point, use ssget "F" actually a polygon keep increasing till ssget find 2 circles then like marko use TTR with random radius. The approx. tan point is circle cen to picked point intersection. Interesting idea have done a few random patterns including a 3d tree ball of leaves. Try this includes 1st 2 circles, note it seems to work as it tries to find only 2 circles so if it misses keeps going no real check for after 50. Circles should be radius 1 to 30. Big circle be a little away small up closer. Note the Briscad polygon difference, need to find the check what am I running know about product key but Briscad does not like something when using it. ;; Rand - Lee Mac ;; PRNG implementing a linear congruential generator with ;; parameters derived from the book 'Numerical Recipes' (defun LM:rand ( / a c m ) (setq m 4294967296.0 a 1664525.0 c 1013904223.0 $xn (rem (+ c (* a (cond ($xn) ((getvar 'date))))) m) ) (/ $xn m) ) (defun LM:randrange (a b) (+ (min a b) (* (LM:rand) (abs (- a b)))) ) ; Adds a random radius circle berween 2 existing circles. ; By AlanH March 2020 info@alanh.com.au (defun c:3rdcirc (/ pt obj1 obj2 obj3 inc cen intpt1 intpt2 rad ss) (vl-load-com) (setq rad (fix (1+ (LM:randrange 1 30)))) (command "circle" (getpoint "\pick point for 1st circle") rad) (command "circle" (getpoint "\pick point for 2nd circle") rad) (while (setq pt (getpoint "\npick a point Enter to exit")) (setq inc 1.0) (setq rad (fix (1+ (LM:randrange 1 30)))) (while (< inc 50) (command "polygon" 20 pt "I" inc) ; Autocad ; (command "polygon" 20 pt (polar pt 0.0 inc)) ; Briscad (setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (entlast))))) (setq ss (ssget "F" co-ord (list (cons 0 "circle")))) (if (and (/= ss nil) (= (sslength ss) 2)) (progn (setq inc 51) (command "erase" (entlast) "") (setq obj1 (vlax-ename->vla-object (ssname ss 0))) (setq cen (vlax-get Obj1 'Center)) (command "line" cen pt "") (setq obj3 (vlax-ename->vla-object (entlast))) (setq intpt1 (vlax-invoke obj3 'intersectWith obj1 acExtendNone)) (command "erase" (entlast) "") (setq obj2 (vlax-ename->vla-object (ssname ss 1))) (setq cen (vlax-get Obj2 'Center)) (command "line" cen pt "") (setq obj3 (vlax-ename->vla-object (entlast))) (setq intpt2 (vlax-invoke obj3 'intersectWith obj2 acExtendNone)) (command "erase" (entlast) "") (command "circle" "TTR" intpt1 intpt2 Rad) ) (progn (setq inc (+ inc 1.0)) (command "erase" (entlast) "") ) ) ) ) (princ) ) (c:3rdcirc)

Thanks Alan

@amir0914 Just noticed a bug. Have updated above code

Try removing "X" from the SSGET (ssget '((-4 . "<OR") (0 . "MTEXT") (0 . "TEXT") (0 . "attdef") (0 . "dimension") (0 . "leader") (0 . "multileader") (-4 . "OR>"))))

What if the circle is located at the vertex of the polyline? Offset it at half the angle formed between the two lines?

I didn't thought you'd be doing that. I simply thought it was just an arc. A better way to approach that is if you select all lines or curves) that "goes below" (or doesn't change), then select the one polyline to curve or "go above" as shown in your desired result. With the help of LM:intersectionbetweensets by Lee Mac, this can be accomplished as shown in the gif below Assuming that the "purple" lines doesn't go too close the vertex of the polyline to "go above", the code to do as such is below: ;; Intersections Between Sets - Lee Mac ;; Returns a list of all points of intersection between objects in two selection sets. ;; ss1,ss2 - [sel] Selection sets (defun LM:intersectionsbetweensets ( ss1 ss2 / id1 id2 ob1 ob2 rtn ) (repeat (setq id1 (sslength ss1)) (setq ob1 (vlax-ename->vla-object (ssname ss1 (setq id1 (1- id1))))) (repeat (setq id2 (sslength ss2)) (setq ob2 (vlax-ename->vla-object (ssname ss2 (setq id2 (1- id2)))) rtn (cons (LM:intersections ob1 ob2 acextendnone) rtn) ) ) ) (apply 'append (reverse rtn)) ) ;; Intersections - Lee Mac ;; Returns a list of all points of intersection between two objects ;; for the given intersection mode. ;; ob1,ob2 - [vla] VLA-Objects ;; mod - [int] acextendoption enum of intersectwith method (defun LM:intersections ( ob1 ob2 mod / lst rtn ) (if (and (vlax-method-applicable-p ob1 'intersectwith) (vlax-method-applicable-p ob2 'intersectwith) (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)) ) (repeat (/ (length lst) 3) (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn) lst (cdddr lst) ) ) ) (reverse rtn) ) (defun c:linearc ( / *error* above activeundo acadobj adoc ang arc below msp rad) (defun *error* ( msg ) (setvar "CMDECHO" cmd) (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)) (princ "\nSelect curves that goes below: ") (if (setq cmd (getvar "CMDECHO") below (ssget '((0 . "LINE,*POLYLINE,CIRCLE,ARC,ELLIPSE,SPLINE"))) ) (progn (setq rad (progn (initget 1) (getreal "\nSpecify radius of arc: "))) (while (progn (setq above (entsel "\nSelect curve that goes above: ")) (cond ((null above) (princ "\nNothing selected")) ((not (wcmatch (cdr (assoc 0 (entget (car above)))) "LINE,*POLYLINE,CIRCLE,ARC,ELLIPSE,SPLINE")) (princ "\nObject is not a curve") ) ((setq above (car above)) nil) ) ) ) (setvar "CMDECHO" 0) (foreach x (vl-sort (LM:intersectionsbetweensets below (ssadd above)) '(lambda (a b) (< (vlax-curve-getParamAtPoint above a) (vlax-curve-getParamAtPoint above b) ) ) ) (if (< (* 0.5 pi) (setq ang (angle '(0 0 0) (vlax-curve-getFirstDeriv above (vlax-curve-getParamAtPoint above x)))) (* 1.5 pi) ) (setq ang (+ pi ang)) ) (setq arc (entmakex (list '(0 . "ARC") (cons 10 x) (cons 40 rad) (cons 50 ang) (cons 51 (+ pi ang)) ) ) ) (command "_break" above (polar x ang rad) (polar x (+ pi ang) rad)) (setq above (entnext arc)) ) (setvar "CMDECHO" cmd) ) ) (if activeundo nil (vla-EndUndoMark adoc)) (princ) ) The arc is drawn under the assumption that the intersection point is a straight line, and thus the angle between the arc is 180. If you were to select it on a circle, you'll notice that the arc and line won't be in line, but I think this will be quite enough with what you need to achieve. Thanks, Jonathan Handojo

Try this Command FIB (for Find In Block), select block ... It will print the insert point of the circle within the block, and outside the block (see if this works) (vl-load-com) ;; iterates through the items inside a block. Returns the searched item (for example "CIRCLE") (DEFUN find_in_block (blkname tag / od_ent res) (SETQ od_ent (TBLOBJNAME "BLOCK" blkname )) (WHILE (SETQ od_ent (ENTNEXT od_ent)) (if (= tag (cdr (assoc 0 (entget od_ent)))) (setq res od_ent) ) ) res ) (defun geteffectivename ( ent / ) (vla-get-Effectivename (vlax-ename->vla-object ent)) ) (defun c:fib ( / ent blkname subent ip_ins ang_ins ip ang sc dist) (setq ent (car (entsel "\nSelect block: "))) ;;(setq blkname (cdr (assoc 2 (entget ent)))) (setq blkname (geteffectivename ent)) (setq subent (find_in_block blkname "CIRCLE")) ;; get the Insert Point (princ "\nInsert point of the circle inside the block: ") (princ (setq ip_ins (cdr (assoc 10 (entget subent))))) (setq ang_ins (angle (list 0.0 0.0 0.0) ip_ins)) ;; now let's add that to where the block was inserted, including rotation and scale (setq ip (cdr (assoc 10 (entget ent)))) (setq ang (cdr (assoc 50 (entget ent)))) (setq sc (cdr (assoc 41 (entget ent)))) ;; I will assume uniform scale (princ "\nInsert point of the circle outside the block: ") (princ (polar ip (+ ang ang_ins) (* sc (distance (list 0.0 0.0 0.0) ip_ins) ) ) ) (princ) )

Ah, your function is in a while loop... makes sense. Then... (defun First_Routine nil (while (progn ; your code (initget 1 "Yes No") (if (eq (getkword "\nProceed to Second_Routine? [Yes/No]: ") "Yes") (progn (Second_Routine) T) ) ) ) ) (defun Second_Routine nil (alert "\nI'm in Routine B") )

Um... there are two commands in there: Polyoutline and MPolyoutline. You might want to use MPolyoutline.

You could try this oldie (defun c:detachx ( / *error* c_doc c_blks b_str ss cnt obj) (defun *error* ( msg ) (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nAn Error : " msg " occurred."))) (princ) );_end_*error*_defun (setq c_doc (vla-get-activedocument (vlax-get-acad-object)) c_blks (vla-get-blocks c_doc) );end_setq (vlax-for blk c_blks (if (= :vlax-true (vlax-get-property blk 'isxref)) (setq b_str (strcat b_str "," vlax-get-property blk 'name))) );end_for (setq b_str (vl-string-trim "," b_str) ss (ssget "_X" (list '(0 . "INSERT") '(410 . "Model") (cons 2 b_str))) );end_setq (cond (ss (repeat (setq cnt (sslength ss)) (setq obj (vlax-ename->vla-object (ssname ss (setq cnt (1- cnt))))) (vla-detach obj) );end_repeat ) );end_cond (princ) );end_defun There are no checks for locked layers, so ensure all relevant layers are unlocked. I would also test it on a copy of a drawing first.

Be careful but you can use regedit and search to find the answer. Mine returned Australia.

That is not what @Lee Mac meant. You need to use regedit to find the name of the correct Key/Val pair. In my case this was "sCountry" Then (vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sCountry") Gave me United Kingdom

That's not what I suggested, and you haven't escaped the backslashes. Open regedit, browse to the location indicated, and examine the set of subkeys to understand which you require.

You don't need to mirror the block, just rotate it pi radians (180degrees). If you know the insertion point and the end of line 2, you can test if the angle (line1 ip) Line2 ip) (end line2) is clockwise or ccw. Depending on result rotate or not. This code function by Gilles will test whether the angle is clockwise or ccw. It requires 3 points in order of the direction. (defun gc:clockwise-p ( p1 p2 p3 ) (< (sin (- (angle p1 p3) (angle p1 p2))) -1e-14))

Assuming that you are looking to return the smallest section of the string which matches the supplied pattern, you could use a function such as the following: (defun LM:wcmatchx ( str pat ) (if (wcmatch str pat) (cond ( (LM:wcmatchx (substr str 2) pat)) ( (LM:wcmatchx (substr str 1 (1- (strlen str))) pat)) ( str ) ) ) ) For example: _$ (LM:wcmatchx "abc123def" "*###*") "123" But this relatively simplistic approach isn't bulletproof and may not be applicable to all conceivable wcmatch pattern & string combinations. A more robust approach might be to turn to Regular Expressions and use the Execute method.

I have the following, but there are still some bugs -

You're welcome.

Are you hoping to make it look more Pro Steely? Try as shown in the screenshot. Drawing1.dwg

Yes, that would work for objects residing in Modelspace. Though, as Stefan has noted above, be aware that the program will error with objects which do not meet the criteria for a region, so you may wish to include some error trapping to either prevent the user from selecting invalid objects, or a vl-catch-all-apply expression as used by Stefan to catch the error should an invalid object be selected. For objects residing in any space, consider the following method: (defun c:reg ( / doc ent obj ) (if (setq ent (car (entsel))) (progn (setq obj (vlax-ename->vla-object ent) doc (vla-get-activedocument (vlax-get-acad-object)) ) (vlax-invoke (if (vlax-method-applicable-p doc 'objectidtoobject32) (vla-objectidtoobject32 doc (vla-get-ownerid32 obj)) (vla-objectidtoobject doc (vla-get-ownerid obj)) ) 'addregion (list obj) ) ) ) (princ) ) (vl-load-com)