Leaderboard

@SLW210 Your comments above and the header reminded me of theSwamp "Show You Stuff" section: http://www.theswamp.org/index.php?topic=31584.0 @ElAmigo did you try downloading version 5.0c? See the link above and try it - perhaps they fixed this issue?

Another Example: I wrote this back in the 90's (believe it or not) and still maintain it for drawing ANSI plug gages. It fully draws everything with Visual LISP. I Don't even use it anymore, but it's a good resource that I use as a test bed for trying out better code, and keeping myself exercised in LISP programming.

There are many ways to skin this cat (cond ((and txt (wcmatch (cdr (assoc 0 (entget txt))) "*TEXT")) also works.

@Tsuky Good Job. I did notice a bug however, and I am not sure why it is behaving like this. Try running your command on an MTEXT object that has only 1 field with no other text around it. For some reason it will kill the Field object, leaving behind "####" or "---". EDIT: I figured it out - thanks to reviewing Lee Mac's FieldArithmetic program. You need to clear the text contents before re-adding them for some reason. (defun c:foo ( / ss n ent obj old new) (defun string-subst (nam_obj / value_string nbs tmp_nbs) (setq value_string (vla-fieldcode nam_obj) nbs 0) (while nbs (if (setq nbs (vl-string-search "%pr0" value_string (setq tmp_nbs nbs))) (setq value_string (vl-string-subst "%pr2" "%pr0" value_string tmp_nbs) nbs (1+ nbs) ) ) ) (vlax-put nam_obj 'TextString "") ;; Add this line (vlax-put nam_obj 'TextString value_string) ) (setq ss (ssget '((0 . "MTEXT")))) (cond (ss (repeat (setq n (sslength ss)) (setq ent (ssname ss (setq n (1- n))) obj (vlax-ename->vla-object ent) ) (string-subst obj) ) ) ) (prin1) )

Pretty much the same here and most other companies. I have lots of convincing to do to get free apps from the Autodesk store, something from anonymous non opensource isn't going to happen. Sometimes Windows will flag the msi files and IT will have to research the source, so can take a while. AFAIK, the issue with things like DOSLIB, OpenDCL, etc. everyone using the codes needs them installed.

There are a few people going down this path, making ARX function library, I know of another to do with Excel functions. Yes have tested them, but still use lisp. Another is a poster pushing python code again need a runtime. I stay away from 3rd party add ons like DOSLIB have enough problems with clients just running lisps, without adding an extra load that they struggle to do. Look at LT2024 no DOSLIB.

