Leaderboard

however... quite aggressive asking for the credit here today. Nicer ways to go "Hey, this was originally my code, can you credit me" and perhaps if possible the link to the original code to help the OP out. Code gets shared, the links and credits lost. Always good practice to add links to the sources and credits in case there are thing you want to go back and understand more from any discussions. Having said that though, upload code, you have no control of it's use and I am not sure I'd want credited with a base code that is mine and then heavily modified, or just a snippet of my code included in something larger without me doing checks and testing.

@EIA You can use a dynamic block. А-А.dwg

Why not something different...? ;************************ G L A V C V S ************************* ;************************** F E C I T *************************** (defun c:txtIncrem (/ tam capa ind para a txsel lstent le l s dameTexto errores error0) (defun errores (mens) (setq *error* error0) (prin1) ) (defun dameTexto (/ tx) ;;; WRITE HERE THE CODE YOU NEED TO CUSTOMIZE THE TEXT YOU WANT TO ENTER OR CREATE (cond ((= (strlen (setq tx (itoa (setq ind (+ ind 1))))) 1) (strcat "00" tx) ) ((= (strlen tx) 2) (strcat "0" tx) ) (T tx) ) ) (while (not para) (if (setq ent (car (entsel "\nSelect index text..."))) (if (= (cdr (assoc 0 (setq lstent (entget ent)))) "TEXT") (if (wcmatch (setq ind (cdr (assoc 1 lstent))) "#,##,###,####") (setq ind (atoi ind) capa (cdr (assoc 8 lstent)) a (cdr (assoc 40 lstent)) para T) (princ "\n*** The selected object is not valid. Please, try again... ***") ) ) (setq para T) ) ) (setq error0 *error* *error* errores ) (setq tam (* (getvar "pickbox") (/ (GETVAR "VIEWSIZE") (CADR (GETVAR "SCREENSIZE")))) para nil) (princ "\nSelect text to modify or insert new text (RIGHT CLICK for exit)...") (while (and (setq l (grread T (if s 4 13) (if s 2 0))) (member (car l) '(5 3))) (if (setq s (ssget "_C" (list (- (car (setq p (cadr l))) tam) (- (cadr p) tam)) (list (+ (car p) tam) (+ (cadr p) tam)) (list (cons 0 "TEXT")) ) ) (cond ((= (car l) 3) (entmod (subst (cons 1 (dameTexto)) (assoc 1 (setq le (entget (ssname s 0)))) le)) ) ;Here are other possible cases ) (cond ((= (car l) 3) (entmake (list '(0 . "TEXT") (cons 8 capa) (cons 40 a) (cons 1 (dameTexto)) (cons 10 (list (car p) (cadr p) 0.0)) ) ) ) ;Here are other possible cases ) ) ) (princ) )

Where layer transparency is concerned, this may be of interest - https://www.theswamp.org/index.php?topic=52473.msg574001#msg574001

As StevenP says, to request any parameter from the keyboard, consider the following: -If it's an integer: 'getint' -If it's a decimal number: 'getreal' -If it's a text string: 'getstring' The advantage of using 'getint' or 'getreal' (as appropriate) is that the function itself will prevent the user from entering data that doesn't match the expected type. However, if you use 'getstring', any data entered will be considered a text string and will need to be converted. In this case, if the user had mistakenly entered a string beginning with a non-numeric character (for example, "y734"), converting it with 'atoi' or 'atof' would return 0. Therefore, it's advisable to use the 'get...' functions appropriately.

