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.

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

;;; blocks in group (defun c:big ( / gl ) (vl-load-com) (if (not (vl-consp (setq gl (lag)))) (alert "Computer says no : there are no groups") ;;; show all blocks in group (choose from group list) (sabig (cfl gl)) ) (princ) ) ;;; list all groups (setq rtn (lag)) (defun lag ( / gps lst) (setq gps (vla-get-groups (vla-get-activedocument (vlax-get-acad-object)))) (vlax-for g gps (setq lst (cons (vla-get-name g) lst))) (if (vl-consp lst) (acad_strlsort lst)) ) ; choose from list (cfl '("1""2""3")) (defun cfl (l / f p d r) (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ "cfl:dialog{label=\"Choose\";:list_box{key=\"lb\";width=40;}ok_cancel;}" p) (not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d) (progn (start_list "lb")(mapcar 'add_list l)(end_list)(action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)") (action_tile "accept" "(setq r (get_tile \"lb\"))(done_dialog 1)")(action_tile "cancel" "(setq r nil)(done_dialog 0)") (start_dialog)(unload_dialog d)(vl-file-delete f))) (cond ((= r "") nil)(r r)(t nil))) ;;; display list (plus message) (defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l)))) (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";" "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb") (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f)))) ; multiple association (defun massoc ($i $l / a l)(while (setq a (assoc $i $l))(setq l (cons (cdr a) l) $l (cdr (member a $l))) l)) ;;; test if (vla) object is a block / get blockname / ename->vla-object (defun block-p (o) (and (setq o (e->o o)) (member (vla-get-objectname o) '("AcDbBlockReference" "AcDbBlockTableRecord")))) (defun block-n (o) (if (block-p o)(if (vlax-property-available-p o 'EffectiveName)(vla-Get-EffectiveName o)(vla-Get-Name o)))) (defun e->o (e) (cond ((= 'vla-object (type e)) e)((= 'ename (type e))(vlax-ename->vla-object e))(t nil))) ;;; show all blocks in group (defun sabig (gname / odic gdic grec el blist) (setq odic (namedobjdict)) (setq gdic (dictsearch odic "ACAD_GROUP")) (setq grec (dictsearch (cdar gdic) gname)) (setq el (massoc 340 grec)) (if (vl-consp el) (foreach x el (if (block-p x)(setq blist (cons (block-n (e->o x)) blist))))) (if (vl-consp blist) ;;; (dplm (acad_strlsort blist) (strcat "Blocks in group " gname)) (write-list blist) (alert (strcat "Computer says no : sorry no block in group " gname)) ) ) (defun write-list ( l / fn fp) (if (setq fp (open (setq fn (strcat (getvar "dwgprefix") "file1.txt")) "w")) (progn (foreach item l (write-line item fp)) (close fp) (gc) (gc) (startapp "notepad" fn) ) ) (princ) )

https://www.theswamp.org/index.php?topic=51248.msg563608#msg563608

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

I never wrote this app with dynamic blocks in the back in my mind but I may have a look at this someday. Thing is , I have very few dynamic blocks myself. Probably can count them on one hand. Mainly because static block are easier to handle in lisp. (very difficult to teach old dragons new tricks haha)

If the inner text touches any segment of the lwpolyline, '(ssget "WP"...)' would not include the text in the selection set. Also, performing recursive 'ssget's could be too slow on large drawings.