(defun c:XDTB_DWGCUT (/ dynpt e lastpnt myerr olderr pts ss ss1 tf) (defun _callback (dynpt) (xdrx_entity_move ss lastpnt dynpt) (setq lastpnt dynpt) ) (defun _move (ss) (setq lastpnt (trans (xd::geom:get9pt ss 5)1 0)) (xdrx_pointmonitor "_callback" ss) (initget 1) (getpoint (xdrx-string-multilanguage "\n插入点:""\nInsert Point:")) (xdrx_pointmonitor) ) (defun myerr (msg) (princ "\n*cancel") (xdrx_end) (vl-cmdf ".undo" 1) (setq *error* olderr) (princ) ) (xdrx_begin) (setq olderr *error*) (setq *error* myerr) (setq pts nil) (if (setq e (car (xdrx_entsel (xdrx-string-multilanguage "\n请拾取裁剪边界<退出>:""\nPlease pick the cropping boundary <Exit>:") '((0 . "lwpolyline,circle,ellipse,spline")) ) ) ) (progn (setq tf (xdrx-document-safezoom e)) (setq pts (xdrx_getsamplept e) ss (ssget "cp" (xd::pnts:wcs2ucs pts)) ) (if (setq ss1 (xdrx_geom_clipboundary ss e t t)) (progn (if tf (xdrx_document_zoomprevious) ) (ssadd e ss1) (_move ss1) ) ) ) ) (setq *error* olderr) (xdrx_end) (princ) ) [XDrX-PlugIn(83)] DWG cutting (theswamp.org) https://www.theswamp.org/index.php?topic=59019.0

(defun c:linesthickness-0 ( / s i e ex ) (prompt "\nSelect LINE entities...") (setq s (ssget "_:L" (list (cons 0 "LINE")))) (repeat (setq i (sslength s)) (setq e (ssname s (setq i (1- i)))) (if (assoc 39 (setq ex (entget e))) (entupd (cdr (assoc -1 (entmod (subst (cons 39 0.0) (assoc 39 ex) ex))))) ) ) (princ) )

I think I commented earlier, it would be far more convenient for us if you post the code in the same thread as the question was asked, rather than starting a new single post thread without any context in another forum.

my problem has been resolved. Thank you to all of you

You may want to do a little research on object-oriented programming (OOP). Once you understand inheritance, abstraction, encapsulation, and polymorphism, it's easier to see how the pieces of an OOP system fit together. For instance, an AutoCAD object is more like a class, while an entity is more like an instance of a class. The class defines how the entity can behave, but the instance tells you how a particular entity does behave. Visual LISP is a dialect of AutoLISP that works in an Integrated Development Environment (IDE). It's supposed to make programming easier. Visual LISP objects aren't higher level, they're the same objects in a different space. The libraries are necessary to run code in that space. Visual LISP, in effect, adds a layer of abstraction so that you don't get stuck in the weeds of AutoLISP. Commands that start with vla- are part of Visual LISP. Commands that start with vlax- are part of the ActiveX system, which allows you to access other types of documents, such as Word or Excel. ActiveX commands are at once more generic and more powerful. Unfortunately, you can only use ActiveX with Windows. If you want to retrieve the layer of an object, you can do it either way, but notice the difference: (vla-get-layer 'obj) (vlax-get-property 'obj Layer) With the first command, you get the layer of an object. With the second one, you can get any property of that object, even if the property isn't related to AutoCAD. You can use either one, depending on how you feel about context, readability, and consistency.

@mhupp, You cannot do (ssadd nil ss3) you will get an " error: bad argument type: lentityp nil". So you need the if clause. ;;SSint by mhupp ;; ;; ;; ;; Return a selection set of Common element to both sets ;; ;; ;; (defun ssint (ss1 ss2 / e ss3) (setq ss3 (ssadd)) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1))) (if (ssmemb e ss2) (ssadd e ss3)) ) ss3 )

I see what your saying could be condensed down to. bad code

Doesn't ssadd add the entity if it is not there else it ignores it - so not sure you need the(if (ssmemb.....) ? (weekend.... )

https://www.lee-mac.com/listintersection.html

Here's my take. ;; cone_batter by ymg ; ;; ; ;; Note that ssb remains global and is the selection set of batters, ; ;; At a selection prompt enter !ssb ; ;; ; ;; Prog requires function midpoint. ; ;; ; (defun c:cone_batter (/ ent1 ent2 p1 p2 cum1 cum2 len1 len2 n_bat n i) (setq ent1 (car (entsel "\n Select a TOP polyline: ")) ent2 (car (entsel "\n Select a BOTTOM polyline: ")) n_bat (getint "\n How many batter tics: ") n (+ 1 n_bat) ) (setq len1 (/ (vlax-curve-getdistatparam ent1 (vlax-curve-getendparam ent1)) n) len2 (/ (vlax-curve-getdistatparam ent2 (vlax-curve-getendparam ent2)) n) cum1 0.0 cum2 0.0 i 0 ssb (ssadd) ) (repeat (+ n 1) (setq p1 (vlax-curve-getPointAtDist ent1 cum1) p2 (vlax-curve-getPointAtDist ent2 cum2) ) (if (zerop (rem i 2)) (entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2))) (entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 (midpoint p1 p2)))) ) (ssadd (entlast) ssb) (setq cum1 (+ cum1 len1) cum2 (+ cum2 len2) i (+ i 1) ) ) ) ;; Function midpoint by ymg ; ;; Returns the midpoint between 2 points. ; (defun midpoint (a b) (polar a (angle a b) (* (distance a b) 0.5))) ymg cone_batter.lsp

It may be easier to try this expects that you are picking 3 field text objects, expects that the destination mtext exists. ; pick multi mtext and paste into another mtext ; By AlanH March 2024 (defun c:wow ( / txt1 txt2 txt3 obj4) (setq txt1 (vlax-ename->vla-object (car (entsel "Pick 1st text object ")))) (setq str (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-objectid txt1)) ">%).TextString>%" ) ) (setq txt2 (vlax-ename->vla-object (car (entsel "Pick 2nd text object ")))) (setq str (strcat str "-" "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-objectid txt2)) ">%).TextString>%" ) ) (setq txt3 (vlax-ename->vla-object (car (entsel "Pick 3rd text object ")))) (setq str (strcat str "-" "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-objectid txt3)) ">%).TextString>%" ) ) (setq obj4 (vlax-ename->vla-object (car (entsel "Pick destination text ")))) (vlax-put obj4 'textstring str) (princ) )

Al revisar el archivo adjunto que compartió, noto que solo contiene una tabla con una descripción del equipo. Sin embargo, he observado que el equipo número 2 y el número 6 son idénticos. Si tu objetivo es identificar textos que sean exactamente iguales, puedes utilizar la siguiente rutina. En la primera selección se te pedirá que elijas el texto a identificar, o simplemente presionar enter para ingresarlo manualmente, mientras que en la segunda selección deberás seleccionar en una ventana los posibles textos duplicados. Al final, los textos idénticamente duplicados permanecerán seleccionados. En mi opinión esta estrategia es más práctica que unir los textos con una línea o polilínea. ;Select similar identical text v 1.0 ;Romero... March 2024 (defun C:SST ( / s1 obj lst s2 str) (princ "\nSelect the text string or enter to indicate manually :") (if (or (if (setq s1 (cadr (ssgetfirst))) (setq str (if (= 1 (sslength s1)) (cdr (assoc 1 (entget (ssname s1 0)))) (car (sssetfirst nil nil)) ) ) ) (if (setq s1 (car (entsel))) (setq str (cdr (assoc 1 (entget s1)))) ) (/= (setq str (getstring t "\nEnter the text to select: ")) "") (setq str "*") ) (progn (princ "\nSelect the other text objects...") (sssetfirst nil nil) (setq flst (list '(0 . "*TEXT") (cons 1 str))) (if (setq s2 (ssget (list '(0 . "*TEXT") (cons 1 str)))) (princ (strcat (itoa (sslength s2)) " objects")) ) (cadr (sssetfirst nil s2)) ) ) (if (zerop (getvar 'cmdactive)) (princ) (cadr (sssetfirst nil s2))) )

You can make bounding boxes from groups and then apply routines like there were only rectangles... You must also have big rectangular sheet where to place bounding boxes, but as far as I remember no rotations by 90 degree were included in solution codes...

This is challenge topic, but if you need it, maybe this topic may help... https://www.theswamp.org/index.php?topic=52260.0

I think that this: (setq q (getpoint "\nSpecify 2nd point: " p)) Should actually be this: (setq q (getpoint p "\nSpecify 2nd point: "))

@dungcan68 The error you are describing could not be coming from the code you have presented, but rather an global error handler made by some other additional code not included in what you have shown. The error itself comes from using the (command) function within an error handler, which causes some issues in newer versions of AutoCAD. the (command-s) function was created to allow command functions from within an error handler when referencing local variables, but older code that was not upgraded may display this error. I recommend you start looking through other AutoLISP functions you have loaded to determine which code is using a global error handler that contains the (command) function. See the following link for more info: https://help.autodesk.com/view/OARX/2023/ENU/?guid=GUID-5C9DC003-3DD2-4770-95E7-7E19A4EE19A1

i would just use I would use ssmemb then. this will create a global selection set SS3 ;;----------------------------------------------------------------------------;; ;; Create a third selection set of values found in both selection sets provied ;; (ssint ss sss) (defun SSInt (SS1 SS2) (setq SS3 (ssadd)) ;create a blank selection set to add entitys to (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS1))) ;generate a list of entity names (if (ssmemb ent SS2) ;test if its in the other selection set (ssadd ent ss3) ;add to the 3rd selection set if true ) ) (princ) )

