Leaderboard

Assuming I've understood what you're looking to achieve, you could potentially use the sendcommand method to accomplish this, i.e.: (defun c:ctext ( / ent enx str ) (while (not (progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect command text: "))) (cond ( (= 7 (getvar 'errno)) (prompt "\nMissed, try again.") ) ( (null ent)) ( (not (wcmatch (cdr (assoc 0 (setq enx (entget ent)))) "*TEXT")) (prompt "\nThe selected object is not text or mtext.") ) ( (setq str (cdr (assoc 1 enx)))) ) ) ) ) (if str (vla-sendcommand (vla-get-activedocument (vlax-get-acad-object)) (strcat str "\n"))) (princ) ) (vl-load-com) (princ)

(vl-load-com) (defun c:ARCTEST ( / ss ssl index tlist ent obj elist arclist arcrad arccenter arcalongcenter ll ur lll url midpt unitvect1 xline1 xlineobj unitvect2 ray1 tlen resultss 1text 1textcen cen2cen ray2 interpt) (setq ss (ssget '((0 . "ARC,TEXT")))) (setq ssl (sslength ss)) (setq index 0) (setq tlist '()) (repeat ssl (setq ent (ssname ss index)) (setq obj (vlax-ename->vla-object ent)) (setq elist (entget ent)) (cond ((eq (cdr (assoc 0 elist)) "ARC") (setq arclist (LM:ArcEndpoints ent)) (setq arcrad (cdr (assoc 40 elist))) (setq arccenter (cdr (assoc 10 elist))) (setq arcalongcenter (vlax-curve-getPointAtDist obj (/ (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj ) ) 2 ) ) ) ) ((eq (cdr (assoc 0 elist)) "TEXT") (vla-getboundingbox obj 'll 'ur) (setq lll (vlax-safearray->list ll)) (setq url (vlax-safearray->list ur)) (setq midpt (mapcar '* (mapcar '+ lll url) '(0.5 0.5 0.5))) (setq tlist (cons (list ent midpt) tlist)) ) ) (setq index (+ index 1)) ) (setq unitvect1 (mapcar '(lambda (x) (/ x (distance (car arclist) (cadr arclist)))) (mapcar '- (cadr arclist) (car arclist)))) (setq xline1 (entmakex (list (cons 0 "XLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbXline") (cons 10 (cadr arclist)) (cons 11 unitvect1) ) ) ) (setq xlineobj (vlax-ename->vla-object xline1)) (setq unitvect2 (mapcar '(lambda (x) (/ x (distance arcalongcenter arccenter))) (mapcar '- arccenter arcalongcenter))) (setq ray1 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 arcalongcenter) (cons 11 unitvect2) ) ) ) (setq tlen (length tlist)) (setq index 0) (setq resultss (ssadd)) (repeat tlen (setq 1text (nth index tlist)) (setq 1textcen (cadr 1text)) (setq cen2cen (distance 1textcen arccenter)) (if (<= cen2cen arcrad) (progn (ssadd (car 1text) resultss) ) (progn (setq ray2 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 1textcen) (cons 11 unitvect2) ) ) ) (setq interpt (LM:intersections xlineobj (vlax-ename->vla-object ray2) acextendnone)) (if (= interpt nil) (progn (ssadd (car 1text) resultss) ) (progn) ) (entdel ray2) ) ) (setq index (+ index 1)) ) (sssetfirst nil resultss) (entdel xline1) (entdel ray1) (princ) ) ;; 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) ) ;; Arc Endpoints - Lee Mac ;; Returns the endpoints of an Arc expressed in WCS (defun LM:ArcEndpoints (ent / cen nrm rad) (setq ent (entget ent) nrm (cdr (assoc 210 ent)) cen (cdr (assoc 010 ent)) rad (cdr (assoc 040 ent)) ) (mapcar (function (lambda (ang) (trans (mapcar '+ cen (list (* rad (cos ang)) (* rad (sin ang)) 0.0)) nrm 0 ) ) ) (list (cdr (assoc 50 ent)) (cdr (assoc 51 ent))) ) ) how does it works, step by step gif. (vl-load-com) (defun c:ARCTEST ( / ss ssl index tlist ent obj elist arclist arcrad arccenter arcalongcenter ll ur lll url midpt unitvect1 xline1 xlineobj unitvect2 ray1 tlen resultss 1text 1textcen cen2cen ray2 interpt circleent) (setq ss (ssget '((0 . "ARC,TEXT")))) (setq ssl (sslength ss)) (setq index 0) (setq tlist '()) (repeat ssl (setq ent (ssname ss index)) (setq obj (vlax-ename->vla-object ent)) (setq elist (entget ent)) (cond ((eq (cdr (assoc 0 elist)) "ARC") (setq arclist (LM:ArcEndpoints ent)) (setq arcrad (cdr (assoc 40 elist))) (setq arccenter (cdr (assoc 10 elist))) (setq arcalongcenter (vlax-curve-getPointAtDist obj (/ (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj ) ) 2 ) ) ) ) ((eq (cdr (assoc 0 elist)) "TEXT") (vla-getboundingbox obj 'll 'ur) (setq lll (vlax-safearray->list ll)) (setq url (vlax-safearray->list ur)) (setq midpt (mapcar '* (mapcar '+ lll url) '(0.5 0.5 0.5))) (setq tlist (cons (list ent midpt) tlist)) ) ) (setq index (+ index 1)) ) (setq unitvect1 (mapcar '(lambda (x) (/ x (distance (car arclist) (cadr arclist)))) (mapcar '- (cadr arclist) (car arclist)))) (setq xline1 (entmakex (list (cons 0 "XLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbXline") (cons 10 (cadr arclist)) (cons 11 unitvect1) ) ) ) (setq xlineobj (vlax-ename->vla-object xline1)) (setq unitvect2 (mapcar '(lambda (x) (/ x (distance arcalongcenter arccenter))) (mapcar '- arccenter arcalongcenter))) (setq ray1 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 arcalongcenter) (cons 11 unitvect2) ) ) ) (setq circleent (entmakex (list (cons 0 "CIRCLE") (cons 10 arccenter) (cons 40 arcrad)))) (setq tlen (length tlist)) (setq index 0) (setq resultss (ssadd)) (repeat tlen (setq 1text (nth index tlist)) (setq 1textcen (cadr 1text)) (setq cen2cen (distance 1textcen arccenter)) (if (<= cen2cen arcrad) (progn (ssadd (car 1text) resultss) (vlax-put-property (vlax-ename->vla-object (car 1text)) 'textstring "Gotcha (Circle)") (vlax-put-property (vlax-ename->vla-object (car 1text)) 'color 2) ) (progn (setq ray2 (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 1textcen) (cons 11 unitvect2) ) ) ) (setq interpt (LM:intersections xlineobj (vlax-ename->vla-object ray2) acextendnone)) (if (= interpt nil) (progn (ssadd (car 1text) resultss) (vlax-put-property (vlax-ename->vla-object (car 1text)) 'textstring "Gotcha (Ray)") (vlax-put-property (vlax-ename->vla-object (car 1text)) 'color 3) ) (progn) ) (setq answer (getstring)) (entdel ray2) ) ) (setq index (+ index 1)) ) (sssetfirst nil resultss) (entdel xline1) (entdel circleent) (entdel ray1) (princ) ) ;; 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) ) ;; Arc Endpoints - Lee Mac ;; Returns the endpoints of an Arc expressed in WCS (defun LM:ArcEndpoints (ent / cen nrm rad) (setq ent (entget ent) nrm (cdr (assoc 210 ent)) cen (cdr (assoc 010 ent)) rad (cdr (assoc 040 ent)) ) (mapcar (function (lambda (ang) (trans (mapcar '+ cen (list (* rad (cos ang)) (* rad (sin ang)) 0.0)) nrm 0 ) ) ) (list (cdr (assoc 50 ent)) (cdr (assoc 51 ent))) ) )

I thought you already got an answer from another forum? Here's a quick one for fun .. prints results to the command line: (defun c:foo (/ a l n r s) (cond ((setq s (ssget '((0 . "ARC")))) ;; Add lengths to this list sorted smallest to largest (setq l (vl-sort '(1.2 1.5 2.0 2.5) '<)) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) (setq n (vla-get-arclength (vlax-ename->vla-object e))) (if (setq n (vl-some '(lambda (x) (if (<= n x) x)) l)) (if (setq a (assoc n r)) (setq r (subst (list n (1+ (cadr a))) a r)) (setq r (cons (list n 1) r)) ) (print "NO CABLE LENGTH FOUND!") ) ) (print (vl-sort r '(lambda (r j) (< (car r) (car j))))) ) ) (princ) )

This only assumes the horizontal and vertical lines are drawn in UCS, and not WCS: (defun c:vmirror nil (OnePointMirror '(00 10 00))) (defun c:hmirror nil (OnePointMirror '(10 00 00))) (defun OnePointMirror (dir / ss pt) (and (setq ss (ssget "_:L")) (setq pt (getpoint "\nSpecify base point <exit>: ")) (command "_mirror" ss "" "_non" pt "_non" (mapcar '+ dir pt) "No") ;; <--- Change to Yes to delete source object, or \\ to prompt user. (while (not (zerop (getvar "cmdactive"))) (command "")) ) (princ) ) And while this may be off the OP, this might be worth looking at as well: Quick Mirror.

Try something like this - change the value of the two variables at the top of the code to suit: (defun c:test ( / bln idx lst nla pat ) (setq pat "*block*" nla "NewLayer" pat (strcase pat) ) (if (setq sel (ssget '((0 . "INSERT")))) (repeat (setq idx (sslength sel)) (setq idx (1- idx) bln (cdr (assoc 2 (entget (ssname sel idx)))) ) (if (not (member bln lst)) (progn (setq lst (cons bln lst)) (processblock bln pat nla) ) ) ) ) (princ) ) (defun processblock ( bln str lay / ent ) (if (setq ent (tblobjname "block" bln)) (while (setq ent (entnext ent)) (processobject ent str lay) ) ) ) (defun processobject ( ent str lay / bln enx ) (cond ( (not (setq enx (entget ent)))) ( (/= "INSERT" (cdr (assoc 0 enx)))) ( (not (wcmatch (setq bln (strcase (cdr (assoc 2 enx)))) str)) (processblock bln str lay) ) ( (entmod (subst (cons 8 lay) (assoc 8 enx) enx)) (processblock bln str lay) ) ) ) (princ)

(vl-load-com) (defun c:wrap ( / acdoc *error* oldcmdecho ss0 ssl0 index ent bb ss ssl ptlist elist pt1 ptlist chlist chent textflag obj box lll url ) (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))) (setq oldcmdecho (getvar 'cmdecho)) (defun *error* ( msg ) (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (vla-EndUndoMark acdoc) (setvar 'cmdecho oldcmdecho) (princ) ) (defun LWPolybylist (lst cls) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls) ) (mapcar (function (lambda (p) (cons 10 p))) lst) ) ) ) (vla-StartUndoMark acdoc) (setvar 'cmdecho 0) (setq ss0 (ssget)) (setq ssl0 (sslength ss0)) (setq index 0) (setq textflag 0) (setq ptlist '()) (repeat ssl0 (setq ent (ssname ss0 index)) (setq elist (entget ent)) (if (or (eq (cdr (assoc 0 elist)) "TEXT") (eq (cdr (assoc 0 elist)) "MTEXT") (eq (cdr (assoc 0 elist)) "INSERT")) (progn (setq textflag 1) (setq obj (vlax-ename->vla-object ent)) (setq box (vla-getboundingbox obj 'll 'ur)) (setq lll (vlax-safearray->list ll)) ; lower left point (setq url (vlax-safearray->list ur)) ; upper right point (setq ent (LWPolybylist (list lll (list (car url) (cadr lll)) url (list (car lll) (cadr url))) 1)) ) (progn ) ) (setq ptlist (append (LM:ent->pts ent 100) ptlist)) ;(command "_.DIVIDE" ent 100 "") (if (= textflag 1) (entdel ent) ) (setq textflag 0) (setq index (+ index 1)) ) (setvar 'cmdecho oldcmdecho) (setq bb (LM:ssboundingbox ss0)) ;(if (setq ss (ssget "_C" (car bb) (cadr bb) '((0 . "POINT")))) ; (progn ; (setq ssl (sslength ss)) ; (setq index 0) ; (repeat ssl ; (setq ent (ssname ss index)) ; (setq elist (entget ent)) ; (setq pt1 (cdr (assoc 10 elist))) ; (setq ptlist (cons pt1 ptlist)) ; (entdel ent) ; (setq index (+ index 1)) ; ) ; ) ;) ;(princ ptlist) (setq chlist (LM:ConvexHull ptlist)) (setq chent (entmakex (append (list '(000 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length chlist)) '(070 . 1) ) (mapcar '(lambda ( x ) (cons 10 x)) chlist) ) ) ) (vla-EndUndoMark acdoc) (princ) ) ;; Convex Hull - Lee Mac ;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points. (defun LM:ConvexHull ( lst / ch p0 ) (cond ( (< (length lst) 4) lst) ( (setq p0 (car lst)) (foreach p1 (cdr lst) (if (or (< (cadr p1) (cadr p0)) (and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0))) ) (setq p0 p1) ) ) (setq lst (vl-sort lst (function (lambda ( a b / c d ) (if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (< (distance p0 a) (distance p0 b)) (< c d) ) ) ) ) ) (setq ch (list (caddr lst) (cadr lst) (car lst))) (foreach pt (cdddr lst) (setq ch (cons pt ch)) (while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt)) (setq ch (cons pt (cddr ch))) ) ) ch ) ) ) ;; Clockwise-p - Lee Mac ;; Returns T if p1,p2,p3 are clockwise oriented or collinear (defun LM:Clockwise-p ( p1 p2 p3 ) (< (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1))) (* (- (cadr p2) (cadr p1)) (- (car p3) (car p1))) ) 1e-8 ) ) ;; 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)) ) ) ;; Entity to Point List - Lee Mac ;; Returns a list of WCS points describing or approximating the supplied entity, else nil if the entity is not supported. ;; ent - [ent] Entity name to be described by point list (POINT/LINE/ARC/CIRCLE/LWPOLYLINE/POLYLINE/ELLIPSE/SPLINE) ;; acc - [num] Positive number determining the point density for non-linear objects (defun LM:ent->pts (ent acc / ang bul cen cls di1 di2 enx inc itm lst num ocs rad tot typ vt1 vt2 vtl ) (setq enx (entget ent) typ (cdr (assoc 0 enx)) ) (cond ((= "POINT" typ) (list (cdr (assoc 10 enx))) ) ((= "LINE" typ) (mapcar '(lambda (x) (cdr (assoc x enx))) '(10 11)) ) ((or (= "ARC" typ) (= "CIRCLE" typ)) (if (= "ARC" typ) (setq ang (cdr (assoc 50 enx)) tot (rem (+ pi pi (- (cdr (assoc 51 enx)) ang)) (+ pi pi)) num (fix (+ 1.0 1e-8 (* acc (/ tot (+ pi pi))))) inc (/ tot (float num)) num (1+ num) ) (setq ang 0.0 tot (+ pi pi) num (fix (+ 1e-8 acc)) inc (/ tot (float num)) ) ) (setq cen (cdr (assoc 010 enx)) rad (cdr (assoc 040 enx)) ocs (cdr (assoc 210 enx)) ) (repeat num (setq lst (cons (trans (polar cen ang rad) ocs 0) lst) ang (+ ang inc) ) ) (reverse lst) ) ((or (= "LWPOLYLINE" typ) (and (= "POLYLINE" typ) (zerop (logand (logior 16 64) (cdr (assoc 70 enx)))) ) ) (if (= "LWPOLYLINE" typ) (setq vtl (LM:ent->pts:lwpolyvertices enx)) (setq vtl (LM:ent->pts:polyvertices ent)) ) (if (setq ocs (cdr (assoc 210 enx)) cls (= 1 (logand 1 (cdr (assoc 70 enx)))) ) (setq vtl (append vtl (list (cons (caar vtl) 0.0)))) ) (while (setq itm (car vtl)) (setq vtl (cdr vtl) vt1 (car itm) bul (cdr itm) lst (cons (trans vt1 ocs 0) lst) ) (if (and (not (equal 0.0 bul 1e-8)) (setq vt2 (caar vtl))) (progn (setq rad (/ (* (distance vt1 vt2) (1+ (* bul bul))) 4.0 bul) cen (polar vt1 (+ (angle vt1 vt2) (- (/ pi 2.0) (* 2.0 (atan bul)))) rad ) rad (abs rad) tot (* 4.0 (atan bul)) num (fix (+ 1.0 1e-8 (* acc (/ (abs tot) (+ pi pi))))) inc (/ tot (float num)) ang (+ (angle cen vt1) inc) ) (repeat (1- num) (setq lst (cons (trans (polar cen ang rad) ocs 0) lst) ang (+ ang inc) ) ) ) ) ) (reverse (if cls (cdr lst) lst)) ) ((= "ELLIPSE" typ) (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent)) di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) di2 (- di2 1e-8) ) (while (< di1 di2) (setq lst (cons (vlax-curve-getpointatdist ent di1) lst) rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatdist ent di1 ) ) ) di1 (+ di1 (/ di2 (1+ (fix (* acc (/ di2 rad (+ pi pi))))))) ) ) (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)) ) ) ((= "SPLINE" typ) (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent)) di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) lst (list (vlax-curve-getstartpoint ent)) inc (/ (- di2 di1) (float acc)) di1 (+ di1 inc) ) (repeat (1- (fix (+ 1e-8 acc))) (setq lst (cons (vlax-curve-getpointatdist ent di1) lst) di1 (+ di1 inc) ) ) (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)) ) ) ) ) (defun LM:ent->pts:lwpolyvertices (enx / elv lst vtx) (setq elv (list (cdr (assoc 38 enx)))) (while (setq vtx (assoc 10 enx)) (setq enx (cdr (member vtx enx)) lst (cons (cons (append (cdr vtx) elv) (cdr (assoc 42 enx))) lst) ) ) (reverse lst) ) (defun LM:ent->pts:polyvertices (ent / lst vte vtx) (setq vte (entnext ent) vtx (entget vte) ) (while (= "VERTEX" (cdr (assoc 0 vtx))) (setq lst (cons (cons (cdr (assoc 10 vtx)) (cdr (assoc 42 vtx))) lst) vte (entnext vte) vtx (entget vte) ) ) (reverse lst) ) this routine wraps edges together rather than connecting right angle extension lines, so it may not suit your purpose..... so this is just for reference. I personally used this when I wanted to combine separate areas while using UNION for REVCLOUD command.

Thanx for reminding me again to this program Bigal but I can't install anything on work computer. PC (laptop) is scanned continuously, it sounds like a vacuum cleaner because of all the scanning going on. AutoCad (cloud based) crashes a few times a day , I suspect due to this scanning because most cpu time is used up by this process. I only find comfort in the fact all my colleagues suffer with me haha

I've created a tool to assist me with a mammoth job I'm working on right now. I have to dig through an enormous amount of folders and data to catalog everything and search for lost and relevant data , in all sorts of format , dwg , doc , excell etc. Purpose of app I gave birth to this time is to present data in whatever form that's best for daddy (or mommy? ... nah dragons don't have this problem) Anyways , I'm on a quota so have to deliver certain amount of data in a certain amount of time and have to put in spare time when behind schedule so no time to explain everything so I hope interface explains itself. Also can't say for certain I've killed all bugs because ink is still wet. So short version : start app , type h for help , s for setup in Main dialog. In setup dialog you can create some test drawings or variables. Files can be represented as button , image_button , edit_box, list_box or toggle. App can also work in data mode. In main dialog you select folder (with drawings or doc's etc) , next extention (dwg, doc, xls ext) , action type (insert , open ...) and dcl type (button, edit_box etc) and ok. New dialog is created : Run dialog. here you can also type h for help. You can type r to rotate dialog , 4 = smaller , 6 is wider , 8 = higher , 2 = less higher and if dcl type is image_tile you can also use + & - keys to resize slides. Oh , thinks save button doesn't work yet. What else to tell... well , haven't done enough testing probably , and time will tell if this is gonna help me to achieve my goals or if its just another useless stupid program. I don't expect I will have much time for chitchat so have fun or trashcan... RlxIndexer.lsp

Consider something like the following: (while (not (or (= "" (setq nodwg (getstring "\nEnter the number <exit>: "))) (wcmatch nodwg "###") ) ) (princ "\nNumber must be in the range 001-999.") ) (if (/= "" nodwg) (progn ;; do stuff ) )

Hello everyone, I've been coding a lot the past few days and I just wanted to share my code for those who may have some use for them, and also for me to keep track of my progress. ;********************************************************; ;; MA:perp-test - Test if two angles are perpendicular ;; Arguments: ;; - a (float): First angle in radians ;; - b (float): Second angle in radians ;; - tol (float): Tolerance value for comparison ;; Returns: ;; - test (bool): True if the angles are perpendicular within the given tolerance, False otherwise ;; Usage: (MA:perp-test a b tol) (defun MA:perp-test (a b tol / test) (if (and a b tol) (if (< (abs (- (abs (cos a)) (abs (sin b)))) tol) (setq test T) (setq test nil) ) ) ) This is a very simple script for when you want to compare two angles, especially of blocks you're working with. This can be modified to where it has a default tolerance value for orthogonality, but that would be a good exercise for you guys to test for yourselves.

I just discovered this and anybody wanting to do things with Excel should welcome this, it has multiple functions. I use a couple of FIXO functions now and his efforts to talk to Excel had a huge catalogue. Please note these functions expect a coder has a good knowledge of lisp and how to use defuns etc. XLFIXOLIB.zip

Even simpler: (vl-remove-if 'distof lst)

@Clint OK - well since I have already done most of the work for you, I might was well give you a full solution. See the attached. I improved the code to have an UNDO group, and run quietly, eliminating the command echoing and displaying just the results. You will still need to alter the code for your desired old and new text styles. If the new text style is already in the drawing, it will just use what is defined rather than create it. ;|============================================================== CHTS.lsp written by Phil Kenewell - 3/19/2024 Description: This program converts all Text objects (TEXT, MTEXT, RTEXT) from one Text style to another, then purges the old text style. The desired styles need to be preset in the variables noted in the comments of the code. Last Update: Initial Release 3/20/2024 ===============================================================|; (defun C:CHTS (/ ce cnt d el NewFontFile NewTextHght NewTextoblq NewTextStyle NewTextWdth OldTextStyle ss ts) ;; Presets for Old and New Text style names. (setq OldTextStyle "MyoldStyle" ;; Old Style to Purge NewTextStyle "MyNewStyle" ;; New style to move text objects to NewFontFile "arial.ttf" ;; Font file for new Text. NewTextHght 0.0 ;; Preset hieght (if needed) for new text style NewTextWdth 1.0 ;; Width Factor (if needed) for new text style NewTextoblq 0.0 ;; Oblique angle (if needed) for new text style ) ;; Create an undo mark. (vla-startundomark (setq d (vla-get-activedocument (vlax-get-acad-object)))) ;; Save the values for cmdecho and textstyle. (setq ce (getvar "cmdecho") ts (getvar "textstyle")) ;; turn off cmdecho to clean up command line echoing. (setvar "cmdecho" 0) ;; Create a selection set of the Text Objects and Text Style: (setq ss (ssget "X" (list (cons 0 "*TEXT")(cons 7 OldTextStyle)))) ;; If the Style table does not have the new Style Name, Make it. (if (not (tblsearch "STYLE" NewTextStyle)) (command "._-style" NewTextStyle NewFontFile NewTextHght NewTextWdth NewTextoblq "_n" "_n") ) ;; If the selection set is found: (if ss ;; Iterate through the selection set - set counter to the length of the set: (repeat (setq cnt (sslength ss)) ;; Get the entity list of item in selection set. (setq el (entget (ssname ss (setq cnt (1- cnt)))) ;; Substitute the new Text Style name in place of the old one. el (subst (cons 7 NewTextStyle) (assoc 7 el) el) ) ;; Modify the entity. (entmod el) (if (= cnt 0)(princ (strcat "\n(" (itoa (sslength ss)) ") Text objects were changed to style \"" NewTextStyle "\"."))) ) (princ (strcat "\nNo Text objects with style \"" OldTextStyle "\" were found.")) ) ;; Purge the old Style. (vla-delete (vlax-ename->vla-object (tblobjname "STYLE" OldTextStyle))) (if (not (tblsearch "STYLE" OldTextStyle)) (princ (strcat "\nText Style \"" OldTextStyle "\" was successfully purged.")) ) ;; If the previously current text style was not the old style to be purged, then reset the text style to what it was. (if (/= ts OldTextStyle)(setvar "textstyle" ts)) ;; Set cmdecho to previous value (setvar "cmdecho" ce) ;; End the undo mark (vla-endundomark d) ;; exit quietly (princ) ) CHTS.lsp

I merged your threads. No need to create new threads for the same question.

(defun c:11 (/) (setq ent (vlax-ename->vla-object (car (entsel))) lat (vla-get-latitude ent) lon (vla-get-longitude ent) ) (alert (strcat "Latitude = " lat "\nLongitude = " lon)) )

Use DATE instead of CDATE: https://help.autodesk.com/view/ACD/2023/ENU/?guid=GUID-CBB24068-1654-4753-BE2E-1D0CE9700411 DATE stores the date value as a Julian date, which simply counts the number of days which have elapsed from a given epoch - as such, you can easily subtract two integer Julian date values to calculate the number of elapsed days between two dates, e.g.: (< 7 (- (getvar 'date) (atoi (getenv "TELNUMBERS")))) (assuming you have changed TELNUMBERS to store the DATE value instead of CDATE)

Cool, I saved this one. I just added a couple lines for settings. @cooldude224 My edit should help you with the position of the attribute (defun c:add_ATT (/ ss blk blk-lst atts-lst def AttObj obj2 text_height ip mode align) ;; settings. Feel free to adapt to your needs. ;; Feel free to change the settings from hard coded to user input. See below (setq text_height 2.5) (setq ip (list 0.0 0.0)) ;; insert point in the block (setq default_value "") ;; MODE: ;; (any combination of constants can be used by adding them together): ;; acAttributeModeNormal ;; acAttributeModeInvisible ;; acAttributeModeConstant ;; acAttributeModeVerify ;; acAttributeModePreset (setq mode acAttributeModeNormal) ;; Allignment: ;; acAlignmentLeft / acAlignmentCenter / acAlignmentRight / acAlignmentAligned / acAlignmentMiddle / acAlignmentFit / acAlignmentTopLeft / acAlignmentTopCenter / acAlignmentTopRight / acAlignmentMiddleLeft / acAlignmentMiddleCenter / acAlignmentMiddleRight / acAlignmentBottomLeft / acAlignmentBottomCenter / acAlignmentBottomRight (setq align acAlignmentRight) ;; COMMENT OUT THESE NEXT LINES IF YOU WANT THE HARD CODED SETTINGS (setq text_height (getdist "\nText height: ")) (setq ip (getpoint "\nInsert point: ")) (setq default_value (getstring "\nDefault value: " T)) (vl-load-com) (setq Tag (strcase (getstring "\nSpecify attribute tag: "))) (if (setq ss (ssget '((0 . "INSERT")))) ;change if to while repeats command if you keep selecting things (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS))) ;makes a list of all entitys by ename in selection set and steps thought them one at a time (setq blk (cdr (assoc 2 (entget e)))) (if (not (vl-position blk blk-lst)) (progn (setq blk-lst (cons blk blk-lst)) (setq obj2 (vlax-ename->vla-object e)) (setq atts-lst nil) ;clear list from last use (if (= (vla-get-hasattributes obj2) :vlax-true) (foreach att (vlax-invoke obj2 'getattributes) (setq atts-lst (cons (strcase (vla-get-tagstring att)) atts-lst)) ;make a list of all Attributs tag names to check rather then checking them all individually ) ;;close foreach ) ;;close if (if (not (member tag atts-lst)) ;checks list for "SYSTEM" could also use vl-position (progn (setq def (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) blk)) ;; VL : RetVal = (vla-AddAtribute object Height Mode Prompt InsertionPoint Tag Value) (setq AttObj (vla-addattribute def text_height mode "" (vlax-3D-point ip) TAG default_value)) (vlax-put AttObj 'Alignment align) (vla-move AttObj (vlax-3D-point (list 0.0 0.0)) (vlax-3D-point ip)) (command "_.attsync" "_N" blk) ) ;;close progn ) ;;close if ) ;;close progn ) ;;close if ) ;;close foreach ) ;;close if (princ) )

Drafting correctly in the 1st place should remove the problems. There is some code out there that looks at miss closes, but its not mine.

I still believe making a mnu is the way to go they are so easy to make, you can have hundreds of lisps at your mouse click, they can be loaded and ran, this is what the line would look like in the mnu file ^c^c(load "11") 11 ***MENUGROUP=NIKON ***POP20 **CADLIB [->LISP1 A-B] [11]^c^c(load "11") 11 [1/4 POINTS]^C^C(LOAD "1-4 POINTS") [Add 2 Level]^C^C(LOAD "add-to-levels") [Add-pits-drain]^C^C(LOAD"Add-pits-drain") [Allbylayer]^C^C(LOAD "Allbylayer") [Apndtext]^C^C^p(LOAD "apndtext") [Apparent int]^C^C^p(LOAD "apparent int") [Area-label]^C^C^p(LOAD "area-label") [Areaobj]^C^C^p(LOAD "AREAOBJ") [ARD layers]^C^C^Parduv7aclayerlistroadslocalnew [AttFind]^C^C^p(LOAD "AttFind") [average ht]^C^C^p(LOAD "average ht") [Batterticks]^C^C^p(load "batterticks") TBL [Blay]^C^C^p(LOAD "blay") [Blockrot]^C^C^p(LOAD "BLCKROT") [Blockscale]^C^C^p(LOAD "Blckscle") [Break path]^C^C^p(LOAD "Break path") dpath [<-] [->LISP2 C-D]

To run after select. (princ MyText) replace with (vl-cmdf mytext) Why would you have your run lisp programs as text ? Just make a menu if you can use notepad you can make a menu.

FYI... ChatGBT does not do lisp well. it can sometimes get you close but I have found personally a 85% failure rate. It makes up functions. Sometimes it's funny what it calls them... Sometimes it fills enough gaps so that if you know lisp you can fill in the needed parts. I do hope it gets better...

When you run cad it creates a lot of temporary files, these being saved in a directory that you can reset. The type of files are SV$ BAK DWL DCL and so on. You may be horrified how much stuff is in there. You will find the files by Options, Files, Temporary prefix (Bricscad) similar Acad. When running dcl's if you crash program a lot of ~00123.dcl will be created. So this will identify how many files you have, dont tick the boxes on, go have a look at the location. Move/copy anything you think you need else tick the file type box and they will be removed. ; clean up temp directory.. (defun cleanuptemp ( / files1 files2 files3 files4 files5 files6 files7 lst7 x val ans) (setq *files* (vla-get-files (vla-get-preferences (vlax-get-Acad-object)))) (setq pre (vla-get-TempFilePath *files*)) (alert (strcat "Your temp directory is " pre)) (setq lst7 '()) (setq files1 (vl-directory-files pre "*.BAK")) (if (= files1 nil) (setq lst7 (cons "0 BAK's " lst7)) (setq lst7 (cons (strcat (rtos (length files1) 2 0) " BAK's ") lst7)) ) (setq files2 (vl-directory-files pre "*.sv$")) (if (= files2 nil) (setq lst7 (cons "0 SV$'s " lst7)) (setq lst7 (cons (strcat (rtos (length files2) 2 0) " SV$'s " ) lst7)) ) (setq files3 (vl-directory-files pre "*.dwl*")) (if (= files3 nil) (setq lst7 (cons "0 DWL's " lst7)) (setq lst7 (cons (strcat (rtos (length files3) 2 0) " DWL's ") lst7)) ) (setq files4 (vl-directory-files pre "*.AC$")) (if (= files4 nil) (setq lst7 (cons "0 ac$'s " lst7)) (setq lst7 (cons (strcat (rtos (length files4) 2 0) " AC$'s " ) lst7)) ) (setq files5 (vl-directory-files pre "*.log")) (if (= files5 nil) (setq lst7 (cons "0 Logfile's" lst7)) (setq lst7 (cons (strcat (rtos (length files5) 2 0) " Logfile's ") lst7)) ) (setq files6 (vl-directory-files pre "~*.dcl")) (if (= files6 nil) (setq lst7 (cons "0 Temp DCL's " lst7)) (setq lst7 (cons (strcat (rtos (length files6) 2 0)" Temp DCL's " ) lst7)) ) (setq files7 (vl-directory-files pre "*.dmp")) (if (= files7 nil) (setq lst7 (cons "0 DMP's " lst7)) (setq lst7 (cons (strcat (rtos (length files7) 2 0)" DMP's " ) lst7)) ) (setq lst7 (reverse lst7)) (if (not AH:Toggs)(load "Multiple toggles.lsp")) (setq lst7 (cons "Pick to delete " lst7)) (setq ans (reverse (ah:toggs lst7))) (setq x 1) (foreach val ans (if (= val "1") (progn (foreach filename (eval (read (strcat "files" (rtos x 2 0)))) (vl-file-delete (strcat pre filename)) (princ (strcat "\n" filename)) ) ) ) (setq x (1+ x)) ) (princ) ) (cleanuptemp) Multi toggles.lsp

My $0.05 Did you use chatGP for code ? (defun c:evp2 ( / ssvp tel sc vlag obj) (setq ssvp (ssget "X" '((0 . "VIEWPORT")))) (if (= ssvp nil)(progn (alert "NO viewports selected \n \nWill exit now ")(exit))) (repeat (setq tel (sslength ssvp)) (setq obj (vlax-ename->vla-object (ssname ssvp (setq tel (1- tel))))) (setq sc (vlax-get obj 'customscale)) (cond ((equal sc 1.0 1e-03)(setq vlag 0)) ((equal sc 10.0 1e-03)(setq vlag 0)) ((equal sc 5.0 1e-03)(setq vlag 0)) ((equal sc 50.0 1e-03)(setq vlag 0)) ((setq vlag 1)) ) (if (= vlag 1) (progn (vlax-put obj 'color 1) (alert "One or more viewports have got a wrong scale ! \n \nNow RED color ") (setq vlag nil) ) ) ) (princ) ) (c:evp2 )

I'd typically opt for something like - (nth <param> (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 42 (car x))) <dxf-data>)))

Try this: The values for x, y scales and rotation should be a number, not a string (Number: 1 or string: "1") The point should be a list and not a string. - Replaced your El_mm line to keep it as a number (worth doing a check if this value comes from another LISP that it is a number) - 2 different options to calculate the point, P_fixed, the second half of the mapacar line is a good example how to set elevation to 0 (mapcar '* '(1 1 0) P)) - Insert as described above (defun c:test ( / ) (setq P (getpoint "Pick Point: \n")) ;; pick point (setq El_mm 105100) ;; New Elevation (setq P_fixed (mapcar '+ (list 0 0 El_mm) (mapcar '* '(1 1 0) P))) ;;Point at elevation ;;or (setq P_fixed (list (car p) (cadr pt) EL_mm)) ;;Point at elevation (command "-insert" "C:\\Myblock\\RBlock.dwg" P_fixed 1 1 0) )

If the R value of the inner and outer lines is the same, it's width is different in curve. Is it sure that picture you want? if YES, and T is smaller than R, you can use this routine. 1. set global width of polyline to T, by properties window (ctrl+1) 2. get outline of polylines by MPOLYOUTLINE http://www.lee-mac.com/polyoutline.html 3. make fillet in once by FMP. https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/fillet-multiple-polyline-all-at-once-by-lisp/m-p/6473166/highlight/true#M343470 if NO, 1. set global width of polyline to T, by properties window (ctrl+1) 2. make fillet in once by FMP. https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/fillet-multiple-polyline-all-at-once-by-lisp/m-p/6473166/highlight/true#M343470 3. get outline of polylines by MPOLYOUTLINE. (link is different from the one above.) http://www.lee-mac.com/advpolyoutline.html It is more advanced version of MPOLYOUTLINE, because it recognizes arcs, but it is difficult to execute on complex drawings. so before execution, the drawing must be simply organized.

Another. (mapcar '(lambda (j) (setq r nil) (mapcar '(lambda (k) (and (= (car j) (car k)) (setq r (cons (cadr j) r) r (cons (cadr k) r) ) ) ) lst2 ) (setq l (cons (if r (cons (car j) r) (list (car j) 0 (cadr j))) l)) ) lst1 ) (reverse l)

Because the tblobjname function returns an AcDbBlockBegin object for the Block Symbol Table so as to facilitate iterating over the block components (until an AcDbBlockEnd object is encountered); the AcDbBlockBegin class is derived from the AcDbEntity class, hence the equivalent ActiveX interface object is an IAcadEntity object. You can also observe this through the DXF data for the entities - tblobjname will return a BLOCK entity of class AcDbBlockBegin which is derived from the AcDbEntity base class: ( (-1 . <Entity name: 20458ff8900>) (0 . "BLOCK") (330 . <Entity name: 20458ff88a0>) (5 . "3C0") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockBegin") (70 . 0) (10 0.0 0.0 0.0) (-2 . <Entity name: 20458ff88b0>) (2 . "test") (1 . "") ) The parent entity is a BLOCK_RECORD entity of class AcDbBlockTableRecord which is derived from the AcDbSymbolTableRecord base class: ( (-1 . <Entity name: 20458ff88a0>) (0 . "BLOCK_RECORD") (5 . "3BA") (102 . "{ACAD_XDICTIONARY") (360 . <Entity name: 20458ff88e0>) (102 . "}") (330 . <Entity name: 20458fef810>) (100 . "AcDbSymbolTableRecord") (100 . "AcDbBlockTableRecord") (2 . "test") (360 . <Entity name: 20458ff8900>) (340 . <Entity name: 0>) (102 . "{BLKREFS") (331 . <Entity name: 20458ff8920>) (102 . "}") (70 . 4) (280 . 1) (281 . 0) )

You're welcome to use my implementation from here.

Here's one possible way - (vl-sort lst '(lambda ( a b ) (< (vl-position (atoi (cadr a)) dsd) (vl-position (atoi (cadr b)) dsd)))) Or, perhaps faster: (mapcar '(lambda ( n ) (nth n lst)) (vl-sort-i (mapcar '(lambda ( x ) (vl-position (atoi (cadr x)) dsd)) lst) '<)) Or, if you only want members that are present in dsd, you could use - (vl-remove nil (mapcar '(lambda ( x ) (car (vl-member-if '(lambda ( y ) (= x (atoi (cadr y)))) lst))) dsd))

Since you're using BricsCAD, you can use the isPropertyValid function to test whether the property is valid prior to obtaining it, e.g.: (defun c:test ( / ent ) (if (setq ent (car (entsel))) (if (ispropertyvalid ent "d1~MCAD") (print (getpropertyvalue ent "d1~MCAD")) (princ "\nProperty not valid.") ) ) (princ) )

(defun c:buildingelev ( / *error* pt ex:lwpline_by_list pt elev pt1 clr arrow1 arrow2 arrow3 arrow4 arrow5 arrow6 arrow7 arrow8 arrowPoints oldLayer layerName lay lwp textStr textPtLeft textsize textent) (vl-load-com) (defun *error* (msg) (if (/= msg "Function cancelled") (princ (strcat "\nError: " msg)) ) (setvar "CLAYER" oldLayer) (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) (princ) ) ; make lwpolyline by pointlist ; lst - point list (2d), cls - closed (0 - no, 1 - yes), clr - color (by aci, 256 - by layer, 0 - by block, 1 - red, 2 - yellow ~~ ) ; return - ename (defun ex:lwpline_by_list (lst cls clr) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 62 clr) (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst) ) ) ) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) (setq oldLayer (getvar "CLAYER")) (setq layerName "LEVEL_NCW") (if (not (tblsearch "LAYER" layerName)) (progn (setq lay (vla-add (vla-get-layers (vla-get-ActiveDocument (vlax-get-acad-object))) layerName)) (vlax-put-property lay 'color clr) ) ) (setvar "CLAYER" layerName) (while (setq pt (getpoint "\nSelecione o ponto: (pick point - continue / space bar or esc - exit)")) (setq elev (cadr pt)) (setq pt1 (trans pt 0 1 elev)) (setq clr 2) ;temp value - yellow ;; Arrow Creation (setq arrow1 (list (- (car pt1) 0.000) (+ (cadr pt1) 0.0))) ; Position for arrow1 (setq arrow2 (list (- (car pt1) 0.075) (+ (cadr pt1) 0.175))) ; Position for arrow2 (setq arrow3 (list (- (car pt1) 0.019) (+ (cadr pt1) 0.150))) ; Position for arrow3 (setq arrow4 (list (- (car pt1) 0.038) (+ (cadr pt1) 0.235))) ; Position for arrow4 (setq arrow5 (list (+ (car pt1) 0.038) (+ (cadr pt1) 0.235))) ; Position for arrow5 (setq arrow6 (list (+ (car pt1) 0.019) (+ (cadr pt1) 0.150))) ; Position for arrow6 (setq arrow7 (list (+ (car pt1) 0.075) (+ (cadr pt1) 0.175))) ; Position for arrow7 (setq arrow8 (list (+ (car pt1) 0.000) (+ (cadr pt1) 0.000))) ; Position for arrow8 (setq arrowPoints (list arrow1 arrow2 arrow3 arrow4 arrow5 arrow6 arrow7 arrow8)) (setq lwp (ex:lwpline_by_list arrowPoints 0 256)) ;; Criação do texto (setq textStr (rtos elev 2 2)) ; Converte a elevação para string (setq textPtLeft (trans (list (- (car pt) 0.0) (+ (cadr pt) 0.3)) 0 0 elev)) ; Posicionamento do texto à esquerda (setq textsize 0.3) ;temp value, or (setq textsize (getvar 'textsize)) (setq textent (entmakex (list (cons 0 "TEXT") (cons 62 256) (cons 10 textPtLeft) (cons 40 textsize) (cons 1 textStr) (cons 50 0) (cons 41 1) (cons 51 0) (cons 71 0) (cons 72 0) (cons 73 0) ) ) ) ) (setvar "CLAYER" oldLayer) (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) (princ) ) i cannot load your image, but if below gif is what you want, try this

Think this should do it (defun AT:NumFix (s n) ;; Fix number string with leading zeros ;; s - Number string to fix ;; n - Number of characters for final string ;; Alan J. Thompson, 10.29.09 ;; (AT:NumFix i 2) i= 5 = 05 (if (< (strlen s) n) (AT:NumFix (strcat "0" s) n) s ) )

I use @Lee Mac Areas2Attribute http://www.lee-mac.com/areafieldtoattribute.html

I'm not sure I follow .. the code HERE does that already? Nevermind .. I see what you are saying... let me take a look. Try this version: (defun c:foo (/ a c d) ;; RJP » 2023-08-13 ;; Sets hatch background color in blocks to 'none' (vlax-for l (vla-get-layers (setq d (vla-get-activedocument (vlax-get-acad-object)))) (cond ((= -1 (vlax-get l 'lock)) (vlax-put l 'lock 0) (setq a (cons l a)))) ) (vlax-for b (vla-get-blocks d) ;; This line will only process block definitions (if (= 0 (vlax-get b 'isxref) (vlax-get b 'islayout)) (vlax-for o b (cond ((and (vlax-write-enabled-p o) (wcmatch (vla-get-objectname o) "AcDbHatch")) (setq c (vla-get-backgroundcolor o)) (vla-put-EntityColor c -939524096) (vla-put-backgroundcolor o c) ) ) ) ) ) (foreach l a (vlax-put l 'lock -1)) (vla-regen d acallviewports) (princ) )

So close just need to add an if statement. Also sorted your list by color number -Edit Added undo points Fyi (foreach ent (mapcar 'cadr (ssnamex ss))) ;ssget "_X" (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) ;all other ssget (foreach obj (mapcar 'vlax-Ename->Vla-Object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))) ;if you want vla-objects instead of ename (defun c:PipeConvert_IRRI_UPDATE (/ Datalist ss f i ent eData) (vl-load-com) (vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object)))) ;list (Color | Layer | Global Width) (setq Datalist '((1 "P_DN90-6" 0.2) (2 "P_DN250-6" 0.3) (3 "P_DN110-6" 0.25) (4 "P_DN63-6" 0.15) (5 "P_DN160-6" 0.3) (6 "P_DN50-6" 0.15) (7 "P_DN315-6" 0.3) (8 "P_DN140-6" 0.2) (9 "P_DN315-8" 0.3) (14 "P_DN90-10" 0.2) (20 "P_DN225-6" 0.3) (21 "P_DN32-4" 0.1) (22 "P_DN32-6" 0.1) (24 "P_DN16-4" 0.05) (26 "P_DN32-8" 0.1) (51 "P_DN25-6" 0.05) (52 "P_DN450-6" 0.3) (54 "P_DN25-4" 0.05) (56 "P_DN250-12.5" 0.3) (58 "P_DN63-10" 0.15) (81 "P_DN110-10" 0.25) (82 "P_DN280-6" 0.3) (86 "P_DN280-10" 0.3) (91 "P_DN110-12.5" 0.25) (92 "P_DN280-8" 0.3) (94 "P_DN40-6" 0.1) (96 "P_DN280-12.5" 0.3) (111 "P_DN140-10" 0.2) (112 "P_DN355-6" 0.3) (116 "P_DN40-8" 0.1) (120 "P_DN63-8" 0.15) (121 "P_DN140-8" 0.2) (122 "P_DN40-4" 0.1) (134 "P_DN110-8" 0.25) (171 "P_DN160-10" 0.3) (172 "P_DN160-8" 0.3) (174 "P_DN20-4" 0.05) (176 "P_DN160-12.5" 0.3) (178 "P_DN75-12.5" 0.15) (200 "P_DN225-8" 0.3) (201 "P_DN225-10" 0.3) (202 "P_DN75-6" 0.15) (204 "P_DN225-12.5" 0.3) (206 "P_DN75-10" 0.15) (208 "P_DN75-8" 0.15) (214 "P_DN50-10" 0.15) (230 "P_DN50-8" 0.15) (231 "P_DN200-6" 0.3) (234 "P_DN16-6" 0.05) (238 "P_DN90-8" 0.2) (252 "P_DN315-12.5" 0.3) (253 "P_DN315-10" 0.3) (254 "P_DN125-6" 0.2))) (if (setq ss (ssget "_X" '((0 . "LINE") (8 . "MAINLINE_PIPES,ZONE_PIPES,SPRAYLINES")))) (foreach ent (mapcar 'cadr (ssnamex SS)) (setq eData (mapcar '(lambda (d) (cdr (assoc d (entget ent)))) '(62 10 11))) (if (setq f (assoc (car edata) Datalist)) ;if f # isnt found skip entity (progn (ssdel ent ss) (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 2) '(70 . 0) (cons 8 (cadr f)) (cons 43 (caddr f)) (cons 10 (cadr eData)) (cons 10 (caddr eData)) ) ) ) ) ) ) (vla-endundomark doc) (princ) )