This function returns the screen resolution. To get the cursor size in real time and drawing units, simply run the following: (* (/ (AnchoResol) 100.0) (getvar "CURSORSIZE") (/ (GETVAR "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) )

@CADSURAY sorry to burst your bubble but Protected lisp is easy to convert back to plain text. It was introduced say at least 30 years ago. That why these days we have VLX and DES.

Hey @aridzv, Try this: ;;;;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/copy-first-layout-multiple-times-and-number-incrementally/td-p/7030955;;; (defun c:genlayouts-2 (/ trap1 olderr baselay tablist layname cnt entrec objrec a b nn adoc curpos curtab i n) (defun trap1 ( msg ) (setq *error* olderr); restore *error* symbol (princ) ) (setq olderr *error*); assign current function defintion held by the *error* symbol to a local variable - olderr (setq *error* trap1); pointing the *error* symbol to new function definition - trap1 (setq baselay (getvar 'ctab));;store base layout (setvar "tilemode" 1);;move to mode space (if (setq ssrect (ssget '((0 . "LWPOLYLINE") (70 . 1) (90 . 4))));;;;;;;;;;main if (progn (setq n (sslength ssrect)) (setvar 'ctab baselay);;back to base layout (and (= 0 (getvar 'tilemode)) (setq i (getint "\nEnter begining integer for suffix: ")) (setq curtab (getvar 'ctab)) ;(setq n (getint "\nHow many copies of this tab: ")) (repeat n (if (not(member (strcat curtab "." (itoa (+ (1- n) i))) (layoutlist))) (progn (command "._layout" "_copy" "" (strcat curtab "." (itoa (+ (1- n) i))));;create new layout tab (setq tablist (cons (strcat curtab "." (itoa (+ (1- n) i))) tablist)) (setvar 'ctab (strcat curtab "." (itoa (+ (1- n) i))));move to new layout tab );progn );if (setq i (1- i)) );repeat );and );end progn main );;;;;;;;;;end main if (setvar "tilemode" 0) (TabSort) (setq nn (sslength ssrect)) (setq cnt (- (sslength ssrect) 1)) (repeat nn (setq layname (nth (1- nn) tablist)) (setvar 'ctab layname) ;;; (setvar "tilemode" 0) (command "MSPACE") ;;;;;;;;;;;;;;by Steven P https://www.cadtutor.net/forum/topic/76216-create-layout-from-a-grid-in-model-space/;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;create viewport from rectangle in current layout;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (if (setq entrec (ssname ssrect cnt));get rectangle ename (progn (setq objrec (vlax-ename->vla-object entrec));Transforms entrec to a VLA-object (vlax-invoke-method objrec 'GetBoundingBox 'a 'b); get max and min points of the rectangle as safe array (setq a (vlax-safearray->list a));convert a from safe array to list (setq b (vlax-safearray->list b));convert b from safe array to list (vl-cmdf "_.zoom" a b) (command "PSPACE") );progn (alert "no ent") );if ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq cnt (1- cnt)) (setq nn (1- nn)) ;;; (setvar "tilemode" 0) );repeat ;(princ tablist) ;;;(TabSort) (setq *error* olderr); restore *error* symbol (princ) );defun ;;;;https://www.cadtutor.net/forum/topic/10087-re-ordering-layout-tabs/;;;;; ;; --------------------------------------------------------------------------- ;; Function: tabsort ;; Purpose : sort Tabs by the prefix then the first numbers found ;; AUTHOR Charles Alan Butler @ TheSwamp.org ;; --------------------------------------------------------------------------- ;; Last Update 03/01/2006 CAB (defun TabSort (/ cnt doc lay) (vl-load-com) ;; --------------------------------------------------------------------------- ;; Function: Num_sort ;; Purpose : sort list of strings by the prefix then the first numbers found ;; AUTHOR Charles Alan Butler @ TheSwamp.org ;; Params : tablst: list of strings to sort ;; Returns : sorted list ;; --------------------------------------------------------------------------- (defun Num_Sort (tablst / tab ptr len loop tmp tmp2 sub lst) (defun vl-sort-it (lst func) (mapcar '(lambda (x) (nth x lst)) (vl-sort-i lst func)) ) (defun sort2 (tmp2 sub) (setq tmp2 (append (vl-sort-it sub '(lambda (e1 e2) (< (cadr e1) (cadr e2)))) tmp2 ) ) ) ;; convert to a list (string) -> (prefix num string) (foreach tab tablst (setq ptr 1 len (strlen tab) loop t ) (while loop (cond ((wcmatch "0123456789" (strcat "*" (substr tab ptr 1) "*")) (setq tmp (cons (list (substr tab 1 (1- ptr)) (atof (substr tab ptr)) tab ) tmp ) loop nil ) ) ((> (setq ptr (1+ ptr)) len) ;; no number in string (setq tmp (cons (list tab nil tab) tmp) loop nil ) ) ) ; end cond stmt ) ) ;; sort on the prefix (setq tmp (vl-sort-it tmp '(lambda (e1 e2) (< (car e1) (car e2))))) ;; Do a number sort on each group of matching prefex (setq idx (length tmp)) (while (> (setq idx (1- idx)) -1) (cond ((not sub) (setq sub (List (nth idx tmp)) str (car (nth idx tmp)) ) ) ((= (car (nth idx tmp)) str) ; still in the group (setq sub (cons (nth idx tmp) sub)) ) ) ; end cond stmt (if (= idx 0) ; end of list (progn (setq tmp2 (sort2 tmp2 sub)) (if (/= (car (nth idx tmp)) str) (setq tmp2 (append (list (nth idx tmp)) tmp2)) ) (setq str (car (nth idx tmp))) ) ) (if (/= (car (nth idx tmp)) str) ;; next group, so sort previous group (setq tmp2 (sort2 tmp2 sub) sub (list (nth idx tmp)) str (car (nth idx tmp)) ) ) ) ; end while (setq lst (mapcar 'caddr tmp2)) (princ) lst ) ; end defun ;;========================================================================== (setq cnt 1 doc (vla-get-activedocument (vlax-get-acad-object)) ) (foreach lay (num_sort (vl-remove "Model" (layoutlist))) (vla-put-taborder (vla-item (vla-get-layouts doc) lay) cnt) (setq cnt (1+ cnt)) ) (princ) ) ; end defun (prompt "\nTabSort loaded, enter TabSort to run.") (princ) See the attached video. I left only A-0 layout. LAYOUT.mp4

Kind of defeats the object of the forum though of sharing knowledge so that those who need or want to learn from others can do so from those who want to share their code freely. A locked LISP file is great for a finished project but... useless otherwise really. Often the threads are asking for assistance with a snippet of a larger project, and to lock it away doesn't help. Basic manners helps, credit the code where credit is due, a link to the original codes so that others can read and learn.

Dear @Saxlle, @Steven P thank You for Your answers and discusison. I think that code send by @Steven P Is what I was looking for. I've tried to implement 'solutions' from Excel into my script but there are much simpler and effective techniques I was not aware of. Thank You again for the answers Marcin

Have you thought about using a script, it can open a new dwg and will automatically then be in that dwg. Script code. (command "New" "Yourtemplatename") (alert "now in other dwg do your lisp code here") version 2 (command "New" "Yourtemplatename") (load "your lisp program")

If you use Vlide it will do bracket checking, I use Notepad++ it has a bracket check function also. just a comment I have 3 make layouts from rectangle, pick a point, walk along pline, horizontal aligned, the make layouts part supports rotated rectangle. Happy to discuss more.