Maybe like this : (defun c:sss-intersection ( / MR:ListsIntersection-sel-sets ss lst ) (defun MR:ListsIntersection-sel-sets ( ll / sel-set->ename-list ename-lists r l1 l2 rr k ) ;;; ll - list of sel.sets (defun sel-set->ename-list ( ss / i r ) (repeat (setq i (sslength ss)) (setq r (cons (ssname ss (setq i (1- i))) r)) ) r ) (setq ename-lists (mapcar (function (lambda ( x ) (sel-set->ename-list x))) ll)) (while (and (setq l1 (car ename-lists)) (setq l2 (cadr ename-lists))) (setq r (vl-remove-if-not '(lambda ( x ) (member x l2)) l1)) (setq ename-lists (subst r l2 ename-lists)) (setq ename-lists (cdr ename-lists)) ) (if r (progn (setq rr (ssadd) k -1) (repeat (length r) (ssadd (nth (setq k (1+ k)) r) rr) ) ) ) (if (and (= (type rr) (quote pickset)) (> (sslength rr) 0)) (sssetfirst nil rr) ) ) (prompt "\nChoose selections - when done press ENTER or right click...") (while (setq ss (ssget)) (setq lst (cons ss lst)) ) (MR:ListsIntersection-sel-sets lst) (princ) ) HTH. M.R.

And how if you have 4 or more sets? Maybe like this : (defun MR:ListsIntersection ( ll / r l1 l2 ) (while (and (setq l1 (car ll)) (setq l2 (cadr ll))) (setq r (vl-remove-if-not '(lambda ( x ) (member x l2)) l1)) (setq ll (subst r l2 ll)) (setq ll (cdr ll)) ) r ) (MR:ListsIntersection '((1 3 5 2 4) (6 8 1 3 5) (9 0 1 3 5) (7 4 2 1 3) (1 3 5 7 9))) ;;; (1 3) M.R.

I spent some more time with your drawing, here is the Lisp slightly adjusted. Now it searches only for texts that are at least 4 characters long. Also all the lines are placed on a new layer so you can delete them at once after the job is done. (defun c:pp( / ss ss2) (setq ss (ssget "X" '((0 . "TEXT")))) (setq a8 '(8 . "ConnectLines")) (repeat (setq i (sslength ss)) (setq en1 (ssname ss (setq i (1- i))) el1 (entget en1) a1 (assoc 1 el1)) (cond ((> (strlen (cdr a1)) 3) (setq a10 (assoc 10 el1) ss2 (ssget "X" (list '(0 . "TEXT") a1))) (repeat (setq j (sslength ss2)) (setq a11 (cons 11 (cdr (assoc 10 (entget (ssname ss2 (setq j (1- j)))))))) (cond ((/= a10 a11) (entmake (list '(0 . "LINE") a10 a11 a8)))) ) ) ) ) )

My suggestion that works with your example. To use it in other situations you will have to modify the arguments constituting the filters (ssget "_W" and "_X") for it to work. (defun c:FOO ( / ss_o ss_t n dxf_ent lst_o) (setq ss_o (ssget "_W" '(2027.9092 -426.6579) '(2327.9092 373.3421) '((0 . "TEXT") (8 . "TEXT") (62 . 2) (40 . 30.0) (7 . "GHS")))) (cond (ss_o (setq ss_t (ssget "_X" '((0 . "TEXT") (8 . "0") (62 . 7) (6 . "ByBlock") (40 . 3.4) (7 . "Single")))) (cond (ss_t (repeat (setq n (sslength ss_o)) (setq dxf_ent (entget (ssname ss_o (setq n (1- n)))) lst_o (cons (cons (cdr (assoc 1 dxf_ent)) (list (cdr (assoc 10 dxf_ent)))) lst_o) ) ) (repeat (setq n (sslength ss_t)) (setq dxf_ent (entget (ssname ss_t (setq n (1- n))))) (cond ((member (cdr (assoc 1 dxf_ent)) (mapcar 'car lst_o)) (entmake (list (cons 0 "LINE") (cons 10 (cdr (assoc 10 dxf_ent))) (cons 11 (cadr (assoc (cdr (assoc 1 dxf_ent)) lst_o))) ) ) ) ) ) ) ) ) ) (prin1) )

I was thinking of doing the same thing but with bpoly. Only problem it could give false positives if the point is outside the original polyline but still inside another closed polyline or area.

Your python solutions are increasing maybe make a doc of what they all do with some images no code. This needs updating. Lisp files June 2023.docx

Thank you! I did a quick google search and found this: https://cadabyss.wordpress.com/2010/01/04/stripmtext-v5-0/. The download on this site doesn't work. And then I found the reply by Devitg on this forum: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/stripmtext-v5-0-lisp-routine/td-p/2673838 Then I could apply the code with: (defun c:striptest ( / ss) (setq ss (ssget "X" '((0 . "MTEXT")))) ;; Select all TEXT and MTEXT objects in the drawing (if ss (STRIPMTEXT ss "F") ) )

Microsoft like AutoCAD allows VBA to be enabled because so many old VBA users still can't let go but both recommend against it. In Excel this option is Enable VBA macros (not recommended, potentially dangerous code can run) and it only applies to VBA macros. True there are many that ignore these warning and enable VBA code anyway. As long as you work in a closed shop, stay offline and don't exchange files outside your office you're probably fine.

A couple of problems may occur is cc0501 only twice in the dwg ? If it is multiple times wrong text may join. Yes can get a bounding box of the 2 text and draw a pline between them, that is the easy part maybe. Before any code answer question one and supply a sample dwg with more than 1 pair of text.

It should not lose the connection, we never signed in after the install. It sounds like a non connection is happening, when you open ACAD it pings a server and checks you do not see it. I would go back to the dealer for help. It may involve also your IT department giving permission for Autodesk server to be pinged.

Maybe explain it in a better detail, with some images or even a dwg file. Because right now, it's too abstract.

It's more in how the code has been written. You've set p2 to be the polar of pt at 0 degrees. So if there's no curve along that direction, ssget cannot find any curve and returns nil, thus ssname then yields an error. I would do it this way: (defun pt-in-region (pt pts Acc / ss-member-pts pt1 ptn p at ACC AT P PT PT1 PTN PTS) ;;judge a point is in the 2D polygon , polygon given with vetexs . ;;by GSLS(SS) 2011.03.28 ;;return 0 at polygon, 1 in it, -1 out it . (defun ss-member-pts (pt ptl acc / is_go i len a b) (setq is_go T i 0 len(length ptl)) (while (and is_go (< i len)) (setq a(car ptl)ptl(cdr ptl)i(1+ i)) (if (and a (equal a pt acc)) (setq is_go nil b (cons a ptl))))) (setq pt1(list (+ (car (apply (function mapcar) (cons (function max) pts)))(abs acc)(abs acc))(cadr pt))) (mapcar(function(lambda (x y) (if(setq p (inters pt pt1 x y T)) (progn (if(equal (+(distance pt x)(distance pt y))(distance x y)acc)(setq at T)) (if(not (ss-member-pts p pts acc)) (setq ptn (cons p ptn))))))) (cons (last pts) pts) pts) (cond (at 0) ((and (not at) ptn) (if (= (rem (length ptn) 2) 1) 1 -1 )) (t -1) ) ) ;;pts pt is (defun c:test (/ is poly pt pts) (setq pt (getpoint) poly (ssget "f" (list pt (polar pt 0 10000)) '((0 . "LWPOLYLINE"))) ) (cond ((not poly) (alert "Out .")) (t (setq pts (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (ssname poly 0)) ) ) is (pt-in-region pt pts 1e-8) ) (cond ((= is -1) (alert "Out .")) ((= is 0) (alert "At .")) ((= is 1) (alert "In .")) ) ) ) (princ) ) That being said, your code still yields incorrect results sometimes... That's if there is a horizontal segment along the polyline? I guess it's just up to the function itself:

Probably a Windows update messed it up. You might try a repair, restore to defaults or a remove and reinstall of AutoCAD or get a newer version designed to run with Windows 10.

That's called the Quick Access Toolbar (QAT) if that helps. What are your computer specifications? What Windows version? What happened that made it disappear? If I recall correctly, this was an issue with running older AutoCAD versions on Windows 10 or newer, I believe AutoCAD 2016 was first for Windows 10.

So a automatic save, have you looked at Autosave and the way it is setup to do what you want, check help.

I think we need a dwg to really see what you want a before after is needed. Can be VBA or Lisp.

This works amazingly. Just had to update my mlstyle to work with a center justification, also modified to suit my needs slightly, thank you. see below for my modification ; Routine to draw a multi-line wall with single line headers. ; Written: Jerry Fiedler - Feb 2024, Modified by EYNLLIB - FEB 2024 ; Multi-line routine Author: Lee Mac, Copyright © 2010 - www.lee-mac.com (defun c:wh (/ ptS ptE *error*) (defun *error* (msg) (if (not (member msg '("Function cancelled" "quit / exit abort" nil))) (princ (strcat "\nError: " msg)) ) (princ) ) (while t (c:mplb) (setq ptS (getvar 'lastpoint)) (setq ptE (getpoint ptS "\nEnd of header or ESC.")) (if (not ptE) (exit)) (entmake (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 2) (cons 70 0) (cons 8 "S - BEAMS") (cons 10 (trans ptS 1 0)) (cons 10 (trans ptE 1 0)) ) ) ) (princ) )

EYNLLIB, Here is my suggestion for doing what you want. I do not think you can easily modify Lee's routine to add a "line" header so I wrote a simple wrapper that should work for you. I only tested it with Lee's ORIGINAL routine on his website but I would think it would work with your modified version. For my test I set the multi-line justification to zero (centered) so the header (beam) will be in the center of the wall. To use this function: 1) Enter "wall-header" on the command line. 2) At the "start line" prompt enter J if you want to change the justification. Otherwise just click the start point of the wall. 3) Continue clicking points along the wall until your come to the point where you want the header. Click the point to end the wall then press <ENTER>. 4) At the prompt to select the end of the header just click the desired end point and a header will be drawn. 5) The next prompt will be for the start of the wall so just click the end of the new header and continue to draw wall segments. I could not think of a good way to stop this loop except to press <ESC> at the header end prompt. Perhaps someone can show me a better way. ; Routine to draw a multi-line wall with single line headers. ; Written: Jerry Fiedler - Feb 2024 ; Multi-line routine Author: Lee Mac, Copyright © 2010 - www.lee-mac.com (defun c:wall-header (/ ptS ptE) (while t (c:mpl) (setq ptS (getvar 'lastpoint)) (setq ptE (getpoint ptS "\nEnd of header or ESC.")) (entmake (list (cons 0 "LINE") ;(cons 8 headlyr) (cons 10 (trans ptS 1 0)) (cons 11 (trans ptE 1 0))) ) ) (princ) )

Maybe: (mapcar 'print (dictsearch (NAMEDOBJDICT) "ACAD_LAYOUT")) And maybe this: (foreach x (entget (namedobjdict)) (if (= 3 (car x)) (print (cdr x)) ) ) And this: (defun c:dicttest (/ l) (vl-load-com) (vlax-for d (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))) (if (vlax-property-available-p d 'name) (setq l (cons (list (vla-get-name d) d) l)) ) ) (mapcar 'print l) )

does just comment out the last line fix the issue so not (c:lrn) but ;(c:lrn) this will prevent the routine from running automatically

@Lee: You know, in retrospect, I don't know why I fooled with changing it to VL just to change the name. Brain wasn't screwed on all the way that day and all I did as a revision was clean up the code. I decided to update mine to exclude the unneeded use of VL and to give the option to edit the current layer - something I've been meaning to add any way. (defun c:RenL (/ ent old new lay) ;; Rename Layer of Selected Object or current layer ;; Required Subroutines: AT:Getstring ;; Alan J. Thompson, 11.30.09 / 05.21.13 (while (progn (setvar 'ERRNO 0) (initget 0 "Current") (setq ent (entsel "\nSelect object on layer to change name [Current]: ")) (if (eq (getvar 'ERRNO) 7) (princ "\nMissed, try again.") ) ) ) (cond ((not ent)) ((member (setq new (AT:Getstring "Specify new layer name:" (if (eq (type ent) 'STR) (cdr (assoc 2 (setq lay (entget (tblobjname "LAYER" (setq old (getvar 'CLAYER))) ) ) ) ) (cdr (assoc 2 (setq lay (entget (tblobjname "LAYER" (setq old (cdr (assoc 8 (entget (car ent))))) ) ) ) ) ) ) ) ) (list "" nil old) ) ) ((tblsearch "LAYER" new) (alert (strcat "Layer: \"" new "\" already exists!"))) ((not (snvalid new)) (alert (strcat "\"" new "\" is an invalid name!"))) ((entmod (subst (cons 2 new) (assoc 2 lay) lay)) (alert (strcat "Layer: " old " renamed to: " new)) ) ((alert (strcat "Layer: " old " could not be renamed to: " new))) ) (princ) ) (defun AT:GetString (#Title #Default / #FileName #FileOpen #DclID #NewString) ;; Getstring Dialog Box ;; #Title - Title of dialog box ;; #Default - Default string within edit box ;; Alan J. Thompson, 08.25.09 (setq #FileName (vl-filename-mktemp "" "" ".dcl") #FileOpen (open #FileName "W") ) (foreach x '("TempEditBox : dialog {" "key = \"Title\";" "label = \"\";" "initial_focus = \"Edit\";" "spacer;" ": row {" ": column {" "alignment = centered;" "fixed_width = true;" ": text {" "label = \"\";" "}" "}" ": edit_box {" "key = \"Edit\";" "allow_accept = true;" "edit_width = 40;" "fixed_width = true;" "}" "}" "spacer;" ": row {" "fixed_width = true;" "alignment = centered;" ": ok_button {" "width = 11;" "}" ": cancel_button {" "width = 11;" "}" "}" "}//" ) (write-line x #FileOpen) ) (close #FileOpen) (setq #DclID (load_dialog #FileName)) (new_dialog "TempEditBox" #DclID) (set_tile "Title" #Title) (set_tile "Edit" #Default) (action_tile "accept" "(setq #NewString (get_tile \"Edit\"))(done_dialog)") (action_tile "cancel" "(done_dialog)") (start_dialog) (unload_dialog #DclID) (vl-file-delete #FileName) #NewString )

(defun c:RenL (/ ent old new) ;; Rename Layer of Selected Object ;; Required Subroutines: AT:Getstring ;; Alan J. Thompson, 11.30.09 / 05.21.13 (while (progn (setvar 'ERRNO 0) (setq ent (car (entsel "\nSelect object on layer to change name: "))) (if (eq (getvar 'ERRNO) 7) (princ "\nMissed, try again.") ) ) ) (cond ((not ent)) ((member (setq new (AT:Getstring "Specify new layer name:" (setq old (cdr (assoc 8 (entget ent)))))) (list "" nil old) ) ) ((tblsearch "LAYER" new) (alert (strcat "Layer: \"" new "\" already exists!"))) ((not (snvalid new)) (alert (strcat "\"" new "\" is an invalid name!"))) ((vl-catch-all-error-p (vl-catch-all-apply 'vla-put-name (list (vlax-ename->vla-object (tblobjname "LAYER" old)) new) ) ) (alert (strcat "Layer: " old " could not be renamed to: " new)) ) ((alert (strcat "Layer: " old " renamed to: " new))) ) (princ) ) (defun AT:GetString (#Title #Default / #FileName #FileOpen #DclID #NewString) ;; Getstring Dialog Box ;; #Title - Title of dialog box ;; #Default - Default string within edit box ;; Alan J. Thompson, 08.25.09 (setq #FileName (vl-filename-mktemp "" "" ".dcl") #FileOpen (open #FileName "W") ) (foreach x '("TempEditBox : dialog {" "key = \"Title\";" "label = \"\";" "initial_focus = \"Edit\";" "spacer;" ": row {" ": column {" "alignment = centered;" "fixed_width = true;" ": text {" "label = \"\";" "}" "}" ": edit_box {" "key = \"Edit\";" "allow_accept = true;" "edit_width = 40;" "fixed_width = true;" "}" "}" "spacer;" ": row {" "fixed_width = true;" "alignment = centered;" ": ok_button {" "width = 11;" "}" ": cancel_button {" "width = 11;" "}" "}" "}//" ) (write-line x #FileOpen) ) (close #FileOpen) (setq #DclID (load_dialog #FileName)) (new_dialog "TempEditBox" #DclID) (set_tile "Title" #Title) (set_tile "Edit" #Default) (action_tile "accept" "(setq #NewString (get_tile \"Edit\"))(done_dialog)") (action_tile "cancel" "(done_dialog)") (start_dialog) (unload_dialog #DclID) (vl-file-delete #FileName) #NewString )

Here's one I use on a regular basis: (defun c:Clone (/ ent layer name) ;; Clone selected object's layer ;; Required subroutine: AT:GetString ;; Alan J. Thompson, 02.09.11 (setvar 'ERRNO 0) (if (while (and (not ent) (/= 52 (getvar 'ERRNO))) (initget 0 "Current") (setq ent (entsel "\nSelect object on layer to clone [Current]: ")) ) (cond ((not (setq name (AT:GetString "Specity clone layer name:" (setq layer (if (eq (type ent) 'STR) (getvar 'CLAYER) (cdr (assoc 8 (entget (car ent)))) ) ) ) ) ) ) ((not (snvalid name)) (alert "Invalid name!")) ((apply (function eq) (mapcar (function strcase) (list name layer))) (alert "Clone layer cannot have same name as base layer!") ) ((tblsearch "LAYER" name) (alert "Layer already exist!")) ((entmake (append (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") (cons 2 name) ) (vl-remove-if-not (function (lambda (x) (vl-position (car x) '(6 62 70 270 370)))) (entget (tblobjname "LAYER" layer)) ) ) ) (alert (strcat "Layer \"" layer "\" has been cloned to create layer: \"" (setvar 'CLAYER name) "\"" ) ) ) ) ) (princ) ) (defun AT:GetString (#Title #Default / #FileName #FileOpen #DclID #NewString) ;; Getstring Dialog Box ;; #Title - Title of dialog box ;; #Default - Default string within edit box ;; Alan J. Thompson, 08.25.09 (setq #FileName (vl-filename-mktemp "" "" ".dcl") #FileOpen (open #FileName "W") ) (foreach x '("TempEditBox : dialog {" "key = \"Title\";" "label = \"\";" "initial_focus = \"Edit\";" "spacer;" ": row {" ": column {" "alignment = centered;" "fixed_width = true;" ": text {" "label = \"\";" "}" "}" ": edit_box {" "key = \"Edit\";" "allow_accept = true;" "edit_width = 40;" "fixed_width = true;" "}" "}" "spacer;" ": row {" "fixed_width = true;" "alignment = centered;" ": ok_button {" "width = 11;" "}" ": cancel_button {" "width = 11;" "}" "}" "}//" ) (write-line x #FileOpen) ) (close #FileOpen) (setq #DclID (load_dialog #FileName)) (new_dialog "TempEditBox" #DclID) (set_tile "Title" #Title) (set_tile "Edit" #Default) (action_tile "accept" "(setq #NewString (get_tile \"Edit\"))(done_dialog)") (action_tile "cancel" "(done_dialog)") (start_dialog) (unload_dialog #DclID) (vl-file-delete #FileName) #NewString )

Well, try this one instead (defun C:A2S(/ ang1 ang2 len osm p1 p2 p3 p4 wid);;OK (setq *num* 2) (command "_undo" "_be") (setq osm (getvar "osmode")) (setvar "cmdecho" 0) (if (and (setq p1 (getpoint "\nLower Left corner point: ")) (setq p3 (getpoint p1 "\nUpper Right corner point: ")) (setq p2 (getpoint p3 "\nLower Right corner point: ")) (setq num (cond ((getint (strcat"\nSpecify number of subareas (Hit to accept) <"(itoa *num*)">: "))) (num))) ) (progn (setq *num* num) (setq ang1 (angle p1 p2) ang2 (angle p2 p3) len (distance p1 p2) wid (distance p2 p3) ) (setq p2 (polar p1 ang1 (/ len num))) ;;number of divisions were added (setq p4 (polar p1 ang2 wid)) (setq p3 (polar p2 ang2 wid)) (command "_pline" "_non" p1 "_non"p2 "_non"p3 "_non"p4 "_CL") (repeat (- num 1)(command "_copy" (entlast) "" "_non" p1 "_non" p2) (setq p1 p2 p2 (polar p1 ang1 (/ len num)))) ) ) (setvar "osmode" osm) (command "._undo" "_e") (princ) )

Just a quick shot on this way with no error checking (defun C:A2S(/ ang1 ang2 len osm p1 p2 p3 p4 wid) (command "_undo" "_be") (setq osm (getvar "osmode")) (setvar "cmdecho" 0) (if (and (setq p1 (getpoint "\nLower Left corner point: ")) (setq p3 (getpoint p1 "\nUpper Right corner point: ")) (setq p2 (getpoint p3 "\nLower Right corner point: "))) (progn (setq ang1 (angle p2 p1) len (distance p1 p2)) (setq p2 (polar p2 ang1 (/ len 2))) (setq p4 (polar p3 ang1 len)) (setq ang2 (angle p1 p4) wid (distance p1 p4)) (setq p3 (polar p2 ang2 wid)) (command "_pline" "_non" p1 "_non"p2 "_non"p3 "_non"p4 "_CL") (command "_copy" (entlast) "" "_non"p1 "_non"p2) ) ) (setvar "osmode" osm) (command "_undo" "_e") (princ) )

Hi all, I'm looking for a lisp to make a enlarge detail. Thanks for any help. Pascal