This can help you? (vl-load-com) (defun c:Dim_PolyArc ( / js AcDoc modelSpace n ename obj pr dist_start dist_end pt_start pt_end pt_sel seg_len seg_bulge pos offset ang_base ang rad alpha pt_cen) (princ "\nSelect polylines.") (while (null (setq js (ssget '((0 . "LWPOLYLINE"))))) (princ "\nSelection is empty, or aren't POLYLINES!") ) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) modelSpace (vla-get-ModelSpace Acdoc) ) (vla-StartUndoMark AcDoc) (repeat (setq n (sslength js)) (setq ename (ssname js (setq n (1- n))) obj (vlax-ename->vla-object ename) pr -1 ) (repeat (fix (vlax-curve-getEndParam obj)) (setq dist_start (vlax-curve-GetDistAtParam obj (setq pr (1+ pr))) dist_end (vlax-curve-GetDistAtParam obj (1+ pr)) pt_start (vlax-curve-GetPointAtParam obj pr) pt_sel (vlax-curve-GetPointAtParam obj (+ pr 0.5)) pt_end (vlax-curve-GetPointAtParam obj (1+ pr)) seg_len (- dist_end dist_start) seg_bulge (vla-GetBulge obj pr) ang_base (angle pt_start pt_end) ) (if (or (not offset) (and (not (eq (getvar "USERR1") (* pi 0.5))) (not (eq (getvar "USERR1") (* pi 1.5))))) (progn (initget 1) (setq pos (getpoint pt_sel "\nPosition for all dimensions: ") offset (distance pt_sel pos) ang (angle pt_sel pos) ) (setvar "USERR1" (if (eq (rem pi (- ang ang_base)) pi) (* 0.5 pi) (* 1.5 pi))) ) ) (if (not (zerop seg_bulge)) (progn (setq rad (/ seg_len (* 4.0 (atan seg_bulge))) alpha (+ (angle pt_start pt_end) (- (* pi 0.5) (* 2.0 (atan seg_bulge)))) pt_cen (polar pt_start alpha rad) ) (vlax-put (vla-AddDimAngular modelSpace (vlax-3d-point pt_cen) (vlax-3d-point pt_start) (vlax-3d-point pt_end) (vlax-3d-point (polar pt_sel (+ ang_base (getvar "USERR1")) offset)) ) 'TextOverride (vl-string-subst (getvar "DIMDSEP") "." (rtos seg_len (getvar "DIMLUNIT") (getvar "DIMDEC"))) ) ) (vla-AddDimAligned modelSpace (vlax-3d-point pt_start) (vlax-3d-point pt_end) (vlax-3d-point (polar pt_sel (+ ang_base (getvar "USERR1")) offset)) ) ) ) ) (vla-EndUndoMark AcDoc) (prin1) )

You might have a look at THIS Could adapt that example maybe?

See if this does anything (defun C:foo (/ name) (vl-load-com) (vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object)))) (vlax-for blk (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) ;lists all block definitions in the drawing (cond ((wcmatch (setq name (vla-get-name blk)) "*ARCHI*") ;if block name contains this string (vlax-for obj blk ;step though each entity in the block (vla-put-color obj 8) ;and change its coloer to 8 ) ) ((wcmatch name "*MECHD*") (vlax-for obj blk (vla-put-color obj 1) ) ) ((wcmatch name "*MECHW*") (vlax-for obj blk (vla-put-color obj 2) ) ) ) ) (vla-Regen doc acAllViewports) (vla-endundomark doc) (princ) )

(if (null tmp) (setq tmp 25)) (initget 6) (and (setq tmp (cond ( (getreal (strcat "\nSpecify the psize <" (vl-princ-to-string tmp)"> : ") ) ( tmp ) )) (setq psize tmp))

I made something. A few remarks: - For my ease I made it 1 unit = 1 smallest paver. So I ignored the 8" size. You can always scale the result by 8 at the end. - The driveway starts at 0,0 . Then you pick a second point (both X and Y must be positive). Start small. (x=10, y=25 for example) - The algorithm will pick a random point, then a random pavers size (we skip the smallest paver), and a random orientation (horizontal or vertical) If there's room for that paver there, then it's drawn there. Else skip. This is done 3000 times (you can change this number) - At the end the smallest paver fills all the rest at the end command PAVER The script needs some cleanup; I just got it working. I might edit the script to clean it up. TODO. It might be nice to put a factor in the pavers, so that big pavers are randomly selected more or less often than small ones. You can add pavers sizes to the pavers_size list. Make sure the first size is 1,1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; DRAW (defun drawLWPoly (lst cls) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst))) ) (defun drawLWPoly_color (lst cls col) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 62 col) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ROUNDING ;; http://www.lee-mac.com/round.html ;; Round Multiple - Lee Mac ;; Rounds 'n' to the nearest multiple of 'm' (defun LM:roundm ( n m ) (* m (fix ((if (minusp n) - +) (/ n (float m)) 0.5))) ) ;; Round Up - Lee Mac ;; Rounds 'n' up to the nearest 'm' (defun LM:roundup ( n m ) ((lambda ( r ) (cond ((equal 0.0 r 1e-8) n) ((< n 0) (- n r)) ((+ n (- m r))))) (rem n m)) ) ;; Round Down - Lee Mac ;; Rounds 'n' down to the nearest 'm' (defun LM:rounddown ( n m ) ((lambda ( r ) (cond ((equal 0.0 r 1e-8) n) ((< n 0) (- n r m)) ((- n r)))) (rem n m)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; RANDOM number generator ;; http://www.lee-mac.com/random.html ;; 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) ) ;; Random in Range - Lee Mac ;; Returns a pseudo-random integral number in a given range (inclusive) (defun LM:randrange ( a b ) (+ (min a b) (fix (* (LM:rand) (1+ (abs (- a b)))))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Replace item in list (defun replace-element (index newelement lst) (subst newelement (nth index lst) lst) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; XY coordinates to array index ;; vice versa is just (nth index pavers) (defun yx2index ( x y pavers / res i) ;;(setq x_ (rem x w)) ;;(setq y_ (LM:rounddown (/ ind w) 1.0)) (setq i 0) (foreach cel pavers (if (and (= x (nth 0 cel)) (= y (nth 1 cel)) ) (setq res i) ) (setq i (+ i 1)) ) res ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun c:pavers ( / bl tr p1 p2 driveway_pl pixels pix w h x y a rnd rot ind ind_ blk paver pixelsfree counter stopcounter) (setq stopcounter 3000) ;; number of times it will try to put a randow paver on a random place (setq pavers_size (list (list 1 1) (list 2 1) (list 2 2) (list 3 2) )) ;;(setq p1 (getpoint "\nPoint bottom left: ")) (setq p1 (list 0.0 0.0)) (setq p2 (getcorner p1 "\nPoint top right: ")) ;; now round down the coordinates to multiples of the size of the smallest pavers (setq bl (list (LM:rounddown (nth 0 p1) 1 ) (LM:rounddown (nth 1 p1) 1 ) )) (setq tr (list (LM:rounddown (nth 0 p2) 1 ) (LM:rounddown (nth 1 p2) 1 ) )) ;; draw driveway (drawLWPoly (list (list (nth 0 bl) (nth 1 bl) ) (list (nth 0 tr) (nth 1 bl) ) (list (nth 0 tr) (nth 1 tr) ) (list (nth 0 bl) (nth 1 tr) ) ) 1) ;; make a list of pixels (setq w (- (nth 0 tr) (nth 0 bl))) (setq h (- (nth 1 tr) (nth 1 bl))) ;; round down and turn into integer (setq w (atoi (rtos w 2 0))) (setq h (atoi (rtos h 2 0))) (setq pixels (list)) (setq x 0) (setq y 0) (repeat h (setq x 0) (repeat w (setq pixels (append pixels (list (list x y nil) ;; the nil means the pixel is empty and can/must be filled by a paver ))) (setq x (+ x 1)) ) (setq y (+ y 1)) ) ;;(princ pixels) ;;(while (/= "a" (getstring "\nPress enter for random pixel") ) (setq counter 0) (while (< counter stopcounter) ;; random pixel (setq rnd (LM:randrange 0 (- (length pixels) 1))) ;; random orientation (0 = 0°, 1 = 90°) ;;(setq rot (/ (* pi (LM:randrange 0 1)) -2) ) (setq rot (LM:randrange 0 1)) ;; 0 means horizontal, 1 means vertical (this doesn't matter for square pavers obviously) ;; random paver block. ind is the index of the paver. ;; Let's skip the smallest paver, as it will fill up any place that doesn't fit any bigger. ;;(setq blk (nth (setq ind (LM:randrange 1 (length pavers_name))) pavers_name )) (setq paver (nth (setq ind (LM:randrange 1 (- (length pavers_size) 1))) pavers_size )) (setq pix (nth rnd pixels)) ;; now put a paver there ;;(drawInsert_rot (list (nth 0 pix) (nth 1 pix)) blk rot) (setq pixels_taken (list)) ;; draw paver (if (= 0 rot) ;; horizontal T ;; vertical (setq paver (list (nth 1 paver) (nth 0 paver))) ;; swap Width / height ) (progn ;; pixels taken: ;; width = (nth 0 paver) ;; height = (nth 1 paver) (setq x (nth 0 pix)) (setq y (nth 1 pix)) (setq pixelsfree T) (repeat (nth 1 paver) (setq x (nth 0 pix)) (repeat (nth 0 paver) (setq ind_ (yx2index x y pixels)) (setq pixels_taken (append pixels_taken (list ind_))) (if (or (= ind_ nil) ;; pixels outside the driveway (nth 2 (nth ind_ pixels)) ;; pixels already taken ) (setq pixelsfree nil) ) (setq x (+ x 1)) ) (setq y (+ y 1)) ) (if pixelsfree (progn (foreach a pixels_taken ;; set (nth 2) to true (setq pixels (replace-element a (list (nth 0 (nth a pixels)) (nth 1 (nth a pixels)) T) pixels)) ) (drawLWPoly_color (list (list (nth 0 pix) (nth 1 pix) ) (list (+ (nth 0 pix) (nth 0 paver) ) (nth 1 pix) ) (list (+ (nth 0 pix) (nth 0 paver) ) (+ (nth 1 pix) (nth 1 paver)) ) (list (nth 0 pix) (+ (nth 1 pix) (nth 1 paver)) ) ) 1 ind ) ) ;;(princ "*") ) ) ;;(setq (nth 1 pix)) (setq counter (+ counter 1)) ) ;;(princ pixels) ;; fill the rest with 1/1 pavers (foreach pix pixels (if (not (nth 2 pix)) (drawLWPoly_color (list (list (nth 0 pix) (nth 1 pix) ) (list (+ (nth 0 pix) 1 ) (nth 1 pix) ) (list (+ (nth 0 pix) 1 ) (+ (nth 1 pix) 1) ) (list (nth 0 pix) (+ (nth 1 pix) 1) ) ) 1 0 ) ) ) )

This old example may provide some food for thought

Here's another way to write it - (defun casesensitivity ( s ) (vl-list->string (apply 'append (mapcar '(lambda ( a b ) (if (= a b) (list a) (list 91 a b 93))) (vl-string->list (strcase s)) (vl-string->list (strcase s t)) ) ) ) ) As for combinations, maybe something like this - (defun combinations ( s / foo ) (defun foo ( u l ) (if (cdr u) (append (mapcar '(lambda ( x ) (cons (car u) x)) (foo (cdr u) (cdr l))) (mapcar '(lambda ( x ) (cons (car l) x)) (foo (cdr u) (cdr l))) ) (list u l) ) ) (mapcar 'vl-list->string (foo (vl-string->list (strcase s)) (vl-string->list (strcase s t)) ) ) ) _$ (length (combinations "floor")) 32

Lets do counting, I can do counting. Let's make it trickier and do binary counting, the first number in the list is the decimal equivalent. Dead handy if each character in a string has only 2 options. 1. 00000 2. 00001 3. 00010 4. 00011 5. 00100 6. 00101 7. 00110 8. 00111 9. 01000 10.01001 11.01010 12.01011 13.01100 14.01101 15.01110 16.01111 17.10000 18.10001 19.10010 20.10011 21.10100 22.10101 23.10110 24.10111 25.11000 26.11001 27.11010 28.11011 29.11100 30.11101 31.11110 32.11111

Two choices per letter upper or lower case 5 letters 2^5 = 32 possible choices. either do it lee's way (best) or use the strcase funciton to convert everything to upper case and check that way.

(defun c:t1 ( / ss l mid-pt ss->el) (defun mid-pt (e / x) (setq x (entget e))(mapcar '* (mapcar '+ (cdr (assoc 10 x)) (cdr (assoc 11 x))) '(0.5 0.5 0.5))) (defun ss->el (ss / i l) (setq i 0)(repeat (sslength ss)(setq l (cons (ssname ss i) l) i (1+ i))) l) (if (setq ss (ssget (list (cons 0 "Line")))) (setq l (vl-sort (ss->el ss) '(lambda (a b) (< (cadr (mid-pt a)) (cadr (mid-pt b))))))) (setq ss (ssadd) i -2) (while (setq e (nth (setq i (+ i 2)) l))(ssadd e ss)) (command "chprop" ss "" "color" "red" "") ) load code , start with t1 or (c:t1) , select the lines with window or crossing (no problem selecting the leaders also because they are filtered out anyway so don't worry , be happy) et voila...

it may be a bug I fixed a while ago by not first saving text before starting properties dialog. I'll attach latest version I have, it has a few more (undocumented) bells & whistles but in its core its still the same. VT.LSP Note that some functions / buttons will not work because they only function on my company network like button 'serv' in main dialog and also revision in quick menu only works with my company's titleblocks.

(defun c:MyHatch() (setq ss (ssget "X" (list '(0 . "LWPOLYLINE") '(70 . 1)))) (repeat (setq i (sslength ss)) (setq p (ssname ss (setq i (1- i)))) (setq pl (entget p) lay (assoc 8 pl) color (assoc 62 pl) ) (command "_hatch" "s" p "") (setq hatch (entget (entlast)) hatch (subst lay (assoc 8 hatch) hatch) ) (cond (color (setq hatch (append hatch (list color)))) ) (entmod hatch) ) (setq ss nil) ) Just a quick one...

Maybe - (defun 2parea ( p1 p2 ) (abs (apply '* (mapcar '- p2 p1 '(0 0)))) )

; offset increment numbering with change direction - 2023.04.28 exceeds (vl-load-com) (defun c:WCOPY ( / ss util en ent alignpt obj originalnum basept ang deg dist rotateold rotateinput rotatememory newnewobj ss2 en2 ent2 alignpt2 counter) (sssetfirst nil) (setvar "cmdecho" 0) (setq counter 0) ;error control (defun *error* ( msg ) (if (>= counter 1) (progn (setq alignpt2 (cdr (assoc 11 (entget (entlast))))) (if (= alignpt alignpt2) (progn (vla-delete newnewobj) (princ "\n Temporary Object Deleted.") ) ) );end of progn );end of if (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")) (princ (strcat "\n Error: " msg)) ) (setvar 'cmdecho 1) (princ) ) (setq util (vla-get-utility (vla-get-activedocument (vlax-get-acad-object)))) (setq ss (ssadd)) (princ "\n Select Original Number (Text) : ") (if (setq ss (ssget '((0 . "TEXT")))) (if (= (sslength ss) 1) (progn (setq en (ssname ss 0)) (setq ent (entget en)) (setq alignpt (cdr (assoc 11 ent))) (setq obj (vlax-ename->vla-object en)) (setq originalnum (atoi (vl-princ-to-string (vlax-get-property obj 'TextString)))) (setq basept (getpoint "\n Pick Base Point : ")) (setq ang (angle basept alignpt)) (setq deg (* 180.0 (/ ang pi))) (setq dist (distance basept alignpt)) (cond ((or (<= 315 deg) (< deg 45)) (setq rotateold "D") (princ "\n Direction : Right") ) ((and (<= 45 deg) (< deg 135)) (setq rotateold "W") (princ "\n Direction : Up") ) ((and (<= 135 deg) (< deg 225)) (setq rotateold "A") (princ "\n Direction : Left") ) ((and (<= 225 deg) (< deg 315)) (setq rotateold "S") (princ "\n Direction : Down") ) ) (command "_tjust" ss "" "mc") (while (= 1 1) (setq rotateinput (strcase (getstring "\n Change Direction? Up(W), Down(S), Left(A), Right(D), Keep Previous Direction(SpaceBar)"))) (if (= rotateinput "") (if (= rotatememory "") (progn (setq rotateinput rotateold) ) (progn (setq rotateinput rotatememory) ) ) (progn) ) (princ "\n Direction : ") (princ rotateinput) (cond ((= rotateinput "W") (princ "Up(W) Selected.") (cond ((= rotateold "D") (setq newdeg (+ deg 90)) ) ((= rotateold "W") (setq newdeg deg) ) ((= rotateold "A") (setq newdeg (- deg 90)) ) ((= rotateold "S") (setq newdeg (+ deg 180)) ) (t (setq newdeg deg) ) ) ) ((= rotateinput "A") (princ "Left(A) Selected.") (cond ((= rotateold "D") (setq newdeg (+ deg 180)) ) ((= rotateold "W") (setq newdeg (+ deg 90)) ) ((= rotateold "A") (setq newdeg deg) ) ((= rotateold "S") (setq newdeg (- deg 90)) ) (t (setq newdeg deg) ) ) ) ((= rotateinput "S") (princ "Down(S) Selected.") (cond ((= rotateold "D") (setq newdeg (- deg 90)) ) ((= rotateold "W") (setq newdeg (+ deg 180)) ) ((= rotateold "A") (setq newdeg (+ deg 90)) ) ((= rotateold "S") (setq newdeg deg) ) (t (setq newdeg deg) ) ) ) ((= rotateinput "D") (princ "Right(D) Selected.") (cond ((= rotateold "D") (setq newdeg deg) ) ((= rotateold "W") (setq newdeg (- deg 90)) ) ((= rotateold "A") (setq newdeg (+ deg 180)) ) ((= rotateold "S") (setq newdeg (+ deg 90)) ) (t (setq newdeg deg) ) ) ) (t (setq newdeg deg) ) ) (setq ang (* pi (/ (+ newdeg 180) 180))) ;(princ ang) (setq basept (polar alignpt ang dist)) ;(princ basept) (setq newnewobj (vla-copy obj)) (setq counter (+ counter 1)) (setq ss2 nil) (setq ss2 (ssadd)) (setq en2 (vlax-vla-object->ename newnewobj)) (ssadd en2 ss2) (vlax-put-property newnewobj 'TextString (+ originalnum 1)) (setq ent2 (entget en2)) (command "_move" ss2 "" basept pause) ;(command "_pasteclip" pause) (setq originalnum (+ originalnum 1)) (setq rotatememory rotateinput) );end of while ) (progn (princ "\n Select 1 Text Only.") (c:WCOPY) ) ) ) (setvar "cmdecho" 1) (princ) ) Long time no see. this uses command instead of grread. because I want to be able to see the preview & using osnap. Move Command is easy way for me. Command : WCOPY 1. Select 1 Text (Number) 2. Pick Base Point 3. lisp check your Direction 4. Select Direction - Press W/A/S/D or SpaceBar 5. Pick Target Point