Use entmakex. ; A 1000x500 rectangle with horizontal sides with a global width of 40, vertical sides with a global width of 0. (defun c:RectWidth-hor40 (/ pt1 pt2 hWidth vWidth p1 p2 p3 p4 pl) (setq width 1000 ; Rectangle width height 500 ; Rectangle height hWidth 40 ; Global width of horizontal sides vWidth 0) ; Global width of vertical sides (setq pt1 (getpoint "\nSpecify the insertion point: ")) (setq p1 pt1 p2 (list (+ (car pt1) width) (cadr pt1)) p3 (list (+ (car pt1) width) (+ (cadr pt1) height)) p4 (list (car pt1) (+ (cadr pt1) height))) (setq pl (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) (cons 10 p1) (cons 40 hWidth) (cons 41 hWidth) (cons 10 p2) (cons 40 vWidth) (cons 41 vWidth) (cons 10 p3) (cons 40 hWidth) (cons 41 hWidth) (cons 10 p4) (cons 40 vWidth) (cons 41 vWidth) ) ) ) (princ) )

solved it, instead of pt I put '(0.0 0.0 0.0) and it works.(pt and r are acquired at start of lisp) THANX again for ur help and guidance, and @Tharwat for his lisp that gave me idea

I really miss that guy. ;/ He was such a witty kind person and one of the most talented lisp programmers I knew.

