Leaderboard

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

Get smaller fingers so you don't hit them by accident? Look at an internet search: 'AutoCAD mapping F keys"

Bit late to the party but try this. See the header for changes I've made. (vl-load-com) ;; ;; Replace multiple instances of selected blocks (can be different) with selected block ;; Size and Rotation will be taken from original block and original will be deleted ;; Required subroutines: AT:GetSel ;; Alan J. Thompson, 2010.09.02 ;; Found at: http://www.cadtutor.net/forum/showthread.php?48458-Replace-Selected-Block-Or-Blocks-With-Another-Block ;; ;; EDIT by 3dwannab, 2018.04.09 - Added redraw to old block selection, Error handling for redraw and sssetfirst newly created blocks. ;; EDIT by 3dwannab, 2024.08.15 - Removed original selection from the new selection set and output block name to commandline. ;; EDIT by 3dwannab, 2024.11.28 - Give the user the ability to replace the same blocks by name as the ones selected. Option Yes/No. ;; - Option to choose whether you want to match properties or not. Option Yes/No. ;; - Added undo handling. ;; - Changed the redraw to a regen to correctly display the new selection of blocks. ;; ;; TO DO LIST ;; N/A ;; (defun c:BKReplace (/ *error* acDoc ansMatchProps ansReplaceAll blkNew blkNewObj def e f lst ssReplaced ssSel ssVla var_cmdecho var_osmode var_selectsimilarmode) (defun *error* (errmsg) (and acDoc (vla-EndUndoMark acDoc)) (and errmsg (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*")) (princ (strcat "\n<< Error: " errmsg " >>\n")) ) (command "_.regen") (setvar 'cmdecho var_cmdecho) (setvar 'osmode var_osmode) (setvar 'selectsimilarmode var_selectsimilarmode) ) ;; Start the undo mark here (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object))) (or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc)) ;; Get any system variables here (setq var_cmdecho (getvar "cmdecho")) (setq var_osmode (getvar "osmode")) (setq var_selectsimilarmode (getvar 'selectsimilarmode)) (setvar 'cmdecho 0) (setvar 'osmode 0) (if (and (AT:GetSel entsel "\nSelect NEW block: " (lambda (blkOriginal / e) (if (and (eq "INSERT" (cdr (assoc 0 (setq e (entget (car blkOriginal)))))) (/= 4 (logand (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 e))))) 4)) (/= 4 (logand (cdr (assoc 70 (entget (tblobjname "LAYER" (cdr (assoc 8 e)))))) 4)) ) (setq blkNewObj (vlax-ename->vla-object (car blkOriginal))) ) ) ) (not (redraw (vlax-vla-object->ename blkNewObj) 3)) ) (progn ;; initget from LeeMac help pages (initget "No Yes") (setq ansReplaceAll (cond ((getkword (strcat "\nReplace all the same blocks as the one you select now ? [Yes/No] <" (setq ansReplaceAll (cond (ansReplaceAll) ("Yes"))) ">: " ) ) ) (ansReplaceAll) ) ) ;; If No to replace blocks only replace the selection (if (= ansReplaceAll "No") (progn (princ "\nSelect OLD blocks to be replaced: ") (setq ssReplaced (ssget "_:L" '((0 . "INSERT")))) ) ;; If yes, replace the same blocks as the one you select (progn ; Code by Lee Mac http://www.cadtutor.net/forum/showthread.php?92638-Simple-fix-%28LISP-noob%29-Syntax-problem&p=633824&viewfull=1#post633824 ;; Iterate over the block table and compile a list of xref blocks to exclude (while (setq def (tblnext "block" (not def))) (if (= 4 (logand 4 (cdr (assoc 70 def)))) (setq lst (vl-list* "," (cdr (assoc 2 def)) lst)) ) ) ;; Attempt to retrieve a selection of blocks (but not xrefs) (setq ssReplaced (ssget (cons '(0 . "INSERT") (if lst (vl-list* '(-4 . "<NOT") (cons 2 (apply 'strcat (cdr lst))) '((-4 . "NOT>"))))))) ;; Set selectsimilarmode to use the name of an object. (setvar 'selectsimilarmode 128) ;; If ss1 one is valid then do this (if ssReplaced (progn (vl-cmdf "_.selectsimilar" ssReplaced "") (setq ssReplaced nil) ;; Reset the selection set (setq ssReplaced (ssget)) ;; Create a new selection set for to zoom and reselect as the zoom objects will do this ) (princ "\n: ------------------------------\n\t\t*** Nothing selected ***\n: ------------------------------\n") ) ) ) (setq f (not (vla-startundomark (cond (acDoc) ((setq acDoc (vla-get-activedocument (vlax-get-acad-object)))) ) ) ) ) ;; initget from LeeMac help pages (initget "No Yes") (setq ansMatchProps (cond ((getkword (strcat "\nMatch these properties? Insertionpoint, Rotation, XEffectiveScaleFactor, YEffectiveScaleFactor & ZEffectiveScaleFactor\nNo only matches the Insertion Point and Rotation[Yes/No] <" (setq ansMatchProps (cond (ansMatchProps) ("Yes"))) ">: " ) ) ) (ansMatchProps) ) ) ; Set ssSel to a null selection set: (setq ssSel (ssadd)) (vlax-for blkOriginal (setq ssVla (vla-get-activeselectionset acDoc)) ;; Check if old block is not part of the new selection (if (not (equal (vlax-vla-object->ename blkNewObj) (vlax-vla-object->ename blkOriginal))) (progn (setq blkNew (vla-copy blkNewObj)) (cond ((= "Yes" ansMatchProps) (mapcar (function (lambda (p) (vl-catch-all-apply (function vlax-put-property) (list blkNew p (vlax-get-property blkOriginal p)) ) ) ) '(Insertionpoint Rotation XEffectiveScaleFactor YEffectiveScaleFactor ZEffectiveScaleFactor) ) ) ((= "No" ansMatchProps) ;; Only match the insertion point (mapcar (function (lambda (p) (vl-catch-all-apply (function vlax-put-property) (list blkNew p (vlax-get-property blkOriginal p)) ) ) ) '(Insertionpoint Rotation) ) ) ) ; The following command adds the blkNew entity to the selection set referenced by ss2: (ssadd (vlax-vla-object->ename blkNew) ssSel) (vla-delete blkOriginal) ) ) ) ; Select ssSel (sssetfirst nil ssSel) (redraw (vlax-vla-object->ename blkNewObj) 4) (vla-delete ssVla) (princ (strcat "\n'" (vla-get-effectivename blkNewObj) "' has replaced " (itoa (sslength ssReplaced)) (if (> (sslength ssReplaced) 1) " blocks" " block"))) ) ) (vla-EndUndoMark acDoc) (*error* nil) (princ) ) (defun AT:GetSel (meth msg fnc / ent good) ;; meth - selection method (entsel, nentsel, nentselp) ;; msg - message to display (nil for default) ;; fnc - optional function to apply to selected object ;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (blkOriginal) (eq (cdr (assoc 0 (entget (car blkOriginal)))) "ARC"))) ;; Alan J. Thompson, 05.25.10 (setvar 'errno 0) (while (not good) (setq ent (meth (cond (msg) ("\nSelect OLD blocks to be replaced: ") ) ) ) (cond ((vl-consp ent) (setq good (cond ((or (not fnc) (fnc ent)) ent) ((prompt "\nInvalid object!")) ) ) ) ((eq (type ent) 'STR) (setq good ent)) ((setq good (eq 52 (getvar 'errno))) nil) ((eq 7 (getvar 'errno)) (setq good (prompt "\nMissed, try again."))) ) ) ) (princ "\nBK_Replace.lsp loaded...") (princ) ; (c:BKReplace) ;; Unblock for testing

@Nikon There were a few errors in the code you posted .. FWIW here are some modifications with comments. ;; Create a new text style and replace all styles in the drawing (defun c:cr-txtst-sel2 ;; RJP - Localize all variables (/ acaddoc eo ff i objstyle oldcmd select ss styles) (vl-load-com) ;; RJP - Check that the font can be found otherwise BOOM! Also search for the system font not tied to a CAD version (if (findfile (setq ff (strcat (getenv "WINDIR") "\\FONTS\\ARIALN.ttf"))) ;; (findfile (setq ff "C:\\Program Files\\Autodesk\\AutoCAD 2019\\Fonts\\ARIALN.ttf")) (progn (setq acaddoc (vla-get-activedocument (vlax-get-acad-object))) (setq styles (vla-get-textstyles acaddoc)) ;; Add the style named "ArialN0" (setq objstyle (vla-add styles "ArialN0")) ;; Assign fontfile "ARIALN.ttf" to the style (vla-put-fontfile objstyle ff) ;; Optional: Make the new style Active (vla-put-activetextstyle acaddoc objstyle) ;; Replace All/Select texts with the ArialN0 style (initget "All Select") (if (= "All" (setq select (getkword "\nSelect text to change [All/Select] <Select> : "))) (setq ss (ssget "_X" '((0 . "*TEXT")))) (setq ss (ssget "_:L" '((0 . "*TEXT")))) ) ;; RJP - Check for valid selection (if ss (progn (setq oldcmd (getvar "cmdecho")) (setvar "cmdecho" 0) (repeat (setq i (sslength ss)) (setq eo (vlax-ename->vla-object (ssname ss (setq i (1- i))))) ;; RJP - Check that the text can be modified (if (vlax-write-enabled-p eo) (vlax-put eo 'stylename "ArialN0") ) ) ;; RJP - This line below bombs the code? ;; (vla-endundomark doc) ; Set the style to the current one (vl-cmdf "_-PURGE" "_ST" " " "_N") ; clear unused text styles (setvar "cmdecho" oldcmd) ) ) ) (alert (strcat ff " NOT FOUND!")) ) (princ) )

I have done translations before. I'd suggest using Notepad ++ to open the file because it keeps the foreign characters for a better translation than regular Notepad. Then use Google Translate or some other translator and translate the comments only at first. This way you understand what the program is doing. Then, only translate the prompts. If the program works as it is, I wouldn't tinker with it too much. Some of the prompts may have some setq variables to adjust, but keep it simple.

You need to modify the key from the CUI manually.

or put them on temp layer first , then change style / layer. Not sexy but dragonproof.

Just keep practicing is the best solution. The answer to align is just that there is a ALIGN command, pick objects, pick 1st point object, pick 1st point for align, repeat for second point, press Enter and it should happen. Read the prompts that come up.

You are entirely welcome. I wish you every success come the New Year.

I would add a does new layer exist ? The oldlayer ssget will fail if the layer does not exist so that is handled. (if (= (tblsearch "LAYER" newlayer) nil) (command "-layer" "m" newlayer "C" 3 "" "") )

now you tell me I like this quote : “Life is not obliged to give us what we expect.” Sure , some users don't respond or don't give a like but unlike some users , I don't feel the need to respond to every thread or want to collect as many likes as I can for the sake of reputation points. Most of us are here just to give a helping hand to those who ask for it and expecting eternal glory or whatever only leads to disappointment. Having said this , I am gratefull for everybody who liked my post. It does give a feeling of appreciation. Even when OP is a No Show , others may still find your response useful. So when you do deal with a 'leacher' , just append his folder with "_No_Show" so next time you feel the urge to respond you can lower your expection for ever getting a response.

Just wanted something more flexible , user friendly and sexier for me , myself and I

Hi @mhy3sx... I've updated my last posted code... Now it won't miss anything... I checked it and it worked well with fuzz = 1.0... HTH. Regards, M.R.

Using VLAX can save a couple of lines when getting pline points. (setq r (vlax-get ob 'coordinates)) I tend to use this, I think it was a suggestion by Lee-Mac. (setq plent (entsel "\nPick rectang")) (if plent (setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car plent))))))

I have moved your thread to the AutoLISP, Visual LISP & DCL Forum. Please post in the correct forum.

I have select a dynamic block you will then be asked to pick say a visibility state or in your case an extrusion shape. Not sure how that works. It is a global routine works for any dynamic block. It will need changing to suit your task. Post a block or send via PM if you have copyright problems. Need one to look at. .Multi radio buttons.lsp Dynamic block get-put-part2.lsp

Why not do it all in one go ? That is what I am suggesting. @Dadgad is hinting can help he can use the front end if useful, was done using this. The profiles could be selected from images rather than just a description. Multi GETVALS.lsp

I don't do much in 3d but why would you not just draw the correct sizes to start with, by that I mean use a front end. I just tend to do this type of thing from 1st principles, within lisp can do extrude, subtract etc.

I have 2 make layouts lisp, working on a 3rd method. You can walk along a p/Line and it makes rectangs at correct scale matching your title block, it rotates the rectangs to following the line work so layouts are displayed horizontally. The second is a more grid style where you just make the 1st rectang at scale again then copy it see movie. The 3rd doing now is for more a parts style solution just pick a point in model, select scale and title block, matching layout is made. Draw rectangs.mp4 Ok a comment , for me you don't scale your mview shape, rather the mview is fixed shape within a title block, the title block exists in a layout at 1:1 scale, true size, the mview has its scale set to desired scale. See image above. Withe the title block fixed and at a known point like 0,0 it makes auto plotting easy. Ok I charge a price like a cup of coffee as the code needs to be set up to suit your title blocks. Yes can be imperial or metric. Also check the word doc.Lisp files Apr 2024.docx

Talking to Butch via email putting something together. based on this starting point and pick point in model, layout made and mview created at correct scale.

Just create a few templates and then do a simple import. I don't think having lisp setting them up is worth the trouble , but that's just me...

From the documentation, the StationOffset method will accept an X & Y coordinate and return two output parameters (station & offset), as such, you'll need to supply the appropriate number of parameters, e.g.: (vlax-invoke-method objAlign 'StationOffset (car point) (cadr point) 'stn 'off) (print stn) (prin1 off)

I tend to shy away from automatic changes, partly different clients have different naming conventions for files and drawings to make that trickier. However, if all drawings follow the same conventions then yes, a short LISP to check things out as things open is a handy tool.

you could also search this forum for 'outline' , I think this subject has been posted before. Else you could also try outline from master Lee Sometimes routine is not perfect and you still have to manually delete some leftovers but you decide if near perfect is good enough.

https://lee-mac.com/ssboundingbox.html Will do a rectangular box, might be able to be modified to get the shape?

Okay, I got something. It copy/pastes: - color - linetype - Transparency of an object that you select. And sets those properties to a new layer that you type (getstring). If there's anything more the script should do, then tell me. Command: CNLIP (for: Create New Layer Identical Properties) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; https://forum.bricsys.com/discussion/28719/how-to-put-transparency-to-an-objekt-in-bricscad-16 ; Transparency: ; 0 ; Transparency ByLayer. ; (lsh 1 24) => 16777216 ; Transparency ByBlock. ; (lsh 2 24) => 33554432 ; Transparency 100%; Saturation 0%. ; (+ (lsh 2 24) 255) => 33554687 ; Transparency 0%; Saturation 100%. ; (_Sys_Transparency_Num_To_Perc 33554661) => 0.1 ; (_Sys_Transparency_Num_To_Perc (cdr (assoc 440 (entget (car (entsel)))))) (defun _Sys_Transparency_Num_To_Perc (num) (* 0.01 (fix (/ (- 33554687 num) 2.55))) ) ; (_Sys_Transparency_Perc_To_Num 0.1) => 33554661 (defun _Sys_Transparency_Perc_To_Num (perc) (fix (- 33554687 (* perc 255))) ) ; (TransparencyPut (car (entsel)) "80") ; (TransparencyPut (car (entsel)) "ByLayer") ; (TransparencyPut (car (entsel)) "ByBlock") (defun TransparencyPut (enme str) (vle-entmod 440 enme (cond ((= "BYLAYER" (strcase str)) 0 ) ((= "BYBLOCK" (strcase str)) 16777216 ) (T (_Sys_Transparency_Perc_To_Num (* 0.01 (atoi str))) ) ) ) ) ; (TransparencyGet (car (entsel))) (defun TransparencyGet (enme / num) ;;(setq num (vle-entget 440 enme)) (setq num (cdr (assoc 440 (entget enme)))) ;;(princ num) (cond ((not num) "BYLAYER" ) ((zerop num) "BYLAYER" ) ((= 16777216 num) "BYBLOCK" ) (T (rtos (* 100 (_Sys_Transparency_Num_To_Perc num)) 2 0) ) ) ) ;; Test TransparencyGet (defun c:gtra ( / ) (TransparencyGet (car (entsel))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (vl-load-com) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; https://www.lee-mac.com/colourconversion.html ;; RGB -> True - Lee Mac ;; Args: r,g,b - [int] Red, Green, Blue values (defun LM:RGB->True ( r g b ) (logior (lsh (fix r) 16) (lsh (fix g) 8) (fix b)) ) ;; True -> RGB - Lee Mac ;; Args: c - [int] True Colour (defun LM:True->RGB ( c ) (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CREATE LAYER with color / also true color ;; transparency. ;; Taken from Steven P, I presume from a Lee Mac function. ;; https://www.cadtutor.net/forum/topic/85796-select-all-layer-turn-to-color-252/#findComment-640849 (defun LM:setlayertransparency ( lay trn / ent ) (defun LM:trans->dxf ( x ) (logior (fix (* 2.55 (- 100 x))) 33554432) ) (if (setq ent (tblobjname "layer" lay)) (progn (regapp "accmtransparency") (entmod (append (entget ent) (list (list -3 (list "accmtransparency" (cons 1071 (LM:trans->dxf trn)) ) ; end list ) ; end list ))) ; end entmod ) ; end progn ) ; end if ) ; end defun ;; (LM:setlayertransparency Layname (atoi xxx) ) ;; test, create earth cable layer (defun c:test_cl ( / ) (_create_new_layer_ "mynewlayer3" ;;name '(178 254 1) ;;color (yellowy green) "Center" ;;ltype 1 ;;plot ) ;; set to 70% transparency (LM:setlayertransparency "mynewlayer3" 70 ) (_create_new_layer_ "mynewlayer4" ;;name 15 ;;color "continuous" ;;ltype 1 ;;plot ) ) (defun _create_new_layer_ (lName color ltype plot / _rgb lt) (defun _rgb (l) (+ (lsh (fix (car l)) 16) (lsh (fix (cadr l)) 8) (fix (caddr l)))) (cond ((not (tblsearch "layer" lName)) (entmakex (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") '(70 . 0) (cons 2 lName) (if color (if (listp color) ;; see if color is a list of RGB (cons 420 (_rgb color)) (cons 62 color) ) ;; else, default white (cons 62 0) ) (cons 6 (if ltype (if (tblsearch "ltype" ltype) ltype "continuous" ) "continuous" ) ) (cons 290 plot) ;;1 = plottable 0 = not=plottable ) ) ) ((tblobjname "layer" lName)) ) ) ;; (_create_new_layer "NewLayerName" '(69 69 69) "3Dash2" 1) ;; true color, some dark grey ;; (_create_new_layer "NewLayerName2" 169 "3Dash2" 1) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; create a new layer by copying all properties from an existing object. ;; such as color (index color, true color, color books), line weight, line type, and transparency. ;; Create New Layer Identical Properties (defun c:cnlip ( / src lName color ltype transp) (setq src (car (entsel "\nSelect source object: "))) (setq color (if (or (assoc 420 (entget src)) (assoc 62 (entget src))) (if (assoc 420 (entget src)) (LM:True->RGB (cdr (assoc 420 (entget src)))) (cdr (assoc 62 (entget src))) ) ;; else ByLayer nil ) ) ;; Color. Must return: ;; - nil => ByLayer ;; - a integer: 0 to 255. 0 = ByBlock; 1=red, 2=yellow, ... ;; - RGB list of three 0-255 (princ "\nColor: ") (princ Color) ;;(princ " - ") ;;(princ (LM:True->RGB Color)) (setq ltype (if (assoc 6 (entget src)) (cdr (assoc 6 (entget src))) ;; else "continuous" ) ) (princ "\n\Linetype: ") (princ ltype) (setq lName (getstring "\nName of the new layer: ")) (_create_new_layer_ lName color ltype 1 ) ;; Transparency (setq transp (TransparencyGet src)) (if (atoi transp) (LM:setlayertransparency lName (atoi transp)) ) (princ "\nLayer created: ") (princ lName) (princ) )

As noted by rlx, this is unfortunately a bug in the ObjectDBX interface, and therefore not something which can be overcome using the LISP API - I note this as one of the known restrictions of the application. Hopefully a simple open/save/close script can rectify any inconvenience caused.

As you mentioned the issue is using OBDX to change objects, so you may have to run a script open the 400 one at a time and saveas. Then go to lunch. The other may be using Acoreconsole it may support the saveas command. Not tested, accoreconsole can run over an entire directory of dwg's. Like OBDX there is no opening of dwgs. Here is a couple of good sources of how to use Accoreconsole. https://through-the-interface.typepad.com/through_the_interface/2012/02/the-autocad-2013-core-console.html https://forums.autodesk.com/t5/forums/replypage/board-id/130/message-id/444989

Maybe something like this as a starting point.Multi GETVALS.lsp save Multi getvals in a support path as its auto loaded. ; 4 holes in rectang ; By AlanH Feb 2022 ; Modified for row and columns July 2024 (defun c:recholes ( / oldsnap obj ss len ht ans voff hoff rad rows cols ) (setq oldsnap (getvar 'osmode)) (setvar 'osmode 0) (if (not AH:getvalsm)(load "Multi Getvals.lsp")) (setq ans (AH:getvalsm (list "Enter values" "length" 5 4 "20" "height" 5 4 "10" "vertical offset" 5 4 "1.5" "Horizontal offset" 5 4 "2.5" "Radius" 5 4 "0.25" "Hor columns" 5 4 "4" "Ver rows" 5 4 "3" "Angle " 5 4 "0.0"))) (setq len (atof (nth 0 ans)) ht (atof (nth 1 ans)) voff (atof (nth 2 ans)) hoff (atof (nth 3 ans)) rad (atof (nth 4 ans)) cols (atoi (nth 5 ans)) rows (atoi (nth 6 ans)) ang (atof (nth 7 ans)) ) (setq pt (getpoint "\nPick lower left point")) (command "Rectang" pt (mapcar '+ pt (list len ht 0.0))) (setq rent (entlast)) (setq ss (ssadd)) (setq pt1 (mapcar '+ pt (list hoff voff 0.0))) (command "circle" pt1 rad) (setq ss (ssadd (entlast) ss)) (setq pt3 pt1) (setq d1 (/ (- len (* 2.0 hoff))(- cols 1))) (repeat (- cols 1) (setq pt2 (mapcar '+ pt3 (list d1 0.0 0.0))) (command "circle" pt2 rad) (setq pt3 pt2) (setq ss (ssadd (entlast) ss)) ) (setq d2 (/ (- ht (* 2.0 voff))(- rows 1))) (setq x 1.0) (repeat (- rows 1) (setq pt2 (mapcar '+ pt1 (list 0.0 (* x d2) 0.0))) (command "copy" ss "" pt1 pt2) (setq x (1+ x)) ) ; top dims (setq pt1 (mapcar '+ pt (list 0.0 ht 0.0))) (setq pt2 (mapcar '+ pt (list len ht 0.0))) (setq pt3 (mapcar '+ pt1 (list 0.0 5.0 0.0))) (command "dim" "Hor" pt1 pt2 pt3 "" "exit") (setq pt2 (mapcar '+ pt1 (list hoff (- voff) 0.0))) (setq pt3 (mapcar '+ pt1 (list 0.0 2.5 0.0))) (command "dim" "Hor" pt1 pt2 pt3 "" "exit") (repeat (- cols 1) (setq pt1 pt2) (setq pt2 (mapcar '+ pt1 (list d1 0.0 0.0))) (command "dim" "Hor" pt1 pt2 pt3 "" "exit") ) (setq pt1 pt2) (setq pt2 (mapcar '+ pt1 (list hoff 0.0 0.0))) (command "dim" "Hor" pt1 pt2 pt3 "" "exit") ;left dims (setq pt2 (mapcar '+ pt (list 0.0 ht 0.0))) (setq pt3 (mapcar '+ pt (list (- 5) 0.0 0.0))) (command "dim" "Ver" pt pt2 pt3 "" "exit") (setq pt2 (mapcar '+ pt (list hoff voff 0.0))) (setq pt3 (mapcar '+ pt (list (- 2.5) 0.0 0.0))) (command "dim" "Ver" pt pt2 pt3 "" "exit") (repeat (- rows 1) (setq pt1 pt2) (setq pt2 (mapcar '+ pt1 (list 0.0 d2 0.0))) (command "dim" "Ver" pt1 pt2 pt3 "" "exit") ) (setq pt1 pt2) (setq pt2 (mapcar '+ pt1 (list 0.0 voff 0.0))) (command "dim" "Ver" pt1 pt2 pt3 "" "exit") (if (= ang 0.0) (princ) (progn (setq ss (ssget "CP" (list pt (mapcar '+ pt (list len ht 0.0))))) (setvar 'aunits 1) (command "rotate" ss "" pt ang) ) ) (setvar 'osmode oldsnap) (princ) ) (c:recholes)

How are your abilities with LISP or programming? If we give you hint of what to do would that be enough for you to make a start? For the circle numbers, what is the logic behind their numbering in each rectangle? Rectangles - I assume are closed polylines, but will the drawing have any other 4 sided closed polylines that are not to be assessed? Perhaps upload a sample drawing if you can? How often will you be doing this? (daily, weekly, monthly, once a year) If it was me I'd go back a few steps and have the user to select the circles in the order they want them numbered and put in the text from there - much easier to program

Create solid objects that can be subtracted from the full solid of the terrain. Start by creating closed polylines for the base of the main building and the garage and extrdue them upwards such that they penetrate the terrain surface. Subtract these solids from the terrain solid. The next goal is to create a solid that defines the void of the tunnel connecting the buildng and the garage. Start by creating two 3dpolys (shown in yellow) and loft a surface between them. Do the same for the two green 3dpolys. This wil yield surfaces for the ceiling and floor of the tunnel. Create a single closed 3dpoly for the floor of the tunnel (yellow lines but conected at their ends) and extrude it upwards. Use surfsculpt to create a solid for the tunnel from these surfaces that define a watertight volume.

In newer versions since AutoCAD 2016, the DIM command can already do this. What do you need that is not in this feature?

After creating the surface with loft create a box that extends above and below the surface and with sides that are within or flush with the surface. Explode the box and delete the top surface. Now use surfsculpt with the remaining 5 sides of the box plus the surface. If the bondary is not a rectangle, create a closed polyline and extrude it then explode etc.

If you look at Vlax-get obj 'area it will return an area so you can compare that answer is it within tolerance for the new object just added. yes you must use a iterative approach, either using a small offset repeatedly till you get to the desired result may use a seed starting value. Then just keep adding to offset value, it can be slow. An alternative method is to jump to halves, you purposely oversize the offset 1st guess, check is equal then jump to a 1/2 way of 1/2 way value if smaller jump to new 1/2 way + 1/2 way of old outside value, hopefully this makes sense see diagram. You are resetting offset step value each time by 1/2. When used as a search a sorted values say 10,000 it takes 13 goes to find the item your looking for, that is fast. How much do you know about lisp ? Something to have a play with. I have set a limit so stops endless loop. (defun c:wow ( / area% oldsnap obj area1 area2 x) (setq oldsnap (getvar 'osmode)) (setvar 'osmode 0) (setvar 'cmdecho 0) (setq plent (car (entsel "\nPick object "))) (setq obj (vlax-ename->vla-object plent )) (setq area1 (vlax-get obj 'area)) (setq area% (* area1 (+ 1.0 (/ (getreal "\nEnter % ") 100.)))) (setq off 0.0 step 0.0001 x 1) (repeat 3000 (vla-offset obj (setq off (+ off step))) (setq area2 (vlax-get (vlax-ename->vla-object (entlast)) 'area)) (princ (setq x (1+ x))) (if (equal area2 area% 0.01) (progn (alert (strcat "\nArea found " (rtos area% 2 3) " " (rtos area2 2 3) ))(exit)) ) (vla-delete (vlax-ename->vla-object (entlast))) ) (setvar 'osmode oldsnap) (if (> x 3000) (alert "solution not found ")) (princ) ) (c:wow)

Try "Net" hatch pattern trying to remember its spacing, create it at 1 scale then look at squares and change hatch pattern scale, as a default if you use acadiso.pat I think scale 1 is 0.25 spacing. We used to change net to 1x1 so made squares that matched scale.

This worked perfectly. Thank you for the assist

Give this a try:

Yes it does! Thanks for your help! Updated lisp: (defun c:wow ( / lst obj x str) (setq lst '()) (while (setq ent (nentsel "\nPick a attribute Enter to stop ")) (setq obj (vlax-ename->vla-object (car ent))) (setq lst (cons (vlax-invoke-method (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))) 'GetObjectIdString obj :vlax-false) lst )) ) (setq lst (reverse lst)) (setq x -1 ) (setq str (strcat "%<\\AcObjProp Object(%<\\_ObjId " (nth (setq x (1+ x)) lst) ">%).Textstring>%")) (if (> (length lst) 1) (repeat (- (length lst) 1) (setq str (strcat str "," "%<\\AcObjProp Object(%<\\_ObjId " (nth (setq x (1+ x)) lst) ">%).Textstring>%")) ) ) (setq obj (vlax-ename->vla-object (car (entsel "\nPick dimension ")))) (vlax-put obj 'textoverride str) (command "regen") (princ) ) (c:wow)

See if these work for you... SuperBoundary • The superior boundary creation tool - Programs and Scripts - AutoCAD Forums TotalBoundary • Outline creation tool - Programs and Scripts - AutoCAD Forums

Both code above amended seems to work now.

Welcome to CadTutor! Maybe add fuzz factor to equal function or round off numbers. What you see is not always what you get. Autocad may show so many digits (for efficiency purposes / smaller files) , under the hood it probably uses more for calculations. Its like PI , you learn its 3.14 but you know the list goes on. So use something like (equal min1y -max2y 0.0001) or whatever fuzz makes you happy.

You're a lifesaver! Thank you so much for creating this. It's been a long time coming. Hit me up if you're ever in Thailand, I owe you a coffee. I'm sure this will be a big help to many.

Yes, but I would recommend a separate routine for it: (defun c:TextCol (/ c cl e i l o ss x) (vl-load-com) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) (if (and (setq ss (ssget '((0 . "*TEXT")))) (setq cl 5 cl (acad_colordlg cl T)) ) (repeat (setq i (sslength ss)) (setq e (ssname ss (setq i (1- i))) l (entget e) o (vlax-ename->vla-object e) x (vla-get-textstring o) c (vla-get-truecolor o) ) (vla-put-colorindex c cl) (vla-put-truecolor o c) (if (= (cdr (assoc 0 l)) "MTEXT") (progn (while (wcmatch x "*\\C*;*") (setq n 0) (repeat 257 (setq x (vl-string-subst "" (strcat "\\C" (itoa n) ";") x) n (1+ n) ) ) ) (vla-put-textstring o x) ) ) ) ) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) (princ) )

Another quick one for fun. It defaults to a nearest snap. (defun c:foo (/ fz lyr p1 p2 s) ;; Adjust this value for your needs (setq fz 0.1) (while (and (or p1 (setq p1 (getpoint "\nSpecify start point: "))) (setq p2 (getpoint p1 "\nSpecify next point: ")) ) (and (not lyr) (setq s (ssget "_C" (mapcar '- p1 (list fz fz fz)) (mapcar '+ p1 (list fz fz fz)) '((0 . "LINE"))) ) ;; Take this line out if you don't want to use closest to snap (setq p1 (vlax-curve-getclosestpointto (ssname s 0) p1)) (setq lyr (assoc 8 (entget (ssname s 0)))) ) (if lyr (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) lyr)) (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2))) ) (setq p1 p2) ) (princ) )

Edit: Wasn't working.... See what you are doing pkenewell, but the colour codes might need to remove the paired { } - could be a situation where formats overlap (colour, underline, italic.... ) which for a dimension, leader etc is a slim chance from a draughtsman who maybe should be shot, but still a slim chance. The wrong closing } will close the wrong format. 'Wasn't working' was a modified Lee Mac Un-format for just the colour codes but the paired { } wasn't quite working right, Could do a modified StripMText to take out the interface and just colours.. but a lot more code in there Edit again... for reference.... might just work... and the irony of reference - I have lost the reference where I got this from. (defun c:NoColMT ( / ) ; No Colour MText (NoForMT (strcase (getstring "\nEnter Code (C, T, H, W, Q)"))) (princ) ) (defun NoForMt ( MyCode / MyEnt ed MyString SwapSlashes StrPos ColonPos ColourCode) ; C, T, H, W, Q ;;Slight discrepancy, opening '{' is retained at first formatting point (setq MyEnt (car (entsel))) ;;Select single text entity (setq ed (entget MyEnt)) ;;Entity Definition (setq MyString (cdr (assoc 1 ed))) ;;Extract Text (setq SwapSlashes "ADDINGINBLACKSLASH") (while (wcmatch MyString "*\\\\*" )(setq MyString (vl-string-subst SwapSlashes "\\\\" MyString) )) ;;hide \\\\ (if (and (wcmatch MyString (strcat "*{*`\\" MyCode "*}*")) (= (cdr (assoc 0 ed)) "MTEXT") ) (progn (while (wcmatch MyString (strcat "*{*`\\" MyCode "*}*")) (setq StrPos (vl-string-search (strcat "\\" MyCode) MyString ) ) (setq ColonPos (+ (vl-string-search ";" MyString (+ StrPos 3)) 2)) (setq ColourCode (substr MyString (+ StrPos 1) (- ColonPos (+ StrPos 1)) ) ) (setq MyString (vl-string-subst "" ColourCode MyString) ) ) ; end while (setq ed (subst (cons 1 MyString) (assoc 1 ed) ed )) ;; text String <~250 characters (entmod ed) ;; Modify & update entity ) ; end progn ) ; end if (while (wcmatch MyString (strcat "*" SwapSlashes "*") )(setq MyString (vl-string-subst "\\\\" SwapSlashes MyString) )) )

@StevJ, it's sort of beyond the scope of this program. I wrote it to learn how to make programs with DCLs' more or less but has been very useful today at work. You can change the height of that programs UI too. Open the lisp and search for the height property for that listbox I'd say and change that to your needs. The DCL code is hardcoded into the .lsp file with that one. Something I didn't bother to do with this. (Lazy). I've fixed the issue of the blocks and layers not getting selected or highlighted with the help from @pkenewell for that, see post here. Attached is the fixed version. REVISION HISTORY: 2024.11.17 - v1.0 - First release 2024.11.19 - v1.01 - Layers and blocks can now be renamed without the loss of highlighting or selection issues present in the previous version. Thanks pkenewell on CAD Tutors. - Better handling of the buttons in the UI. Disabling / enabling / focusing them where required. 3dwannab_Rename_Blocks_and_Layers.lsp 3dwannab_Rename_Blocks_and_Layers.dcl

@3dwannab Very nice! Didn't know that the dynamic prompts caused that problem. Learn something new every day!

OK, here is one more try at this. Make a selection of all the lines you want whether they form a part of an arc or not. It -should- loop through it all and convert any it considers to be arcs into arcs. The calculation works matching the origin of a circle on formed on points of adjacent lines. If the origins are out by too much then they won't make an arc. Adjacent lines are found from an area round the end of the last one, however if there are very short lines this currently makes an error, and similarly a small gap between adjacent lines also has an error (I think I know the fix for these), But in a nice drawing this works well. In the example drawings above some of the more complex shapes have very short lines (like almost zero length) and very small gaps - I've put a small function in there to choose an adjacent line which fixes a couple of these but if not it zooms to the problem area - you'll see what I mean. Works better than what I had before Command: Lines2Arc ;;Errors on very short gaps ;;Check fuzz factors for small lines ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun LM:ss-union ( lst / out ss i a b) (setq lst (vl-sort lst '(lambda ( a b ) (> (sslength a) (sslength b)))) ) (setq out (car lst) ) (foreach ss (cdr lst) (repeat (setq i (sslength ss)) (ssadd (ssname ss (setq i (1- i))) out) ) ) out ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun linelength ( AnEnt Fuzz / Result Pt1 Pt2) (setq Pt1 (cdr (assoc 10 (entget AnEnt)))) (setq Pt2 (cdr (assoc 11 (entget AnEnt)))) (setq Result (distance Pt1 Pt2)) (if (< Result Fuzz)(setq Result 0)) Result ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun onlyunique ( MyList / ReturnList n ) (setq ReturnList (list)) ; blank list for result (foreach n MyList ; loop through supplied list (if ( = (member n (cdr (member n MyList))) nil) ; if list item occurs only once (setq ReturnList (append ReturnList (list n))) ; add to list ) ) ; end foreach ReturnList ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun uniquepoints ( MySS / MyList acount MyEnt) (princ "Select Lines") (setq MyList (list)) ; Blank list for line coordinates (setq acount 0) (while (< acount (sslength MySS)) ; loop each line (setq MyEnt (entget (ssname MySS acount))) (setq MyList (append MyList (list (cdr (assoc 10 MyEnt))))) ; add end A to list (setq MyList (append MyList (list (cdr (assoc 11 MyEnt))))) ; add end B to list (setq acount (+ acount 1)) ) (list (onlyunique MyList) MyList) ; list: Unique Items, All Items ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun 3parc ( pt1 pt2 pt3 / ocs lst ) ; Lee Mac (if (setq ocs (trans '(0 0 1) 1 0 t)) (if (setq lst (LM:3pcircle pt1 pt2 pt3)) (progn (if (minusp (sin (- (angle pt1 pt3) (angle pt1 pt2)))) (mapcar 'set '(pt1 pt3) (list pt3 pt1)) ) (entmakex (list '(000 . "ARC") (cons 010 (trans (car lst) 1 ocs)) (cons 040 (cadr lst)) (cons 050 (angle (trans (car lst) 1 ocs) (trans pt1 1 ocs))) (cons 051 (angle (trans (car lst) 1 ocs) (trans pt3 1 ocs))) (cons 210 ocs) ) ) ) (princ "\nPoints are collinear.") ) ) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun BndBx ( EntName AnArea / mn mx) ; Line bounding box, for ssget (vla-getboundingbox (vlax-ename->vla-object EntName) 'mn 'mx) (setq mn (mapcar '+ (list (* -1 AnArea) (* -1 AnArea) 0) (vlax-safearray->list mn))) (setq mx (mapcar '+ (list (* 1 AnArea) (* 1 AnArea) 0) (vlax-safearray->list mx))) (list mn mx) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun LM:3pcircle ( pt1 pt2 pt3 / cen md1 md2 vc1 vc2 ) (if (setq md1 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) pt1 pt2) md2 (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) pt2 pt3) vc1 (mapcar '- pt2 pt1) vc2 (mapcar '- pt3 pt2) cen (inters md1 (mapcar '+ md1 (list (- (cadr vc1)) (car vc1) 0)) md2 (mapcar '+ md2 (list (- (cadr vc2)) (car vc2) 0)) nil ) ) (list cen (distance cen pt1)) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun AdjLines ( MyEnt / FF TheLines Pt1 Pt2 currentzoom No_Mutt Pt1A Pt1B AdjSS DelLines AdjCount NewSel ) ;;Set up (setq FF 0.0001) ; Fuzz Factor (setq TheLines (ssadd)) ; List of connecting lines (setq Pt1 (cdr (assoc 10 (entget MyEnt)))) ; End A point (setq Pt2 (cdr (assoc 11 (entget MyEnt)))) ; End B point ;; Zoom to line (setq currentzoom (list (getvar 'viewctr) (getvar 'viewsize))) ; Current Zoom (setq No_Mutt (getvar 'nomutt))(setvar 'NoMutt 1) ; do it quietly (vla-ZoomWindow (vlax-get-acad-object) ; Zoom to line bounding box +/- (vlax-3D-point (car (BNDBX MyEnt (* (linelength MyEnt 0) 0.25)))) (vlax-3D-point (cadr (BNDBX MyEnt (* (linelength MyEnt 0) 0.25)))) ) (setvar 'nomutt No_Mutt) ;; Assess each end (repeat 2 (setq Pt1A (mapcar '+ (list (* FF -1) (* FF -1)) Pt1)) ; Small area around end of line (setq Pt1B (mapcar '+ (list (* FF 1) (* FF 1)) Pt1)) (setq AdjSS (ssget "_C" Pt1A Pt1B '((0 . "LINE"))) ) ; select adjacent lines (setq DelLines (ssadd MyEnt)) ; Selection set to exclude some lines ;;Find if any line is very short (setq AdjCount 0) (while (< AdjCount (sslength AdjSS)) (if (= (linelength (ssname Adjss AdjCount) 0.0001) 0) (setq DelLines (ssadd (ssname Adjss AdjCount) DelLines)) ) (setq AdjCount (+ AdjCount 1)) ) ; end while ;;Delete these lines (setq AdjCount 0) (while (< AdjCount (sslength DelLines)) (setq AdjSS (ssdel (ssname DelLines AdjCount) AdjSS)) (setq AdjCount (+ AdjCount 1)) ) ; end while ;;Number of intersections (cond ((= (sslength AdjSS) 0) ; Found one adjacent intersection point (progn ) ) ; end cond ((= (sslength AdjSS) 1) ; Found one adjacent intersection point (setq TheLines (ssadd (ssname AdjSS 0) TheLines)) ) ; end cond (t ; All others (vla-ZoomWindow (vlax-get-acad-object) (vlax-3D-point (mapcar '+ (list (* -1 (distance Pt1 Pt2)) (* -1 (distance Pt1 Pt2))) Pt1) ) (vlax-3D-point (mapcar '+ (list (* 1 (distance Pt1 Pt2)) (* 1 (distance Pt1 Pt2))) Pt1) ) ) (princ "\nToo many line connections, Select a line") (redraw MyEnt 3) (setq NewSel (car (entsel))) ;;Error check this is a line (redraw MyEnt 4) (setq TheLines (ssadd NewSel TheLines)) ) ) ; end conds (setq Pt1A Pt2)(setq Pt2 Pt1)(setq Pt1 Pt1A) ; swap ends ) ; end repeat (setq No_Mutt (getvar 'nomutt))(setvar 'NoMutt 1) (vla-ZoomCenter (vlax-get-acad-object) (vlax-3d-point (car currentzoom)) (cadr currentzoom)) (setvar 'nomutt No_Mutt) TheLines ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun Int ( Ent1 Ent2 / Pt1A Pt1B Pt2A Pt2B PtC MyInt MyRadius ) ; Get intersection (setq Pt1A (cdr (assoc 10 (entget Ent1)))) ; End A point (setq Pt1B (cdr (assoc 11 (entget Ent1)))) ; End B point (setq Pt2A (cdr (assoc 10 (entget Ent2)))) ; End A point (setq Pt2B (cdr (assoc 11 (entget Ent2)))) ; End B point (if (equal Pt1A Pt2A 0.0001)(setq PtC Pt2B)) ; points not shared (if (equal Pt1B Pt2A 0.0001)(setq PtC Pt2B)) (if (equal Pt1A Pt2B 0.0001)(setq PtC Pt2A)) (if (equal Pt1B Pt2B 0.0001)(setq PtC Pt2A)) (setq MyInt (car (LM:3pcircle Pt1A Pt1B PtC)) ) ;;Intersection (setq MyRadius (cadr (LM:3pcircle Pt1A Pt1B PtC)) ) ;;Radius MyInt ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun trythis ( MyEnt AssessedLines ConnectedLines Int1 / p1 p2 TempLines acount AssessedLines Int1 Int2 ConnectedLines TryThisResult result) (setq p1 (cdr (assoc 10 (entget MyEnt)))) (setq p2 (cdr (assoc 11 (entget MyEnt)))) (if (= (linelength MyEnt 0.0001) 0) (princ " Short Line. ") (progn (repeat 2 (setq TempLines (AdjLines MyEnt)) ; returns up to 2 entities ;; Remove from list duplicated in AssessedLines (setq acount (sslength TempLines)) (while (> acount 0) (if (= (ssmemb (ssname TempLines (- acount 1) ) AssessedLines) nil) (progn ) (progn (setq TempLines (ssdel (ssmemb (ssname TempLines (- acount 1)) AssessedLines) TempLines)) ); end progn ) ; end if (setq acount (- acount 1)) ) ; end while (if (= (sslength TempLines) 0) (progn ; temp lines all assessed. ) (progn (setq AssessedLines (ssadd (ssname TempLines 0) AssessedLines)) ; add to assessed lines (if (= Int1 nil) (setq Int1 (Int MyEnt (ssname TempLines 0))) ) (setq Int2 (Int MyEnt (ssname TempLines 0))) (if (< (distance Int1 Int2) 1) (progn (setq ConnectedLines (ssadd (ssname TempLines 0) ConnectedLines)) ; add to Connected lines (setq TryThisResult (trythis (ssname TempLines 0) AssessedLines ConnectedLines Int1)) (setq AssessedLines (car TryThisResult)) (setq ConnectedLines (cadr TryThisResult)) (setq Int1 (caddr TryThisResult)) ) ; end progn ) ) ; End progn ) ; end if ) ; end repeat 2 ) ; end progn ) ; end if short MyEnt (setq result (list AssessedLines ConnectedLines Int1)) result ) ; end defun ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun c:Lines2Arc ( / ArcSS ArcLines ArcSSCount thisdrawing AnEnt AssessedLines Int1 ConnectedLines TryThisResult MyList P1 p1 p2 p3 counter acount) (setq ArcSS (ssget '((0 . "LINE")))) ; Selection Set (setq ArcLines (ssadd)) ; Selection Set for lines contained in an arc (setq ArcSSCount 0) ; A counter (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark thisdrawing) ; Start Undo (while (< ArcSSCount (sslength ArcSS)) ; while loop (setq AnEnt (ssname ArcSS ArcSSCount)); Next entity in loop (if (= AssessedLines nil)(setq AssessedLines (ssadd))) ; create selection set (if (= (linelength AnEnt 0.0001) 0) ; If the line is very short, ignore, move on (progn ) (progn ;;Reset for next entity (setq Int1 nil) (setq ConnectedLines nil) (setq ConnectedLines (ssadd AnEnt)) ; List for connected lines (if (or (ssmemb AnEnt ArcLines) ; If entity is in an arc.... (ssmemb AnEnt AssessedLines) ) ; Endor (progn ; do nothing ) (progn (setq TryThisResult (trythis AnEnt AssessedLines ConnectedLines Int1)) (setq ConnectedLines (cadr TryThisResult)) (setq Int1 (caddr TryThisResult)) (if (or (= ConnectedLines nil) (> 4 (sslength ConnectedLines)) ; If more than 3 entities its an arc. ) ; end or (progn ; not an arc ) (progn (setq MyList (uniquepoints ConnectedLines)) ; car: unique points, cadr: points list (setq ArcLines (LM:ss-union (list ArcLines ConnectedLines))) ; add entities to ignore list (if (= (car MyList) nil) (progn (princ "Full Circle") (setq P1 (car (cadr MyList)) ) (command "circle" Int1 P1) ) ; end progn (progn (setq p1 (car (car MyList))) ; first unique point (setq p2 (nth (/ (length (cadr MyList)) 2) (cadr MyList))) ; point within the arc (setq p3 (cadr (car MyList))) ; second unique point (setq counter 0) (while (< counter (sslength ConnectedLines)) (redraw (ssname ConnectedLines counter) 3) (setq counter (+ counter 1)) ) (command "delay" 50) (setq counter 0) (while (< counter (sslength ConnectedLines)) (redraw (ssname ConnectedLines counter) 4) (setq counter (+ counter 1)) ) (3parc p1 p2 p3) ; draw arc ) ; end progn ) ; end if full circle ) ; end progn ) ; end if arc returned ) ; end progn ) ; end if entity in an arc ) ;; end progn ) ; end while short line (setq AssessedLines (ssadd AnEnt AssessedLines)) ; List of all lines assessed (setq ArcSSCount (+ ArcSSCount 1) ) ; Increase count ) ; end while (setq acount 0) (repeat (sslength ArcLines) ; delete arc lines. Use entdel to keep command line quiet (entdel (ssname ArcLines acount)) (setq acount (+ acount 1)) ) (vla-endundomark thisdrawing) ; end undo (princ) ) - Edit 05/03/24- Updated to account for very short lines (in the order of 0.0005) - if the drawing contains short lines this length it will still complain.

Wrote it, so might as well post it: (defun c:mtt ( / *error* _StartUndo _EndUndo _GetTextInsertion _PutTextInsertion Props doc entity object ss ) (vl-load-com) ;; © Lee Mac 2010 (setq Props '( Alignment AttachmentPoint BackgroundFill Backward DrawingDirection Height Layer LineSpacingDistance LineSpacingFactor LineSpacingStyle Linetype LinetypeScale Lineweight ObliqueAngle Rotation ScaleFactor StyleName TextString Thickness UpsideDown Width ) ) (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (defun *error* ( msg ) (if doc (_EndUndo doc)) (if mutt (setvar 'NOMUTT mutt)) (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **"))) (princ) ) (defun _StartUndo ( doc ) (_EndUndo doc) (vla-StartUndoMark doc) ) (defun _EndUndo ( doc ) (if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-EndUndoMark doc) ) ) (defun _GetTextInsertion ( object ) (vlax-get-property object (if (or (eq "AcDbMText" (vla-get-ObjectName object)) (vl-position (vla-get-Alignment object) (list acAlignmentLeft acAlignmentFit acAlignmentAligned)) ) 'InsertionPoint 'TextAlignmentPoint ) ) ) (defun _PutTextInsertion ( object point ) (vlax-put-property object (if (or (eq "AcDbMText" (vla-get-ObjectName object)) (vl-position (vla-get-Alignment object) (list acAlignmentLeft acAlignmentFit acAlignmentAligned)) ) 'InsertionPoint 'TextAlignmentPoint ) point ) ) (if (and (setq entity (LM:Selectif (lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "TEXT,MTEXT,ATTRIB,ATTDEF") ) nentsel "\nSelect Source Object: " ) ) (progn (setq mutt (getvar 'NOMUTT)) (setvar 'NOMUTT 1) (princ (strcat "\nSelect Destination " (cdr (assoc 0 (entget entity))) " objects: ")) (setq object (vlax-ename->vla-object entity) ss (ssget "_:L" (list (assoc 0 (entget entity)) ) ) ) (setvar 'NOMUTT mutt) ss ) ) ( (lambda ( i values / entity obj ) (_StartUndo doc) (while (setq entity (ssname ss (setq i (1+ i)))) (setq obj (vlax-ename->vla-object entity)) (mapcar (function (lambda ( prop value / err ) (if (vl-catch-all-error-p (setq err (vl-catch-all-apply (function (lambda nil (if (and (vlax-property-available-p obj prop t) value) (if (vl-position prop '(Alignment AttachmentPoint)) ( (lambda ( insertion ) (vlax-put-property obj prop value) (_PutTextInsertion obj insertion) ) (_GetTextInsertion obj) ) (vlax-put-property obj prop value) ) ) ) ) ) ) ) (princ (strcat "\n** Error Applying Property: " (vl-princ-to-string Prop) ": " (vl-catch-all-error-message err) " **" ) ) ) ) ) Props Values ) ) (_EndUndo doc) ) -1 (mapcar (function (lambda ( prop ) (if (vlax-property-available-p object prop) (vlax-get-property object prop) ) ) ) Props ) ) ) (princ) ) ;;---------------------=={ Select if }==----------------------;; ;; ;; ;; Continuous selection prompts until the predicate function ;; ;; foo is validated ;; ;;------------------------------------------------------------;; ;; Author: Lee McDonnell, 2010 ;; ;; ;; ;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;; ;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; foo - optional predicate function taking ename argument ;; ;; fun - selection function to invoke ;; ;; str - prompt string ;; ;;------------------------------------------------------------;; ;; Returns: selected entity ename if successful, else nil ;; ;;------------------------------------------------------------;; (defun LM:Selectif ( foo fun str / e ) ;; © Lee Mac 2010 (while (progn (setq e (car (fun str))) (cond ( (eq 'ENAME (type e)) (if (and foo (not (foo e))) (princ "\n** Invalid Object Selected **")) ) ) ) ) e ) Check/Edit list of properties at the top of the code to match Lee

Here, I did this as an example, so you can follow suite from it. (defun c:PF (/ pt eLast ent) ;; Alan J. Thompson, 07.21.10 (setvar 'filletrad (cond ((getdist (strcat "\nSpecify fillet radius <" (rtos (getvar 'filletrad)) ">: "))) ((getvar 'filletrad)) ) ) (if (setq pt (getpoint "\nSpecify start point: ")) (progn (setq eLast (entlast)) (command "_.pline" "_non" pt) (while (= 1 (logand (getvar 'cmdactive) 1)) (princ "\nSpecify next point: ") (command PAUSE) ) (or (equal eLast (setq ent (entlast))) (command "_.fillet" "_P" ent) ) ) ) (princ) )