Hi @p7q, You can use system variable nomutt. The default value is 0, you need to change it to 1. You can see from one of part from code (it will supress the default "Select objects:" from ssget): ........ (setq old_nomutt (getvar 'nomutt)) (setvar 'nomutt 1) (princ "Select all Text entities:") (setq ss (ssget '((0 . "*TEXT"))) ........ (setvar 'nomutt old_nomutt) (princ)

here's something to list all block names that live in a group ;;; blocks in group (defun c:big ( / gl ) (vl-load-com) (if (not (vl-consp (setq gl (lag)))) (alert "Computer says no : there are no groups") ;;; show all blocks in group (choose from group list) (sabig (cfl gl)) ) (princ) ) ;;; list all groups (setq rtn (lag)) (defun lag ( / gps lst) (setq gps (vla-get-groups (vla-get-activedocument (vlax-get-acad-object)))) (vlax-for g gps (setq lst (cons (vla-get-name g) lst))) (if (vl-consp lst) (acad_strlsort lst)) ) ; choose from list (cfl '("1""2""3")) (defun cfl (l / f p d r) (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ "cfl:dialog{label=\"Choose\";:list_box{key=\"lb\";width=40;}ok_cancel;}" p) (not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d) (progn (start_list "lb")(mapcar 'add_list l)(end_list)(action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)") (action_tile "accept" "(setq r (get_tile \"lb\"))(done_dialog 1)")(action_tile "cancel" "(setq r nil)(done_dialog 0)") (start_dialog)(unload_dialog d)(vl-file-delete f))) (cond ((= r "") nil)(r r)(t nil))) ;;; display list (plus message) (defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l)))) (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";" "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb") (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f)))) ; multiple association (defun massoc ($i $l / a l)(while (setq a (assoc $i $l))(setq l (cons (cdr a) l) $l (cdr (member a $l))) l)) ;;; test if (vla) object is a block / get blockname / ename->vla-object (defun block-p (o) (and (setq o (e->o o)) (member (vla-get-objectname o) '("AcDbBlockReference" "AcDbBlockTableRecord")))) (defun block-n (o) (if (block-p o)(if (vlax-property-available-p o 'EffectiveName)(vla-Get-EffectiveName o)(vla-Get-Name o)))) (defun e->o (e) (cond ((= 'vla-object (type e)) e)((= 'ename (type e))(vlax-ename->vla-object e))(t nil))) ;;; show all blocks in group (defun sabig (gname / odic gdic grec el blist) (setq odic (namedobjdict)) (setq gdic (dictsearch odic "ACAD_GROUP")) (setq grec (dictsearch (cdar gdic) gname)) (setq el (massoc 340 grec)) (if (vl-consp el) (foreach x el (if (block-p x)(setq blist (cons (block-n (e->o x)) blist))))) (if (vl-consp blist) (dplm (acad_strlsort blist) (strcat "Blocks in group " gname)) (alert (strcat "Computer says no : sorry no block in group " gname)) ) )

Just a comment provided the layer exists, you can use a (cons 8 "Linework") in the entmake to make object on a certain layer.

First of all happy new year for everybody. Now about this app , RlxPaste. I often have need to copy some objects from one dwg to another. Although I allready have written a 'perfect' app for that , all my colleagues use it and I didn't want to add my junk symbols to it. So I came up with this app , which allows you to simply create symbols on the fly for local use. I think / hope the interface is self explanatory. You can control the grid in the setup dialog and you can select the folder where you save your symbols. Btw , double click to insert and if you want to delete item , click delete button and then click on image to delete. You can add a complete folder and its subfolders at once with the button Add Folder in the main dialog. This is usefull when you have for example a cd from a vendor or client with their company symbols. Hope it is usefull. gr. Rlx RlxPaste.dcl RlxPaste.LSP

Thanks for introducing me to Ray-Casting. To my shame , I must say I wasn't aware of such an algorithm. In return, I can say I came to a similar conclusion years ago. But my algorithm works to the right and left of the reference point, for safety's sake.

Yes @GLAVCVS, that is right, I know it. You can change the text height, and it will included in the selection set (if it still don't touching the boundary from polyline), and the second one can be, if you get a nil from the first ssget with _WP, you can make a selection set with _F (if the text touching the boundary from polyline). Anyway, it's on the @maahee to choose the right way to accomplish what he need.

It seems there is a confusion now with the topic. Point inside a closed polyline and select points inside a closed polyline, which is which? . Either way, for the first one, I can say by experience, Ray-Casting is the best and fastest approach. For the second one, @Saxlle hit it right, just as the OP wanted.

I usually work with dynamic input, and all prompts for ssget appear in the command line if dynamic input is off. Over the years, I'm still waiting for this feature to be added. .

Welcome to Cadtutor Vostro 1500! I (still) have disabled all messages from this site (gives me more rest / spare time ) As for your question , yes its a big dialog , so either get a bigger monitor , or maybe set yours to a higher resolution , no other way I'm afraid... sorry

https://www.theswamp.org/index.php?topic=47969.0

So, if from variable pts you get something like "<Selection set: 3121e>", that means the TEXT is inside the polygon, otherwise, you will get nil. Instead of (0 . "POINT") you need to use (0 . "TEXT"). This part I don't understand.

Also, you didn't mentioned what is that point in the polygon, what it present. Can you describe it more or give an example file?

Hi @maahee, You can first select that object using (setq obj (car (entsel "\nSelect the object:"))) ;an example Then you can read a X, Y values from closed polygon (if it's from polyline) using (setq ptlist (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget obj)))) And at final, you can use (setq pts (ssget "_WP" ptlist '((0 . "POINT"))) I hope you will find a right way to do that.

I will not answer your question for now, because I am interested in knowing the possible solutions proposed by others.

That's a good question. It's not as easy as it might seem at first glance. Although having a closed polyline makes the job easier. Just one thing should be clear: calculating the polygon's centroid isn't always effective. A more elaborate algorithm is needed.

@Steven P, I think the @Mountain_XD want to draw a rectangle between two selected points in that way the rectangle will be drawn inside the yellow polylines (I think that is walls) at desired height (T) in total length between two selected points. I think I understand correctly based on drawing.

Dear @pkenewell, thank You for help, it works like a charm Best greetings M

Check if it works. I don't have a PC in front of me so I edited it from my smartphone. ; DET.LSP Enlarge an Area for a Detail (c)1992, Victor V. Jensen ; - Modified for Release 11. ; [DET.LSP] ; Global variables: s#v, olderr. (prompt "\nLoading functions") ; details error function (defun deterr (S / A L) (if (/= S "Function cancelled") (princ (strcat "\nError: " S))) (command nil) (command ".UNDO" "B") (foreach A s#v (if (= (car A) "CLAYER") (command "LAYER" "S" (cadr A) "") (setvar (car A) (cadr A)) )) (setq *error* olderr s#v nil olderr nil) (princ) ) (princ ".") ; sscross function (defun sscross (/ S1 S2) (setq S1 (ssget "C" P2 P3) S2 (ssget "W" P2 P3)) (if (/= (sslength S1) (sslength S2)) (progn (command ".SELECT" S1 "R" S2 "") (ssget "p")) ) ; if ) (princ ".") ; explode function (defun explode (EN / A C E I L R S E1 E2 E3 S1 S2) (setq S2 (ssadd)) (while (setq EN (entnext EN)) (setq E (entget EN) ET (cdr (assoc 0 E)) E1 (cdr (assoc 41 E)) E2 (cdr (assoc 42 E)) E3 (cdr (assoc 43 E)) ) (if (= HL 1) (redraw EN 3)) (cond ((= ET "INSERT") (if (= (abs E1) (abs E2) (abs E3)) (if (or (< E1 0) (< E2 0) (< E3 0)) (progn (setq A (entlast) C (cdr (assoc 10 E)) I (cdr (assoc 2 E)) L (cdr (assoc 50 E)) R (car C) S (cadr C) ) (entdel EN) (setq S1 (ssadd)) (command ".INSERT" (strcat "*" I) C (abs E1) 0) (while (setq A (entnext A)) (setq S1 (ssadd A S1))) (if (< E1 0) (command ".MIRROR" S1 "" C (list R (+ 10 S)) "Y")) (if (< E2 0) (command ".MIRROR" S1 "" C (list (+ 10 R) S) "Y")) (if (/= L 0) (command ".ROTATE" S1 "" C (* (/ 180 pi) L))) ) (command ".EXPLODE" EN) ) (ssadd EN S2) )) ; if ((member ET '("POLYLINE" "DIMENSION")) (command ".EXPLODE" EN)) ((ssadd EN S2)) ) ; cond ) ; while (setq S1 (ssget "C" P2 P3)) (command ".ERASE" S2 "R" S1 "") ) (princ ".") ; id function (defun id (E / EN ET) (setq EN (cdr (assoc -1 E)) ET (cdr (assoc 0 E))) (if (= ET "ARC") (list EN ET (cdr (assoc 50 E)) (cdr (assoc 51 E))) (list EN ET) ) ; if ) (princ ".") ; trim output function (defun op (EN ET) (if (not (and (<= (- (car P2) 1E-6) (car ET) (+ (car P3) 1E-6)) (<= (- (cadr P2) 1E-6) (cadr ET) (+ (cadr P3) 1E-6)) )) (progn (command (list EN ET)) T) ) ; if ) (princ ".") ; trim function (defun trim (/ I L EN ET EA SA S1 TM E C R D90 D270) (while OK (setq OK nil I 0 S1 (sscross) L (if S1 (sslength S1) 0)) (if (> L 0) (command ".TRIM" C2 "")) (repeat L (setq EN (ssname S1 I) E (entget EN) ET (cdr (assoc 0 E)) I (1+ I)) (if (not (member (id E) TM)) (progn (setq TM (cons (id E) TM)) (cond ((= ET "LINE") (op EN (cdr (assoc 10 E))) (op EN (cdr (assoc 11 E)))) ((= ET "CIRCLE") (setq C (cdr (assoc 10 E)) R (cdr (assoc 40 E)) OK T) (cond ((op EN (list (+ R (car C)) (+ 0.0 (cadr C))))) ((op EN (list (+ 0.0 (car C)) (+ R (cadr C))))) ((op EN (list (+ (- R) (car C)) (+ 0.0 (cadr C))))) ((op EN (list (+ 0.0 (car C)) (+ (- R) (cadr C))))) )) ; cond ((= ET "ARC") (setq C (cdr (assoc 10 E)) R (cdr (assoc 40 E)) SA (cdr (assoc 50 E)) EA (cdr (assoc 51 E)) OK T D90 (/ pi 2) D270 (* pi 1.5) ) (if (> SA EA) (setq EA (+ EA (* pi 2)))) (cond ((op EN (polar C SA R))) ((op EN (polar C EA R))) ((or (<= SA 0.0 EA) (<= SA (* pi 2) EA)) (op EN (polar C 0.0 R))) ((or (<= SA D90 EA) (<= SA 0.0 EA)) (op EN (polar C D270 R))) ((or (<= SA pi EA) (<= SA (* pi 3) EA)) (op EN (polar C pi R))) ((or (<= SA D270 EA) (<= SA (* pi 3.5) EA)) (op EN (polar C D270 R))) )) ; cond )) ; cond )) ; if (if (> L 0) (command "")) ) ; while ) (princ ".") ; main program (defun C:DET (/ A E I L R DT EN ET HL OK TM C1 C2 S1 P0 P1 P2 P3 P4 P5) (setq DT (* (getvar "DIMSCALE") (getvar "DIMTXT")) HL (getvar "HIGHLIGHT") olderr *error* *error* deterr A '("HIGHLIGHT" "BLIPMODE" "OSMODE" "CLAYER" "ORTHOMODE") s#v (mapcar '(lambda (L) (list L (getvar L))) A) osmant (getvar "osmode") ) (setvar "CMDECHO" 0) (setvar "BLIPMODE" 0) (setvar "OSMODE" 0) (command ".UNDO" "M" ".LAYER" "S" "0" "ON" "0" "") (while (= OK nil) (initget 1) (setq P1 (getpoint "\nDetail centerpoint: ")) (princ "\nEncircle detail: ") (command ".CIRCLE" P1 PAUSE) (setq C1 (entlast) R (cdr (assoc 40 (entget C1))) L (sqrt (* (expt R 2) 2)) P2 (append (list (+ (car P1) R) (cadr P1))) A (angle P2 P1) P2 (polar P1 (* A 1.25) L) P3 (polar P1 (* A 0.25) L) S1 (ssget "C" P2 P3) ) (if (> (sslength S1) 1) (setq OK T) (progn (setq OK nil) (princ "\nNothing selected!") (command ".ERASE" C1 "")) ) ; if ) ; while (setvar "ORTHOMODE" 0) (princ "\nLocate detail: ") (command ".COPY" C1 "" P1 PAUSE) (command ".ERASE" C1 "") (setq P4 (getvar "LASTPOINT") C2 (entlast)) (setvar "HIGHLIGHT" 0) (command ".COPY" S1 "" P1 P4) (setvar "HIGHLIGHT" HL) (setq P2 (polar P4 (* A 1.25) L) P3 (polar P4 (* A 0.25) L) EN C2) (princ "\nProcessing data...please wait.") (explode EN) (trim) (setq S1 (sscross) L (if S1 (sslength S1) 0) I 0) (repeat L (setq EN (ssname S1 I) E (entget EN) ET (cdr (assoc 0 E)) I (1+ I)) (if (member ET '("LINE" "CIRCLE" "ARC")) (entdel EN)) ) (command "_REGENALL" "") ;(setvar "HIGHLIGHT" 0) (initget 6) ;(if (setq HL (getreal "\nScale factor <1.0000>: ")) (command ".SCALE" "C" P2 P3 "" P4 (setq HL 1.0)) ;) (setq P3 (polar P4 (* A 1.5) (cdr (assoc 40 (entget C2)))) P4 (polar P3 (* A 1.5) (* DT 2)) P5 (polar P4 (* A 1.5) (* DT 2)) ; TM (strcase (strcat "DETAIL-" (getstring " DETAIL-"))) ; ET (strcat "SCALE: " (getstring " SCALE: ")) ) ; (initget 1) (setq P2 (getpoint P1 "\nLocate leader text: ")) ; (if (or (<= (angle P1 P2) (/ A 2)) (>= (angle P1 P2) (* A 1.5))) ;--------------------------------- Release 11 --------------------------------- ; (progn (setq I "ML" P3 (polar P2 0.0 (* DT 2)) P0 (polar P2 0.0 (* DT 2.5)))) ; (progn (setq I "MR" P3 (polar P2 A (* DT 2)) P0 (polar P2 A (* DT 2.5)))) ;) ; if ;(command ".LINE" P1 P2 P3 "" ".TRIM" C1 "" P1 "" ".TEXT" I P0 DT "0" TM ; ".TEXT" "M" P4 (* DT 1.5) "0" (strcat "%%U" TM) ; ".TEXT" "M" P5 DT "0" ET ;) ;(foreach A s#v ; (if (= (car A) "CLAYER") ; (command ".LAYER" "S" (cadr A) "") (setvar (car A) (cadr A)) ;)) (setq *error* olderr s#v nil olderr nil) (setvar "osmode" osmant) (princ) ) ; end program (princ "loaded.") Basically: -it was necessary to save the state of the variable 'OSNAP' and restore it at the end -the part of the code where the scale is requested has been cancelled and the value 1.0 has been assigned directly

Yes, the (cons 8 "Linework") can be added to entmake, but after executing this line of code: (if (not (tblsearch "LAYER" "Linework")) (command "-layer" "m" "Linework" "") (command "-layer" "s" "Linework" "") ) it will be automatically set to current layer "Linework" and there is no needs for (cons 8 "Linework") inside the entmake.

Hi @ediba, Try with this modification: (defun c:AddLevelLine () (setvar "OSMODE" 1) ; Set osnap to endpoint ; Get points (setq pt1 (getpoint "\nSelect first point: ")) (setq pt2 (getpoint pt1 "\nSelect second point: ")) ; Force horizontal line by using same Y-coordinate (setq pt2 (list (car pt2) (cadr pt1) 0)) ; Prompt for level number (setq levelnum (getstring "\nEnter level number: ")) ; Create the line ;;(command "_layer" "s" "Linework" "") ;;(command "_line" pt1 pt2 "") ; Check if layer "Linework" already exist or not, if it's not, it will make the new layer and set to be "Linework" (if (not (tblsearch "LAYER" "Linework")) (command "-layer" "m" "Linework" "") (command "-layer" "s" "Linework" "") ) ;;; Create the line (entmake (list (cons 0 "LINE") (cons 10 pt1) (cons 11 pt2))) ; Calculate text positions (setq text_string (strcat "LEVEL " levelnum)) ; Create single-point text entities ;;;(command "_dtext" "j" "bc" pt1 0.2 0 text_string) ;;;(command "_dtext" "j" "bc" pt2 0.2 0 text_string) ;;; This few lines from below is better than from above '(command "_dtext" ......)' (setq def_height 0.20 rotation 0 horizontal_justification 1 vertical_justification 1 ) ;;; Instead of using "command", I prefer to use "entmake" (entmake (list (cons 0 "TEXT") (cons 10 pt1) (cons 40 def_height) (cons 1 text_string) (cons 50 rotation) (cons 11 pt1) (cons 72 horizontal_justification) (cons 73 vertical_justification))) (entmake (list (cons 0 "TEXT") (cons 10 pt2) (cons 40 def_height) (cons 1 text_string) (cons 50 rotation) (cons 11 pt2) (cons 72 horizontal_justification) (cons 73 vertical_justification))) (princ) ) Also, you can improve your code by adding somes checkings when user need to insert values (insted of (getstring "\nEnter level number: ") you can use (getint "\nEnter level number: ")), than you can convert it to string using "itoa" (strcat "LEVEL " (itoa levelnum)), localize the variables (defun c:AddLevelLine ( / pt1 pt2 levelnum ......) ......), etc. Best regards.

something like this (defun c:AddLevelLine () (setvar "OSMODE" 1) ; Set osnap to endpoint (setvar 'ORTHOMODE 1) ; Get points (setq pt1 (getpoint "\nSelect first point: ")) (setq pt2 (getpoint pt1 "\nSelect second point: ")) ; Prompt for level number (setq levelnum (getstring "\nEnter level number: ")) ; Create the line (command "_layer" "s" "Linework" "") (command "_line" pt1 pt2 "") ; Create single-point text entities (command"text" "j" "bc" pt1 "0.2" "0" (strcat "LEVEL " levelnum)) (command "txt2mtxt" (entlast)"") (princ) (setvar 'ORTHOMODE 0) )

Hi, Written a tool for replacing (updating) blocks. Had some spare time untill my boss recently used the W-word again (work , yak!) Anywayz , its a prototype so I'm not sure its stable and safe yet because I only did some lab testing. I hope it will be usefull. Not sure if I will be able to work on it further any time soon because I still have a few ideas and wishes. gr. Rlx RlxBlk manual.doc RlxBlk.lsp RlxBlk.dcl

I wrote this program like four years ago (just for fun / exercise) and maybe used it once or twice so as we say here on Mars : guaranteed to the doorstep If it works : , if it doesn't ... As usual never wrote a manual so have fun experimenting. RlxBlockSync.lsp

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)