I hate spending time correcting AI-generated code, but the first thing that sticks out is that the following: (setq attArray (vla-getattributes vlaBlock)) Will return a safearray variant, which cannot be iterated directly using foreach. Instead, you can use: (setq attArray (vlax-invoke vlaBlock 'getattributes)) Which will return the data using native data types, i.e. a list. You can find more examples here.

This function was originally written by the late great Michael Puckett - https://www.theswamp.org/index.php?topic=38072.0

PS: Someday you'll win one of those public tenders, and when that happens, I hope you'll come over here and have a coffee with one of us Good luck!

Hi @PGia I think this should meet your needs. I could say I wrote it from scratch just for you, but really, I also did it for myself. I had a good time revisiting old concepts. As I said, this is much easier to do with Map or Civil3D, creating topologies and manipulating them with the 'mnt*' functions. But writing this code has helped me prove that these tools can also be done in Lisp, with reasonably good results. The expressions are in my language. You'll have to translate them into yours. ;******************* G L A V C V S ******************* ;********************* F E C I T ********************* (defun c:spf>PGia (/ conj cj cjP ent n lstent en ex d pt i l lC lCs cE ltS ltV ltds s lSV actEtqs selR) (defun lSV (l / p r) (setq ltS (cons (list (setq s (vlax-ename->vla-object (car l))) (cadr l)) ltS) lCs (cons (list s (last l)) lCs)) (foreach x (reverse (cdr l)) (if p (if (not (member x ltds));ltds es la lista de los ya tocados (if (setq r (assoc p ltV)) (setq ltV (subst (list (car r) (+ (cadr r) (vla-get-area x))) r ltV) ltds (cons x ltds));ltV es una lista en que se asocia el identificador de las lineas contenedoras con la suma de la áreas de las contenidas (setq ltV (cons (list p (vla-get-area x)) ltV) ltds (cons x ltds)) ) ) ) (setq p x) ) ) (defun actEtqs (/ a b c e p pc l et tx) (foreach v (reverse ltS) (setq e (car v) p (cadr v) pc (last v)) (if (= (vla-get-layer e) "US") (setq l (cadr (assoc e lCs)) tx (vl-some '(lambda (x) (if (equal (cadr x) l) (vla-get-textstring (car x)))) ltS)) (setq tx nil) ) (if (/= (vla-get-layer e) "GEN") (vla-put-color p 6)) (vla-put-textstring e (strcat (if tx (strcat tx "-") "") (vla-get-textstring e) ":" (rtos (- (vla-get-area p) (if (setq a (assoc p ltV)) (cadr a) 0)) 2 2)) ) ) ) (defun selR (p / r s l lt en ex cj n o r4 f) (defun r2+ (p l r / i b) (vl-some '(lambda(g) (= 2 (setq r (if (foreach a (cons (last l) l) (if b (if (inters p (polar p g d) b (setq b a)) (setq i (not i))) (setq b a)) i) (+ r 1) r)))) '(0 1.5708 3.141592 4.71239) ) ) (if (setq cj (ssget "_F" (list p (list (car p) (+ (cadr p) (getvar "viewsize")))) (list '(0 . "LWP*") (cons 8 "PRMTR") '(-4 . "&=") '(70 . 1)) ) ) (while (setq e (ssname cj (setq n (if n (1+ n) 0)))) (if (r2+ p (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget e))) 0) (progn (setq l (cons (vlax-ename->vla-object e) l)) (if (ssmemb e cjP) (ssdel e cjP))) ) ) ) (if l (vl-sort l '(lambda (a b) (< (vla-get-Area a) (vla-get-Area b))))) ) (setq en (getvar "extmin") ex (getvar "extmax") n -1 d (max (- (car ex) (car en)) (- (cadr ex) (cadr en))) ) (vla-zoomExtents (vlax-get-acad-object)) (setq cjP (ssget "x" (list '(0 . "LWP*") (cons 8 "PRMTR") '(-4 . "&=") '(70 . 1)))) (if (setq conj (ssget "_X" '((0 . "TEXT") (8 . "GEN,US")))) (while (setq ent (ssname conj (setq n (1+ n)))) (setq lstent (entget ent) pt (cdr (assoc 10 lstent))) (if (setq l (selR pt)) (lSV (cons ent l)) (princ (strcat "\n*** Etiqueta " (cdr (assoc 1 lstent)) " huerfana"))) ) ) (if (> (sslength cjP) 0) (alert "ATENCION: Hay polilíneas sin asignar")) (alert (strcat "Numero de perímetros procesados: " (itoa (length ltS)))) (actEtqs) (princ) )

See attached code. 1. run the lisp in paper space. 2. the lisp prompt you to select a point on the block IN PAPER SPACE!! - click on the block. 3. click on the start point of the MLeader arrow - you are in paper space, no wories... 4. place the MLeader. 5. if you want to label another block go ahead. 6. to exit hit escape key or mouse right click. EDIT: the lisp works in model space as well. (defun c:MLeaderWBlname( / *error* temperr osnp tm tagname ptms ss ensel obj obj1 nam);ptps ptps1 (setq temperr *error*);store *error* (setq *error* trap1);re-assign *error* (setq osnp (getvar "OSMODE")) (setvar "OSMODE" 0) (setq tm (getvar "TILEMODE")) (princ "Select object in paper space,select start point of MLeader,exit with esc'") (while 1 (if (= tm 0);if in paper space (progn (getpoint) ;;get point in paper space on the target object (command "._MSPACE") (setq ptms (cadr (grread t)));;get the point where the cursor is on the target object in model space (setq ss (ssget ptms));;selction set of the object crossing the ptms point (setq obj(ssname ss 0)) (command "._PSPACE") );progn (progn ;in model space (setq ensel (entsel "\nSelect Block: ")) ;select the block object to copy (setq obj (car ensel)) ;set the block object to varaible );progn );if (setq obj1 (vlax-ename->vla-object obj)) (setq nam (vlax-get-property obj1 (if (vlax-property-available-p obj1 'effectivename) 'effectivename 'name ) ) ) (command "_mleader" "H" pause pause nam) );end while (setq *error* temperr) (princ) ) (defun trap1 (errmsg) (command "._PSPACE") (SETVAR "OSMODE" osnp) (princ) )

Nikon, you forgot to add open and closing brackets for v1 and v2... Like I said it should be : (atof v1) and (atof v2)...

Whereever in the code occurs v1 or v2, change them to (atof v1) and (atof v2)...

There are a few threads around here on this topic. Basically, you can't 100%, as it can still be traced and or duplicated from the dimensions if there are any, etc., best way is to make it as hard as possible. A well worded contract on not reusing your information will go along way to prevent conversion/reuse, just get legal services on specifics. Preventing our PDFs From Being Imported into Acad as Autocad Entities? - AutoCAD Drawing Management & Output - AutoCAD Forums PDF/ JPG file conversion threat. - AutoCAD 2D Drafting, Object Properties & Interface - AutoCAD Forums

Very true. Glad to see you posting more Lee.

Presumably you're assuming an MLEADER as opposed to a LEADER? For a LEADER entity, an arrowhead size override is set within the extended entity data, e.g.: (defun c:myleader ( / p q s ) (if (and (setq p (getpoint "\n1st point: ")) (setq q (getpoint "\n2nd point: " p)) (setq s (getdist "\nSpecify arrowhead size: ")) ) (progn (regapp "ACAD") (entmake (list '(0 . "LEADER") '(100 . "AcDbEntity") '(100 . "AcDbLeader") (cons 10 (trans p 1 0)) (cons 10 (trans q 1 0)) (list -3 (list "ACAD" '(1000 . "DSTYLE") '(1002 . "{") '(1070 . 41) (cons 1040 s) '(1002 . "}") ) ) ) ) ) ) (princ) )

You could try this too: (defun c:foo (/ a d) (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) (if (= 0 (vlax-get b 'isxref) (vlax-get b 'islayout)) (vlax-for o b (vl-catch-all-apply 'vla-put-layer (list o "0")) (vl-catch-all-apply 'vla-put-color (list o 256)) ) ) ) (foreach l a (vlax-put l 'lock -1)) (vla-purgeall d) (vla-regen d acactiveviewport) (princ) )

As we say here in NL : garantie tot aan de deur I've updated RlxPaste in attempt to handle dynamic blocks a little different than the normal cut/copy stuff. At this time it only works (if it works at all) when you select 1 dynamic block to add. It checks if block is dynamic or not. If so , it reads all dymanic properties of this block (I nicked a couple of Grand Master Lee's routines but don't tell him ) Save the block (under a different name of course because you can't save a block with the same name as the dwg) Then it writes all properties to a text file in the same folder & same name as the block but with extenion dbd (dynamic block data). Theory is that after insert it reads this dbd file and puts all props back. If it works , oh happy day , if it doesn't this conversation never happend... RlxPaste.LSP

Hey @PGia, Try the modified code from last post. I updated code about an 1 hour ago. Maybe you tried unupdated version.

Hi @PGia Can you attach a larger drawing? I need to run some tests.

(defun c:pl_area (/ bb e h ll lst lst2 pt pts n nv q r ss sst str ta ur v raycast plineoff) ;;LeeMac (defun raycast ( p l ) (= 1 (logand 1 (length (vl-remove 'nil (mapcar '(lambda ( a b ) (inters p (mapcar '+ p '(1e8 0.0)) a b)) (cons (last l) l) l ) ) ) ) ) ) (defun plineoff (v off Out / e eng pts vs) (setq e (vlax-vla-object->ename v) eng (entget (vlax-vla-object->ename (car (vl-sort (setq vs (mapcar 'car (list (vlax-invoke v 'offset off) (vlax-invoke v 'offset (- off))))) '(lambda (x y) ((if out > <) (vla-get-area x) (vla-get-area y)) ) ) ) ) ) pts (mapcar '(lambda (x)(trans (cdr x) e 1)) (vl-remove-if-not '(lambda (x) (eq (car x) 10)) eng)) ) (mapcar 'vla-delete vs) pts ) (if (setq e (car (entsel "\nSelect largest polyline: "))) (progn (setq v (vlax-ename->vla-object e) ta (vla-get-area v) bb (plineoff v 1.0 T) ss (ssget "wp" bb '((0 . "LWPOLYLINE"))) sst (ssget "cp" bb '((0 . "MTEXT,TEXT"))) ) (if (eq (sslength ss)(sslength sst)) (progn (repeat (setq n (sslength ss)) (setq n (1- n) e (ssname ss n) v (vlax-ename->vla-object e) a (vla-get-area v) lst (cons (cons a e) lst) ) ) (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y)))) q 0 r (length lst)) (repeat (setq n (sslength sst)) (setq n (1- n) e (ssname sst n) v (vlax-ename->vla-object e) lst2 (cons (cons v (vlax-get v 'insertionpoint)) lst2) ) ) (foreach a lst (setq q (1+ q) eng (entget (cdr a)) pts (mapcar 'cdr (vl-remove-if-not '(lambda (x) (eq (car x) 10)) eng)) str (rtos (if (not (eq q r)) (car a) ta) 2 4) ta (- ta (car a)) ) (foreach pt lst2 (if (raycast (cdr pt) pts) (progn (if (eq (vla-get-objectname (car pt)) "AcDbMText") (vlax-put (car pt) 'textstring (strcat (vlax-get (car pt) 'textstring) "\\P= " str) ) (progn (setq nv (vla-copy (car pt)) h (* 1.3333 (vla-get-height nv))) (vlax-put nv 'textstring str) (vlax-put nv 'insertionpoint (list (car (cdr pt)) (- (cadr (cdr pt)) h) (caddr (cdr pt)))) ) ) (setq lst2 (vl-remove pt lst2)) ) ) ) ) ) (prompt "\nPolyline and text counts do not match. Check selection.") ) ) ) (princ) ) here's my latest revision as well.

Hey @PGia, Try this new one: ; **************************************************************************************** ; Functions : UMTXT ; Description : Adding an Area value to the label/text of each closed polyline ; Author : SAXLLE ; Date : March 20, 2025 ; Update 1.0 : Added a substraction to get a total value of largest closed polyline ; Update date : March 21, 2025 ; **************************************************************************************** (prompt "\nTo run a LISP type: UMTXT") (princ) (defun c:UMTXT ( / old_nomutt ss len i area_with_entity_list area area_with_entity len_area_with_entity_list j max_val substracted_area total_area ptlist select_text data_text new_txt k) (setq old_nomutt (getvar 'nomutt)) ;; Get a value from 'nomutt (setvar 'nomutt 1) ;; Set a value to be "1" to "supress" the default "Select objects:" from ssget (princ "\nSelect closed POLYLINES:") (setq ss (ssget '((0 . "LWPOLYLINE") (70 . 1))) ;; Select ONLY POLYLINES which are closed! "1" means "1 = Closed" len (sslength ss) ;; Length of selection set i 0 ;; 1. iterator area_with_entity_list (list) ;; In this list will be stored joined value of an Area and entity (e.g. (500 . <Entity name: 2ed1289fd60>)) ) (while (< i len) (setq area (vlax-get-property (vlax-ename->vla-object (ssname ss i)) 'Area) ;; Get an Area from closed POYLINE area_with_entity (cons area (ssname ss i)) ;; Join the value of Area with entity name area_with_entity_list (cons area_with_entity area_with_entity_list) ;; Create a list of value with Area and entity name ) (setq i (1+ i)) ;; Adding 1+ to iterator "i" to repeat iterating through selection set "ss" ) (setq area_with_entity_list (vl-sort area_with_entity_list (function (lambda (x1 x2) (< (car x1) (car x2))))) ;; Sorting list from MIN to MAX area with entity len_area_with_entity_list (length area_with_entity_list) ;; Length of elements in the variable "area_with_entity_list" j 0 ;; 2. iterator with FIX value "0" ) (setq max_val (car (nth 0 area_with_entity_list))) ;; Get the first value as MAX value of an Area (repeat (setq len_max (length area_with_entity_list)) ;; Finding a MAX value of an Area from variable "area_with_entity_list" (if (<= max_val (car (nth (1- len_max) area_with_entity_list))) (setq max_val (car (nth (1- len_max) area_with_entity_list)) len_max (1- len_max) ) (setq max_val max_val) ) ) (setq substracted_area 0) ;; Set "substracted_area" to 0 (repeat (setq len_max (length area_with_entity_list)) ;; Finding a "substracted_area" from variable "area_with_entity_list" which are going to be substracted from variable "max_val" (if (> max_val (car (nth (1- len_max) area_with_entity_list))) (setq result (+ substracted_area (car (nth (1- len_max) area_with_entity_list))) substracted_area result len_max (1- len_max) ) (setq len_max (1- len_max)) ) ) (setq total_area (- max_val substracted_area)) ;; This is a total area for the largest closed polyline, where the rest Area from closed poylines substracted from variable "max_val" (repeat len_area_with_entity_list (setq ptlist (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (cdr (nth j area_with_entity_list))))) ;; Get a vertices from closed POLYLINE select_text (ssget "_WP" ptlist '((0 . "*TEXT,MTEXT"))) ;; Select ONLY TEXT or MTEXT entities ) (if (/= select_text nil) ;; 1. progn with WINDOW POLYGON "_WP" (progn ;; start cond (cond ;;1. cond ((= (sslength select_text) 1) ;; If the length of selected TEXT or MTEXT equal to 1 (setq data_text (cdr (assoc 1 (entget (ssname select_text 0))))) ;; Get a data from TEXT or MTEXT entity (if (wcmatch data_text "*=*") ;; Check if text contain "=" (nil) (progn (setq new_txt (subst (cons 1 (strcat data_text "=" (rtos (car (nth j area_with_entity_list)) 2 2) " m2")) (cons 1 data_text) (entget (ssname select_text 0)))) ;; Substitue old TEXT or MTEXT value with a new value and adding an Area of closed POLYLINE to the new value (entmod new_txt) ;; Modifies the definition data of an entity with TEXT or MTEXT value (setq area_with_entity_list (vl-remove (nth j area_with_entity_list) area_with_entity_list)) ;; Remove the element from list which are substitued ) ) ) ;; end 1. cond ;;2. cond ((>= (sslength select_text) 2) ;; If the length of selected TEXT or MTEXT are greater or equal to 2 (setq k (- (sslength select_text) 1)) ;; 3. iterator (repeat (sslength select_text) (if (/= k -1) (progn (setq data_text (cdr (assoc 1 (entget (ssname select_text k))))) ;; Get a data from TEXT or MTEXT entity (if (wcmatch data_text "*=*") ;; Check if text contain "=" (setq k (1- k)) (progn (setq new_txt (subst (cons 1 (strcat data_text "=" (rtos total_area 2 2) " m2")) (cons 1 data_text) (entget (ssname select_text k)))) ;; Substitue old TEXT or MTEXT value with a new value and adding an Area of closed POLYLINE to the new value (entmod new_txt) ;; Modifies the definition data of an entity with TEXT or MTEXT value (setq k (1- k)) ;; Reduce 1- to iterator "k" to repeat iterating through selection set "select_text" ) ) ) ) ) (setq area_with_entity_list (vl-remove (nth j area_with_entity_list) area_with_entity_list)) ;; Remove the element from list which are substitued ) ;; end 2. cond ) ;; end cond ) ;; end 1. progn ;; 2. progn with FENCE "_F" (progn (setq select_text (ssget "_F" ptlist '((0 . "*TEXT,MTEXT")))) ;; Select ONLY TEXT or MTEXT entities ;; start cond (cond ;;1. cond ((= (sslength select_text) 1) ;; If the length of selected TEXT or MTEXT equal to 1 (setq data_text (cdr (assoc 1 (entget (ssname select_text 0))))) ;; Get a data from TEXT or MTEXT entity (if (wcmatch data_text "*=*") ;; Check if text contain "=" (nil) (progn (setq new_txt (subst (cons 1 (strcat data_text "=" (rtos (car (nth j area_with_entity_list)) 2 2) " m2")) (cons 1 data_text) (entget (ssname select_text 0)))) ;; Substitue old TEXT or MTEXT value with a new value and adding an Area of closed POLYLINE to the new value (entmod new_txt) ;; Modifies the definition data of an entity with TEXT or MTEXT value (setq area_with_entity_list (vl-remove (nth j area_with_entity_list) area_with_entity_list)) ;; Remove the element from list which are substitued ) ) ) ;; end 1. cond ;;2. cond ((>= (sslength select_text) 2) ;; If the length of selected TEXT or MTEXT are greater or equal to 2 (setq k (- (sslength select_text) 1)) ;; 3. iterator (repeat (sslength select_text) (if (/= k -1) (progn (setq data_text (cdr (assoc 1 (entget (ssname select_text k))))) ;; Get a data from TEXT or MTEXT entity (if (wcmatch data_text "*=*") ;; Check if text contain "=" (setq k (1- k)) (progn (setq new_txt (subst (cons 1 (strcat data_text "=" (rtos total_area 2 2) " m2")) (cons 1 data_text) (entget (ssname select_text k)))) ;; Substitue old TEXT or MTEXT value with a new value and adding an Area of closed POLYLINE to the new value (entmod new_txt) ;; Modifies the definition data of an entity with TEXT or MTEXT value (setq k (1- k)) ;; Reduce 1- to iterator "k" to repeat iterating through selection set "select_text" ) ) ) ) ) (setq area_with_entity_list (vl-remove (nth j area_with_entity_list) area_with_entity_list)) ;; Remove the element from list which are substitued ) ;; end 2. cond ) ;; end cond ) ;; end 2. progn ) ;; end if ) ;; end repeat (setvar 'nomutt old_nomutt) ;; Restore old value to 'nomutt (prompt "\nAdding area to the labels has been done!") (princ) ) I'v been tested this new one lisp on the both drawing which are you uploaded, and get great result (picture 1 and picture 2). Picture 1. Picture 2. I hope you will get satisfied. Notice: It will only concate the label/text value of closed polyline with an Area of that closed polyline, for opened polylines, nothing is going to happen. Best regards.

It's really hard to consider all possible situations in code. I spent a while working on it yesterday afternoon, but I didn't have time to finish. I enjoyed doing it because it's helping me remember some things I'd forgotten. I'll post the result as soon as I can.

Now I see what you did here, you should have to select all the polylines. I've restructured the routine to notify user to select the largest polyline. (defun c:pl_area (/ bb e eng h ll lst lst2 pt pts n nv ss sst str ur v raycast) ;;LeeMac (defun raycast ( p l ) (= 1 (logand 1 (length (vl-remove 'nil (mapcar '(lambda ( a b ) (inters p (mapcar '+ p '(1e8 0.0)) a b)) (cons (last l) l) l ) ) ) ) ) ) (if (setq e (car (entsel "\nSelect largest polyline: "))) (progn (setq eng (entget e) bb (mapcar '(lambda (x)(trans (cdr x) e 1))(vl-remove-if-not '(lambda (x)(eq (car x) 10)) eng)) ss (ssget "wp" bb '((0 . "LWPOLYLINE"))) sst (ssget "cp" bb '((0 . "MTEXT,TEXT"))) ) (cond ((null ss)(setq ss (ssadd))(ssadd e ss)) ((not (ssmemb e ss))(ssadd e ss)) ) (if (eq (sslength ss)(sslength sst)) (progn (repeat (setq n (sslength ss)) (setq n (1- n) e (ssname ss n) v (vlax-ename->vla-object e) a (vla-get-area v) lst (cons (cons a e) lst) ) ) (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))) (repeat (setq n (sslength sst)) (setq n (1- n) e (ssname sst n) v (vlax-ename->vla-object e) lst2 (cons (cons v (vlax-get v 'insertionpoint)) lst2) ) ) (foreach a lst (setq eng (entget (cdr a)) pts (mapcar 'cdr (vl-remove-if-not '(lambda (x) (eq (car x) 10)) eng)) str (rtos (car a) 2 4) ) (foreach pt lst2 (if (raycast (cdr pt) pts) (progn (if (eq (vla-get-objectname (car pt)) "AcDbMText") (vlax-put (car pt) 'textstring (strcat (vlax-get (car pt) 'textstring) "\\P= " str) ) (progn (setq nv (vla-copy (car pt)) h (* 1.3333 (vla-get-height nv))) (vlax-put nv 'textstring str) (vlax-put nv 'insertionpoint (list (car (cdr pt)) (- (cadr (cdr pt)) h) (caddr (cdr pt)))) ) ) (setq lst2 (vl-remove pt lst2)) ) ) ) ) ) (prompt "\nPolyline and text counts do not match. Check selection.") ) ) ) (princ) )

Its no good even if you could convert the TTF to a shx you would still have to send it to all 50 people, so the TTF is a custom font ? Not a standard one within Windows which has lots. You can copy a font and paste to c:\windows\fonts it should auto install. Like @Steven P why not just replace with some thing very close. If you open explorer and go to c:\windows\fonts you will see what the font looks like or you can dbl click it, and it will show an example of the font in words. If you have dual screens will help to compare. There is one TTF I know of which is Arch.TTF which s a freehand font and used a lot.

pkenewell, yes, only going to be asking the tricky ones! It is all working now I think

Yes - I was thinking MLEADER instead of LEADER. Didn't realize Steven P was talking about the old style Leaders. The old leaders were "governed" by dim variables.

It seems perfectly fine and much better. (vla-get-ActiveDocument (vlax-get-acad-object)) - this can be set to a variable.

(defun NearestINT (num f / i r) ;; num - real / integer ;; f - fuzz (setq i (float (fix num)) r (- num i)) (cond ((< r f) i) ((> r (abs (1- f))) (1+ i)) (T num) ) ) (defun add_vtx (obj add_pt ent_name / bulg) (vla-addVertex obj (1+ (fix add_pt)) (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 0 1)) (list (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name)) (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name)) ) ) ) ) (setq bulg (vla-GetBulge obj (fix add_pt))) (vla-SetBulge obj (fix add_pt) (/ (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4)) (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4)) ) ) (vla-SetBulge obj (1+ (fix add_pt)) (/ (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4)) (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4)) ) ) (vla-update obj) ) (defun c:div-vertex_po ( / ss max_l n ent obj_vla pr dist_end dist_start seg_len1 seg_len2 div l_div l) (princ "\nSelect polylines.") (while (null (setq ss (ssget '((0 . "LWPOLYLINE"))))) (princ "\nSelect is empty, or isn't POLYLINE!") ) (initget 7) (setq max_l (getdist "\nMax length between vertex: ")) (repeat (setq n (sslength ss)) (setq ent (ssname ss (setq n (1- n))) obj_vla (vlax-ename->vla-object ent) pr (fix (vlax-curve-getEndParam ent)) ) (repeat (fix (vlax-curve-getEndParam ent)) (setq dist_end (vlax-curve-GetDistAtParam ent pr) dist_start (vlax-curve-GetDistAtParam ent (setq pr (1- pr))) seg_len1 (- dist_end dist_start) seg_len2 (nearestint seg_len1 1e-4) div (if (equal (fix seg_len2) seg_len2 0.0)(fix (/ seg_len2 max_l))(1+ (fix (/ seg_len2 max_l)))) l_div (/ seg_len2 div) l l_div ) (while (< l seg_len2) (add_vtx obj_vla (vlax-curve-getparamatdist ent (- dist_end l)) ent) (setq l (+ l l_div)) ) ) ) (prin1) ) Hi enthralled, please try the 3rd revision.

Or just to - (setq col (cond ((< area1 399.5) "255,121,77") ((< area1 449.5) "242,95,171") ((< area1 549.5) "253,134,206") ((< area1 599.5) "253,206,243") ((< area1 699.5) "242,187,166") ("253,237,206") ) )

The leader entity still exists within the drawing database, the owner is simply the block definition rather than the Modelspace/Paperspace block; rather than using (entlast), you can use the entity name returned by (entmakex).

I've literally just turned it all off for the night.... 42. will try that one Wasn't working for qleader, multileaders I think it does.

Hello everyone. I don't want to take sides. But I think Mr. GLVCVS is right. In my office, we've sometimes had to work with closed polylines inside other closed polylines. This is a possibility that needs to be taken into account in some cases. Although I don't know if it's necessary in this case.

@pkenewell FWIW, all the range checks could be shortened to this. No need for AND (<= 399.5 area1 449.5)

Your return is a list , in your example this is a list with one member '("GroupName") to retrieve it is very basic lisp : (setq group-list '("GroupName")) (setq group-name (car group-list)) or (setq group-name (nth 0 group-list))

Perfect

Thankyou so much. This is perfect. 10000 pieces of texts rotated perfectly in a matter of seconds

I think my approach was somewhat hasty. Without a doubt: the most appropriate approach is the one suggested by @Emmanuel Delay

I kept most of your code. What I added: - code to determine if a point is inside a closed polyline. What the code does is cast a RAY (half a XLINE, just to one side) from said point (being the insert point of the MTEXT). If that ray touches/intersects the polyline an odd number of times, then the point is inside. - You don't have to select the MTEXT. You select the polyline, then the script will select all MTEXTS and only rotate the MTEXTS that are inside the polyline (vl-load-com) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This section is all about determining if a point is inside a closed polyline (defun c:testray ( / pt) (drawxRay (setq pt (getpoint "\nPoint: ")) (list 1.0 0.0)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun drawxRay (pt vec) (entmakex (list (cons 0 "RAY") (cons 100 "AcDbEntity") (cons 100 "AcDbRay") (cons 10 pt) (cons 11 vec)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Intersections - Lee Mac ;; http://www.lee-mac.com/intersectionfunctions.html ;; 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 ;; acextendnone Do not extend either object ;; acextendthisentity Extend obj1 to meet obj2 ;; acextendotherentity Extend obj2 to meet obj1 ;; acextendboth Extend both objects (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) ) ;; what this function does: from point pt we draw a RAY to the right. We detect intersections of the ray with the closed polyline. ;; => if the number of intersections is odd -> this means the point is inside the polygon, and the ray exits the polygon at the last intersection. ;; => if the number of intersections is even (0, 2, 4...) -> the point is outside the polygon. The ray doesn't intersect, or it enters then exits... (defun point_inside_closed_polyline (pt pline / ray ins) (setq ray (drawxRay pt (list 1.0 0.0))) (setq ins (LM:intersections (vlax-ename->vla-object pline) (vlax-ename->vla-object ray) acextendnone )) ;; delete the ray (entdel ray) (if (= 0 (rem (length ins) 2)) nil T) ;; (rem number 2) returns 1 when number is odd, 0 when even. We return T when odd, nil when even ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun c:RotateMtext ( / ent mtexts i mtext is_inside pt entObj mtextObj vertices longestSide longestAngle p1 p2 dist) ;; don't forget these. Local variables must be listed like this. (setq ent (car (entsel "\nSelect enclosed polyline: "))) ;; this selects all MTEXTS (setq mtexts (ssget "_x" (list (cons 0 "MTEXT") ))) (setq i 0) (repeat (sslength mtexts) ;;(setq mtext (car (entsel "\nSelect MTEXT: "))) (setq mtext (ssname mtexts i)) (setq is_inside (point_inside_closed_polyline (setq pt (cdr (assoc 10 (entget mtext)))) ent)) (if (and ent mtext is_inside) (progn (setq entObj (entget ent)) (setq mtextObj (entget mtext)) (if (eq (cdr (assoc 0 entObj)) "LWPOLYLINE") (progn (setq vertices '()) (foreach item entObj (if (or (eq (car item) 10) (eq (car item) 11)) (setq vertices (append vertices (list (cdr item)))) ) ) (setq longestSide 0 longestAngle 0) (repeat (- (length vertices) 1) (setq p1 (nth 0 vertices) p2 (nth 1 vertices)) (setq vertices (cdr vertices)) (setq dist (distance p1 p2)) (if (> dist longestSide) (progn (setq longestSide dist) (setq longestAngle (angle p1 p2)) ) ) ) (setq mtextObj (subst (cons 50 longestAngle) (assoc 50 mtextObj) mtextObj)) (entmod mtextObj) (princ "\nMTEXT rotated successfully.") ) (princ "\nSelected entity is not a polyline.") ) ) (princ "\nInvalid selection.") ) (setq i (+ i 1)) ) (princ) ) Happy with this?

Hi Maahee I think it's hard to know what your code is supposed to do. Without knowing this, it's hard to get anyone to respond to you.

I am thinking you might use this from Lee Mac to get a list of nested blocks and work from there: https://lee-mac.com/extractnestedblock.html I think this is the related part of the code ;;https://lee-mac.com/extractnestedblock.html ;;USe this line to select a block (enb:getreferences (cdr (assoc 2 (entget (car(entsel)))))) ; Use this to loop through the blocks, in this case it is making a list, in your case (ssget "_X") and modify assoc codes to by block / layer colouras and layer codes. (defun enb:getreferences ( blk / ent enx lst ) (if (setq ent (tblobjname "block" blk)) (foreach dxf (entget (cdr (assoc 330 (entget ent)))) (if (and (= 331 (car dxf)) (setq ent (cdr dxf)) (setq enx (entget ent)) (setq enx (entget (cdr (assoc 330 (reverse enx))))) ) (if (wcmatch (strcase (setq blk (cdr (assoc 2 enx)))) "`**_SPACE") (setq lst (cons (list ent) lst)) (setq lst (append (mapcar '(lambda ( l ) (cons ent l)) (enb:getreferences blk)) lst)) ;; Change this line to set colours / layers ) ) ) ) lst ) That might give you a start if you want to do some thinking