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

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.

; slope - 2024.05.28 exceed (defun c:SLOPE ( / acdoc mspace fuzz ssp sspl i ptlist ent entlist pt ss ssl obj coordlist coordlistlen p1 p2 xydist midpt parameter totallen midlen j p1z p2z flag1 flag2 pt2 sloperatio slopeblock blkang slopetextpt slopetext lengthtextpt lengthtext midparam prevparam nextparam) (setq acdoc (vla-get-activedocument (vlax-get-acad-object))) (setq mspace (vla-get-modelspace acdoc)) (setq fuzz 0.005) (setq ssp (ssget "X" '((0 . "POINT")))) (setq sspl (sslength ssp)) (setq i 0) (setq ptlist '()) (repeat sspl (setq ent (ssname ssp i)) (setq entlist (entget ent)) (setq pt (cdr (assoc 10 entlist))) (setq ptlist (cons pt ptlist)) (setq i (+ i 1)) ) ;(princ "\n pt list - ") ;(princ ptlist) (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "-Polyline-")))) (setq ssl (sslength ss)) (setq i 0) (repeat ssl (setq ent (ssname ss i)) (setq obj (vlax-ename->vla-object ent)) (setq coordlist (vlax-safearray->list (vlax-variant-value (vlax-get-property obj 'coordinates)))) (setq coordlistlen (length coordlist)) (setq p1 (list (car coordlist) (cadr coordlist) 0)) (setq p2 (list (nth (- coordlistlen 2) coordlist) (nth (- coordlistlen 1) coordlist) 0)) (setq xydist (distance p1 p2)) (setq midpt '()) (setq param (vlax-curve-getEndParam obj)) (setq totallen (vlax-curve-getDistAtParam obj param)) (setq midlen (* 0.5 totallen)) (setq midpt (vlax-curve-getPointAtDist obj midlen)) ;(setq midparam (vlax-curve-getParamAtPoint obj (vlax-curve-getClosestPointTo obj midpt))) ;(setq prevparam (vlax-curve-getPointAtParam obj (fix midparam))) (setq prevparam (vlax-curve-getpointatdist obj (* 0.499999 totallen))) ;(setq nextparam (vlax-curve-getPointAtParam obj (+ (fix midparam) 1))) (setq nextparam (vlax-curve-getpointatdist obj (* 0.500001 totallen))) ;(princ midpt) (setq j 0) (setq p1z 0) (setq p2z 0) (setq flag1 0) (setq flag2 0) (repeat sspl (setq pt2 (nth j ptlist)) (if (and (and (< (- (car p1) fuzz) (car pt2)) (< (car pt2) (+ (car p1) fuzz))) (and (< (- (car p1) fuzz) (car pt2)) (< (cadr pt2) (+ (cadr p1) fuzz))) (= flag1 0) ) (progn (setq p1z (caddr pt2)) ;(princ "\n p1z = ") ;(princ p1z) (setq flag1 1) ) ) (if (and (and (< (- (car p2) fuzz) (car pt2)) (< (car pt2) (+ (car p2) fuzz))) (and (< (- (car p2) fuzz) (car pt2)) (< (cadr pt2) (+ (cadr p2) fuzz))) (= flag2 0) (= flag1 1) ) (progn (setq p2z (caddr pt2)) ;(princ "\n p2z = ") ;(princ p2z) (setq flag2 1) ) ) (setq j (+ j 1)) ) (if (and (= flag1 1) (= flag2 1)) (progn (setq p1 (list (car p1) (cadr p1) p1z)) (setq p2 (list (car p2) (cadr p2) p2z)) (setq sloperatio (* 100 (/ (abs (- p1z p2z)) xydist))) ;(setq midpt (list (/ (+ (car p1) (car p2)) 2) (/ (+ (cadr p1) (cadr p2)) 2) (/ (+ (caddr p1) (caddr p2)) 2))) (if (> p1z p2z) ;(setq blkang (angle p1 p2)) (setq blkang (angle prevparam nextparam)) ;(setq blkang (angle p2 p1)) (setq blkang (angle nextparam prevparam)) ) ;(princ "\n sloperatio - ") ;(princ sloperatio) ;(princ "%") (setq slopeblock (vla-InsertBlock mspace (vlax-3d-point midpt) "-Slope-" 5 5 5 blkang)) (cond ((and (<= 0 blkang) (< blkang (/ pi 2))) ;(princ "a") ) ((and (<= (/ pi 2) blkang) (< blkang pi)) ;(princ "b") (setq blkang (- blkang pi)) ) ((and (<= pi blkang) (< blkang (* 1.5 pi))) ;(princ "c") (setq blkang (- blkang pi)) ) ((and (<= (* 1.5 pi) blkang) (< blkang pi)) ;(princ "d") ) ) (setq slopetextpt (polar midpt (+ blkang (* 0.5 pi)) 5)) (setq slopetext (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 "-Label Between Geometry Points") (cons 67 0) (cons 100 "AcDbText") (cons 10 slopetextpt) (cons 11 slopetextpt) (cons 40 5) (cons 1 (strcat (rtos sloperatio 2 2) "%")) (cons 50 blkang) (cons 41 1) (cons 51 0) (cons 7 "Standard") (cons 71 0) (cons 72 1) (cons 100 "AcDbText") (cons 73 0) ) ) ) (setq lengthtextpt (polar midpt (- blkang (* 0.5 pi)) 10)) (setq lengthtext (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 "-Label Between Geometry Points") (cons 67 0) (cons 62 7) (cons 100 "AcDbText") (cons 10 lengthtextpt) (cons 11 lengthtextpt) (cons 40 5) (cons 1 (strcat (rtos xydist 2 2) "m")) (cons 50 blkang) (cons 41 1) (cons 51 0) (cons 7 "-Elevation-") (cons 71 0) (cons 72 1) (cons 100 "AcDbText") (cons 73 0) ) ) ) ) (progn ;(princ "\n there's no elevation point for this polyline") ) ) (setq i (+ i 1)) ) (princ) ) If the polyline bends sharply, the angle of the arrow and text may be strange. p.s - Is it correct to use the horizontal length rather than the inclined length? edit - angle problem in the gif has been corrected some

Here's my take on it: (defun c:foo (/ lm:unformat b el p r s sp tx) (cond ((setq s (ssget ":L" '((0 . "CIRCLE")))) (cond ((null (tblobjname "block" "Bubble")) (entmake '((0 . "BLOCK") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockReference") (66 . 1) (2 . "Bubble") (10 0. 0. 0.) (70 . 2) ) ) (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbCircle") (10 0. 0. 0.) (40 . 1.) ) ) (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbText") (10 0. 0. 0.) (40 . 0.75) (1 . "") (50 . 0) (41 . 1) (51 . 0) (7 . "Standard") (71 . 0) (72 . 1) (11 0. 0. 0.) (100 . "AcDbAttributeDefinition") (280 . 0) (3 . "") (2 . "#") (70 . 8) (73 . 0) (74 . 2) (280 . 1) ) ) (entmake '((0 . "ENDBLK") (100 . "AcDbBlockEnd") (8 . "0"))) ) (command "_.ATTSYNC" "_NAME" "BUBBLE") ) ;;-------------------=={ UnFormat String }==------------------;; ;; ;; ;; Returns a string with all MText formatting codes removed. ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; str - String to Process ;; ;; mtx - MText Flag (T if string is for use in MText) ;; ;;------------------------------------------------------------;; ;; Returns: String with formatting codes removed ;; ;;------------------------------------------------------------;; (defun lm:unformat (str mtx / _replace rx) (defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new) ) (if (setq rx (vlax-get-or-create-object "VBScript.RegExp")) (progn (setq str (vl-catch-all-apply (function (lambda () (vlax-put-property rx 'global actrue) (vlax-put-property rx 'multiline actrue) (vlax-put-property rx 'ignorecase acfalse) (foreach pair '(("\032" . "\\\\\\\\") (" " . "\\\\P|\\n|\\t") ("$1" . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]" ) ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);") ("$1$2" . "\\\\(\\\\S)|[\\\\](})|}") ("$1" . "[\\\\]({)|{") ) (setq str (_replace (car pair) (cdr pair) str)) ) (if mtx (_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str) ) (_replace "\\" "\032" str) ) ) ) ) ) (vlax-release-object rx) (if (null (vl-catch-all-error-p str)) str ) ) ) ) (setq sp (vlax-ename->vla-object (cdr (assoc 330 (entget (ssname s 0)))))) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) (setq r (/ (cdr (assoc 40 (setq el (entget e)))) 2.)) (setq p (cdr (assoc 10 el))) (cond ((setq tx (ssget "_C" (mapcar '- p (list r r r)) (mapcar '+ p (list r r r)) '((0 . "*TEXT"))) ) (setq r (* 2 r)) (setq b (vla-insertblock sp (vlax-3d-point p) "Bubble" r r r 0.)) (vla-put-textstring (car (vlax-invoke b 'getattributes)) (lm:unformat (cdr (assoc 1 (entget (ssname tx 0)))) nil) ) (entmod (append (entget (vlax-vla-object->ename b)) '((8 . "BUBBLE")))) (entdel e) (entdel (ssname tx 0)) ) ) ) ) ) (princ) )

@AirBall With your request :elevations in vertices Try this for convert your lwpolyline to 3Dpoly with 3Dfaces (defun pt_sum_store (pt? pt_lst / count p1 p2 vtx alpha btw_alpha) (setq alpha 0.0 vtx (car pt_lst) count 1 ) (while (< 1 (length pt_lst)) (setq p1 (car pt_lst) p2 (cadr pt_lst) pt_lst (cdr pt_lst) btw_alpha (q_ang pt? p1 p2) btw_alpha (if (< 180.0 btw_alpha) (- btw_alpha 360.0) btw_alpha ) alpha (+ alpha btw_alpha) ) (setq count (1+ count)) ) (setq btw_alpha (q_ang pt? p2 vtx) btw_alpha (if (< 180.0 btw_alpha) (- btw_alpha 360.0) btw_alpha ) ) (+ alpha btw_alpha) ) (defun q_ang (pt? p1 p2 / alpha beta) (setq beta (angle pt? p1) alpha (angle pt? p2) alpha (- alpha beta) ) (if (< alpha 0) (setq alpha (+ (* 2 pi) alpha)) ) (* (/ (float alpha) pi) 180.0) ) (defun pt_in_poly (pt? pt_lst / ) (if (equal 0.0 (pt_sum_store pt? pt_lst) 0.0001) nil T ) ) (vl-load-com) (defun c:lwpolyto3dpoly ( / js AcDoc Space ename obj pr lst_pt ss nb ent dxf_ent l_pt n X1 X2 X3 Y1 Y2 Y3 Z1 Z2 Z3 E1 E2 E3 E4 Z nw_lst-pt nw_obj) (princ "\nSelect polyline.") (while (null (setq js (ssget "_+.:E:S" (list (cons 0 "*POLYLINE") (cons 67 (if (eq (getvar "CVPORT") 1) 1 0)) (cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model")) (cons -4 "<NOT") (cons -4 "&") (cons 70 112) (cons -4 "NOT>") ) ) ) ) ) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) Space (if (= 1 (getvar "CVPORT")) (vla-get-PaperSpace AcDoc) (vla-get-ModelSpace AcDoc) ) ) (setq ename (ssname js 0) obj (vlax-ename->vla-object ename) pr -1 ) (repeat (fix (vlax-curve-getEndParam obj)) (setq pr (1+ pr) lst_pt (cons (vlax-curve-GetPointAtParam obj pr) lst_pt) ) ) (setq lst_pt (cons (vlax-curve-GetPointAtParam obj (1+ pr)) lst_pt)) (setq ss (ssget "_F" lst_pt '((0 . "3DFACE")))) (cond (ss (repeat (setq nb (sslength ss)) (setq ent (ssname ss (setq nb (1- nb))) dxf_ent (entget ent) l_pt (list (cdr (assoc 10 dxf_ent)) (cdr (assoc 11 dxf_ent)) (cdr (assoc 12 dxf_ent)) (cdr (assoc 13 dxf_ent)) ) ) (if (equal (car l_pt) (cadr l_pt)) (setq l_pt (list (list (cadr l_pt) (caddr l_pt) (cadddr l_pt)))) (setq l_pt (cons (list (car l_pt) (cadr l_pt) (caddr l_pt)) (list (list (cadr l_pt) (caddr l_pt) (cadddr l_pt))))) ) (mapcar '(lambda (y / n) (foreach e lst_pt (cond ((pt_in_poly e y) (setq n 0) (foreach item '(("X" . "'car") ("Y" . "'cadr") ("Z" . "'caddr")) (mapcar '(lambda (e) (set (read (strcat (car item) (itoa (setq n (1+ n))))) e)) (mapcar (eval (read (cdr item))) (car l_pt)) ) (setq n 0) ) (setq E1 (+ (* X1 (- Y2 Y3)) (* X2 (- Y3 Y1)) (* X3 (- Y1 Y2))) E2 (+ (* Y1 (- Z2 Z3)) (* Y2 (- Z3 Z1)) (* Y3 (- Z1 Z2))) E3 (+ (* Z1 (- X2 X3)) (* Z2 (- X3 X1)) (* Z3 (- X1 X2))) E4 (- (- (* E2 X1)) (* E3 Y1) (* E1 Z1)) Z (- (- (* (/ E2 E1) (car e))) (* (/ E3 E1) (cadr e)) (/ E4 E1)) nw_lst-pt (cons (trans (list (car e) (cadr e) Z) 1 0) nw_lst-pt) ) ) ) ) ) l_pt ) ) (setq nw_obj (vlax-invoke Space 'Add3dPoly (apply 'append nw_lst-pt ) ) ) (vla-put-Layer nw_obj (vla-get-Layer obj)) (vla-put-Color nw_obj (vla-get-Color obj)) (vla-put-Lineweight nw_obj (vla-get-Lineweight obj)) (vla-delete obj) ) ) (prin1) )

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

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

Only one DIMALIGNED call is required, e.g.: (defun c:mydimalign ( / e p x ) (if (and (setq e (car (entsel))) (= "LWPOLYLINE" (cdr (assoc 0 (setq x (entget e))))) ) (foreach g x (cond ( (/= 10 (car g))) ( p (command "_.dimaligned" p (setq p (cdr g)) "@5<180")) ( (setq p (cdr g))) ) ) ) (princ) )

@pondpepo9 I can't tell you if what you are looking for exists unless you can be more specific on what you want. Ideally, post a DWG with the Before and After and explain in more detail what the workflow should be. Then if someone has something they are willing to share, write, or alter - we can let you know. PLEASE NOTE: This is not a forum just to order up free programs. We prefer helping those who wish to learn programming and need a place to start, which is the purpose of this forum.

2012年的发的文章，时隔13年居然依旧是互联网上延曲线填充唯一的解决方案，谢谢！伟大无需多言。 现在已经是2025年了，应该不用我翻译成英文回帖子了 表达一下感谢

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

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.

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

You can not use that code this will always Fail its not supported in LT2024 25, you can not do a vlax-get-or-create-object (vlax-get-or-create-object "Excel.Application") Ok what will work is to write a csv file. Then read that file into Excel. Not sure if "Shell" function is supported, then can as last line start excel and open the csv. Try this change path and filename to one you have. If you dont have a csv just save one from Excel for test. (startapp "Excel.exe" "D:\\acadtemp\\tags.csv") Let us know if it works.

Hi all, I just wrote my first DCL program. It's a renamer for blocks and layers. It has a block walk function to zoom into the block to be renamed from the selection, and the layers are highlighted when picked in the edit box. The rename dialog in ACAD hasn't been touched since I started using it in 2004 so I think this will help identify and rename Blocks and Layers much better. There is a bug whereby if something has been renamed, the zoom to block or highlighting of objects doesn't work. I'll try to fix the bug when I get some spare time. Fixed in v1.01 below. Thoughts on this and improvements are welcome. 3dwannab_Rename_Blocks_and_Layers.lsp 3dwannab_Rename_Blocks_and_Layers.dcl

Try this (defun c:foo ( / ss e_base pt_base n lst) (princ "\nSelect base point:") (while (null (setq ss (ssget "_+.:E:S" '((0 . "POINT")))))) (setq e_base (ssname ss 0) pt_base (cdr (assoc 10 (entget e_base))) ) (princ "\nSelect points to connect:") (setq ss (ssget '((0 . "POINT")))) (cond (ss (if (ssmemb e_base ss) (ssdel e_base ss)) (repeat (setq n (sslength ss)) (setq lst (cons (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))) lst)) ) (mapcar '(lambda (x) (entmake (list (cons 0 "LINE") (cons 10 pt_base) (cons 11 x) ) ) ) lst ) ) ) (prin1) )

Another coming soon ChristmasTree4.lsp

This should change all block definitions to scale uniformly. (defun c:foo nil (vlax-for b (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (and (= 0 (vlax-get b 'isxref) (vlax-get b 'islayout)) (vl-catch-all-apply 'vla-put-blockscaling (list b acuniform)) ) ) (princ) )

I have plot titles in model but try not to use it. A better way is to make a rectang at the required scale using your A1 sheet, the A1 title block is saved in layouts at 1:1 scale then a mview is used to view the model at desired scale. It is a 2 step process make rectangs then make layouts so you can add more as you go along. This video is step 1, then just select all rectangs which are on a layer and make matching layouts. The code I have takes into account that you may have different orientation, Portrait or Landscape, even down to the rectang can be on an angle and Mview matches. Ok the sample dwg has been screwed with the 6000 is 4so 1st step is rescale back to match 6000 or 6.0 then make a retang at scale. Put title block in layout at 1:1 ie 841x594 - edges. Draw rectangs.mp4 I do charge a small fee as the code needs to be setup to match your title block. I am metric ignore scale in movie. Have a look at this dwg. Drawing1-2.dwg

;;; toggle draw toolbar (defun c:tdtb ( / lst ) (vlax-for mnu (vla-get-menugroups (vlax-get-acad-object)) (vlax-for tlb (vla-get-toolbars mnu) (if (= (vla-get-visible tlb) :vlax-true) (setq lst (cons (vla-get-name tlb) lst))))) (if (member "Draw" lst) (command "-toolbar" "Draw" "Hide") (command "-toolbar" "Draw" "Show") ) )

What I use in my day-to-day work is basically something like this. I'd normally type the right command name in and go about that approach. As Steven pointed out, once the direction is set, most users are happy with it. (Only works in 2D): (defun c:lx nil (CommandDirection (list "_.LINE" pause) ".Y")) (defun c:ly nil (CommandDirection (list "_.LINE" pause) ".X")) (defun c:cx (/ ss) (if (setq ss (ssget "_:L")) (CommandDirection (list "_.COPY" ss "" "_M" pause) ".Y"))) (defun c:cy (/ ss) (if (setq ss (ssget "_:L")) (CommandDirection (list "_.COPY" ss "" "_M" pause) ".X"))) (defun c:mx (/ ss) (if (setq ss (ssget "_:L")) (CommandDirection (list "_MOVE" ss "" pause) ".Y"))) (defun c:my (/ ss) (if (setq ss (ssget "_:L")) (CommandDirection (list "_MOVE" ss "" pause) ".X"))) (defun c:sx (/ ss) (if (setq ss (ssget "_:L")) (CommandDirection (list "_STRETCH" ss "" pause) ".Y"))) (defun c:sy (/ ss) (if (setq ss (ssget "_:L")) (CommandDirection (list "_STRETCH" ss "" pause) ".X"))) ;; Command Direction - Jonathan Handojo ;; Creates a command that constraints point prompts to X, Y or Z axis. ;; cmd - a list of strings to pass into the AutoCAD command function. ;; => The next prompt following the string list supplied must be a point selection. ;; dir - a string of either ".X", ".Y" or ".Z" (defun CommandDirection (cmd dir) (apply 'command cmd) (while (not (zerop (getvar "cmdactive"))) (command dir "_non" "@0,0,0" pause) ) (princ) )

This is taking the above a little further, but is not as finished as I might want. The user can alter the direction before or after selecting the entities rather than selecting the direction and then the entities. I reckon if you are using grread in something similar you are wanting quite a complex solution, most users are happy with 'select an option and enter' to continue. A bit of work to do another time so show the rubber bands for the stretches and to add in object snaps, but I am just adding this in here as an example - I might get more chance to look at this another day. (defun c:GRStretch ( / mod MyDist MyEnt MySS pt1 pt2 pt3 pt4 endloop acount) (setq endloop "No") (setq mod "X") (princ (strcat "Press \"X\" or \"Y\" [" mod "], select entities to stretch, or [ENTER] to exit: ")) (while (and (setq g (grread t 14 2)) (= endloop "No") ) (cond ((= (car g) 2) ;;Set mode - text entry (if (or (= 88 (cadr g))(= 120 (cadr g))) (setq mod "X")) ; x, X (if (or (= 89 (cadr g))(= 121 (cadr g))) (setq mod "Y")) ; y, Y (if (or (= 13 (cadr g))(= 32 (cadr g))) (setq endloop "Yes")) ; end loop marker ;;NUMBER ENTRY (if (and (< 48 (cadr g)) (< (cadr g) 57)) (progn (princ "\n")(princ (chr (cadr g))) (setq MyDist (atof (strcat (chr (cadr g)) (rtos (getreal)))))(princ "\n")(princ MyDist) ) ) ;;END NUMBER ENTRY (princ (strcat "\nPress \"X\" or \"Y\" [" mod "], select entities to stretch, or [ENTER] to exit: ")) ; change of mod ) ; end text entry cond ((= (car g) 3) ;;Set click (cond ; set / reset points ((= pt1 nil)(setq pt1 (cadr g))) ((= pt2 nil)(setq pt2 (cadr g))) ((= pt3 nil)(setq pt3 (cadr g))) ((= pt4 nil)(setq pt4 (cadr g))) ( T (setq pt1 nil)(setq pt2 nil)(setq pt3 nil)(setq pt4 nil)) ; reset points ) (if (setq MyEnt (car (nentselp pt1)) ) ; if single entity selected (progn (redraw MyEnt 3) (setq pt2 pt1) (princ (strcat "\nSingle Entity Selected.\nSpecify base point (or X, Y) [" mod "].")) ) ; end progn ) ; end if (if (and pt1 pt2 (not MyEnt)) (progn (if (< (car Pt1)(car Pt2)) ; L->R Selection (setq MySS (ssget "_W" Pt1 Pt2 )) ; Window selection (setq MySS (ssget "_C" Pt1 Pt2 )) ; crossing selection ) (redraw) (if MySS (progn (setq acount 0) (while (< acount (sslength MySS)) (redraw (ssname MySS acount) 3) (setq acount (+ acount 1)) ) ; end while MySS (princ (strcat "\nEntities Selected.\nSpecify base point (or X, Y) [" mod "].")) ) ; end progn (progn (setq pt1 nil)(setq pt2 nil)(setq pt3 nil)(setq pt4 nil) ) ) ; end if MySS ) ; end progn ) ; end if pt1, pt2, not MyEnt ) ; end click entry cond ((and pt1 (not pt2) (= (car g) 5) (not MyEnt) ) ; Draw selection rectangle (setq p3 (cadr g)) (setq p2 (list (car pt1) (cadr p3))) (setq p4 (list (car p3) (cadr pt1))) (redraw) (grvecs (list -256 pt1 p2 p2 p3 p3 p4 p4 pt1)) ) ) ; end conds ;;Single entity stretch ; (if (and pt2 MyEnt) (if (and pt3 MyEnt) (progn (princ "\nSpecify second point") (if (= mod "X") ; X or Y axis ; (command "_.stretch" MyEnt "" (mapcar '* '(1 0 0) pt2) (mapcar '* '(1 0 0) (setq pt3 (getpoint)))) ; (command "_.stretch" MyEnt "" (mapcar '* '(0 1 0) pt2) (mapcar '* '(0 1 0) (setq pt3 (getpoint)))) (command "_.stretch" MyEnt "" (mapcar '* '(1 0 0) pt3) (mapcar '* '(1 0 0) (setq pt4 (getpoint)))) (command "_.stretch" MyEnt "" (mapcar '* '(0 1 0) pt3) (mapcar '* '(0 1 0) (setq pt4 (getpoint)))) ) (redraw MyEnt 4) (setq pt1 nil)(setq pt2 nil)(setq pt3 nil)(setq pt4 nil) ; reset points (setq MyEnt nil)(setq MySS nil) ; reset entity selection (princ (strcat "Press \"X\" or \"Y\" [" mod "], select entities to stretch, or [ENTER] to exit: ")) ) ; end progn ) ; end if ;;Selection set stretch (if (and pt3 MySS) (progn (princ "\nSpecify second point") (if (= mod "X") ; X or Y axis (command "_.stretch" MySS "" (mapcar '* '(1 0 0) pt3) (mapcar '* '(1 0 0) (setq pt4 (getpoint)))) (command "_.stretch" MySS "" (mapcar '* '(0 1 0) pt3) (mapcar '* '(0 1 0) (setq pt4 (getpoint)))) ) (setq acount 0) ; remove highlights (while (< acount (sslength MySS)) (redraw (ssname MySS acount) 4) (setq acount (+ acount 1)) ) ; end while MySS (setq pt1 nil)(setq pt2 nil)(setq pt3 nil)(setq pt4 nil) ; reset points (setq MyEnt nil)(setq MySS nil) ; reset entity selection ) ; end progn ) ; end if ) ; end while grread (redraw) (command "regen") (princ "Ended OK")(princ) ) -EDIT- Added a quick number entry function to specify distance later

(defun c:t1 ( / al ss ) (setq al (vla-get-activelayout (vla-get-ActiveDocument (vlax-get-acad-object)))) (if (setq ss (ssget "_X" (list '(0 . "LWPOLYLINE")))) (vlax-for o (setq s (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))) (setq h (vla-addhatch (vlax-get al 'block) acHatchPatternTypePredefined "SOLID" :vlax-true)) (vlax-invoke h 'AppendOuterLoop (list o))(vlax-invoke h 'Evaluate) ) ) (princ) ) (defun c:t2 ( / al ss) (setq al (vla-get-activelayout (vla-get-ActiveDocument (vlax-get-acad-object)))) (princ "\nSelect objects to apply solid hatch to : ") (if (setq ss (ssget (list '(0 . "LWPOLYLINE")))) (vlax-for o (setq s (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))) (setq h (vla-addhatch (vlax-get al 'block) acHatchPatternTypePredefined "SOLID" :vlax-true)) (vlax-invoke h 'AppendOuterLoop (list o))(vlax-invoke h 'Evaluate) ) ) (princ) )

I made some comments on your code. It does work but could be made more efficient. However the main point it does work, and I'll often leave things at that rather than spending hours optimising code to save milliseconds. The 'nil' report is just the LISP telling you that there is no result from the LISP. You could put this at the end (princ) which makes the LISP exit quietly. You could see the LISP reporting something by putting for example 'a' as the last line. So some comments I'd make: (defun c:zoo () ;; I'd use (defun c:zoo ( / ) - easier to check if you have localised variables (if (setq a (entlast)) ;; OK, check there is a Last Entity (while (setq b (entnext a)) ;; after (entlast) there should be no entnext (setq a b) ) ;; Add comment here "End While" - longer codes makes modification easier ;; Add here what happens if there is no 'entlast' ) ;; Add comment here "End if" - as above (setq ent (entget a)) (setq po (assoc 10 ent)) (setq pt (cdr po)) ;; Could combine this line to the po line above (setq po (cdr (assoc 10.... ))) (command "zoom" "c" pt 50 "") ;; Add here (princ) to exit quietly (no 'nil' after ending the code) ) Following your code format I'd do something like this (defun c:zoo ( / a pt) ;; Localise variables in case other LISPS use the same (especially common ones like pt) (if (setq a (entlast)) (progn ; If 'a' found (setq pt (cdr (assoc 10 (entget a)))) ;; Get point (command "zoom" "c" pt 50) ;; Zoom to point ) ; end progn (progn ; if 'a' not found ;; If 'a' not found (princ "\nNo entity found") ;; Report that 'a' not found ) ; end progn ) ; end if (princ) ; exit quietly ;;change this to pt to see effect of LISP reporting something (zooming point) )

Checking in to celebrate my one year in badge! This site has been so beneficial to me it's awesome! Thanks all!

For single entity selection only: (defun c:test ( / MyEnt ) (while (setq MyEnt (car (entsel "\nSelect entity to delete"))) (command "erase" MyEnt "") ) ; end while (princ "OK") (princ) ) For multiple entity selections: (defun c:test ( / MyEnt ) (princ "\nSelect entity to delete") (while (setq MyEnt (ssget)) (command "erase" MyEnt "") ) ; end while (princ "OK") (princ) ) I also prefer to just press the Delete key on my keyboard.

once made (and posted) this one for fun. Use function (c:t2) : select folder , app searches *.* and displays them in listbox. With out clicking on anything start typing letters and numbers that should be part of filename. The more you type , the smaller the list becomes. When list is small enough press ok and all files in listbox will be openend. So make sure your list box doesn't still contain 100 drawings because it will try to open every single one of them and app is very hard to kill (use ctr-alt-del) ;;; DIP - Dynamic Input , Rlx Sep'23 ;;; sort of (grread) for dcl with exception for space, tab & enter which are reserved by dcl ;;; haven't (yet) found a way to catch character for space. ;;; So gonna use ' (quote) for space, not ideal but it is what it is (vl-load-com) (defun dip ( %lst / dip-list dip-width key-lst imb-str capslock bksp bksl qmrk eb-txt f p d r ib dialog-list drv lb-sel return-list) (setq dip-list %lst) ;;; make sure all elements are strings (setq dip-list (mapcar 'vl-princ-to-string dip-list)) ;;; find length of longest member (setq dip-width (car (vl-sort (mapcar 'strlen dip-list) '>))) ;;; create key codes (setq key-lst (vl-remove-if '(lambda (x)(member x '(34 92))) (append (gnum 33 95) (gnum 123 125)))) (setq imb-str ":image_button {color=dialog_background;width=0.1;height=0.1;fixed_height=true;key=\"ib_") ;;; see if acet-sys-keystate function is available (setq capslock (member 'acet-sys-keystate (atoms-family 0)) eb-txt "" bksp (strcat ":image_button {color=dialog_background;width=0.1;height=0.1;" "fixed_height=true;key=\"ib_bksp\";label=\"&\010\";}") bksl (strcat ":image_button {mnemonic=\"\\\\\";color=dialog_background;width=0.1;" "height=0.1;fixed_height=true;key=\"ib_bksl\";label=\"&\\\\\";}") qmrk (strcat ":image_button {mnemonic=\"\\\"\";color=dialog_background;width=0.1;" "height=0.1;fixed_height=true;key=\"ib_qmrk\";label=\"&\\\"\";}") ) (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (mapcar '(lambda (x) (write-line x p)) (append (list "dip:dialog {label=\"DIP - Dynamic Input (Rlx Sep'23)\";:row {alignment=centered;") (crim) (list bksp bksl qmrk "}") (list ":image_button {color=141;height=1;fixed_height=true;key=\"ib_ib\";}" ":text_part {key=\"tp\";height=1;width=40;}" ) (list (strcat ":list_box {height=25;width=" (itoa (fix (* dip-width 0.9))) ";key=\"lb\";multiple_select=true;}") "ok_cancel;" "}") ) ) (not (setq p (close p))) (< 0 (setq d (load_dialog f))) (new_dialog "dip" d) (progn (upd_lbox) (action_tile "ib_bksp" "(upd_txtp $key)") (action_tile "ib_bksl" "(upd_txtp $key)") (action_tile "ib_qmrk" "(upd_txtp $key)") (stim) (action_tile "lb" "(setq lb-sel $value)") (action_tile "accept" "(done_dialog 1)") (action_tile "cancel" "(done_dialog 0)") (setq drv (start_dialog)) (unload_dialog d) (vl-file-delete f) ) ) (cond ((= drv 0)) ((= drv 1) (cond ((and (boundp lb-sel) (vl-consp dialog-list)) (setq return-list (mapcar '(lambda (x)(nth (atoi x) dialog-list)) (SplitStr lb-sel "")))) ((vl-consp dialog-list) (setq return-list dialog-list)) (t (setq return-list nil)) ) ) (t (setq return-list nil)) ) return-list ) ;;; create image_buttons : (setq lst (gimb)) (defun crim () (mapcar '(lambda (x)(strcat imb-str (chr x) "\";label=\"&" (chr x) "\";}")) key-lst)) ;;; start image_buttons (defun stim () (foreach x key-lst (action_tile (strcat "ib_" (chr x)) "(upd_txtp $key)"))) ;;; update edit_box , k = key (ib_$) (defun upd_txtp ( k / s l) (cond ;;; backspace ((and (eq k "ib_bksp") (> (setq l (strlen eb-txt)) 1)) (setq eb-txt (substr eb-txt 1 (1- l)))) ;;; backslash ((eq k "ib_bksl") (setq eb-txt (strcat eb-txt "\\"))) ;;; quotation mark ((eq k "ib_qmrk") (setq eb-txt (strcat eb-txt "\""))) ;;; use ' for space ((eq k "ib_'") (setq eb-txt (strcat eb-txt " "))) (t (setq eb-txt (strcat eb-txt (case (substr k 4))))) ) (if (wcmatch (strcase eb-txt t) "*bksp")(setq eb-txt "")) (start_image "ib_ib") (fill_image 0 0 (dimx_tile "ib_ib") (dimy_tile "ib_ib") 141) (end_image) (set_tile "ib_ib" eb-txt) (mode_tile k 2) (upd_lbox) ) (defun upd_lbox ( / filter) (if (not (vl-consp dip-list)) (setq dip-list '("void"))) (cond ((= eb-txt "") (setq dialog-list dip-list)) (t (setq filter (strcat "*" eb-txt "*")) (setq dialog-list (vl-remove-if-not '(lambda (x)(wcmatch (strcase x) (strcase filter))) dip-list)) ) ) (start_list "lb") (mapcar 'add_list dialog-list) (end_list) (set_tile "tp" (strcat " selected " (itoa (length dialog-list)) " of " (itoa (length dip-list)))) ) ;;; helper functions ;;; determine status caps lock for when typing filter (even though filter uses strcase) (defun case (s) (cond ((null s) "") ((not (eq (type s) 'STR)) "") ((null capslock) s) (t (if (= (acet-sys-keystate 20) 0) (strcase s t) (strcase s))))) ;;; generate number (gnum 1 5) -> '(1 2 3 4 5) (defun gnum (s e / i l) (and (numberp s)(numberp e)(setq i s)(while (<= i e)(setq l (cons i l) i (1+ i)))) (reverse l)) ; (SplitStr "a,b" ",") -> ("a" "b") (defun SplitStr (s d / p) (if (setq p (vl-string-search d s))(cons (substr s 1 p)(SplitStr (substr s (+ p 1 (strlen d))) d))(list s))) ;;; d = directory , e = extension like "*.dwg" , f = flag include subfolders (any value or nil) (defun alf (d e f) (setq d (vl-string-right-trim "/" (vl-string-translate "\\" "/" d))) (if f (apply 'append (cons (if (vl-directory-files d e)(mapcar '(lambda (x) (strcat d "/" x)) (vl-directory-files d e))) (mapcar '(lambda (x) (alf (strcat d "/" x) e f))(vl-remove ".." (vl-remove "." (vl-directory-files d nil -1)))))) (mapcar '(lambda (x) (strcat d "/" x))(vl-directory-files d e 1)))) ; generic getfolder routine with possibility to create a new subfolder (GetShellFolder "select path") (defun GetShellFolder ( m / f s) (if (and (setq s (vlax-create-object "Shell.Application")) (setq f (vlax-invoke s 'browseforfolder 0 m 65536 "")))(setq f (vlax-get-property (vlax-get-property f 'self) 'path)) (setq f nil))(vl-catch-all-apply 'vlax-release-object (list s)) (if f (strcat (vl-string-right-trim "\\" (vl-string-translate "/" "\\" f)) "\\"))) ; returns T if no errors occurred during program execution (defun ShellOpen ( $f / it sh ) (if (and (not (void $f)) (setq $f (findfile $f)) (setq sh (vla-getInterfaceObject (vlax-get-acad-object) "Shell.Application"))) (progn (setq it (vl-catch-all-apply 'vlax-invoke (list sh 'open $f)))(vlax-release-object sh)(not (vl-catch-all-error-p it))) (progn (prompt "\nShell application was unable to open file")(setq it nil)))) (defun void (x) (or (eq x nil) (and (listp x)(not (vl-consp x))) (and (eq 'STR (type x)) (eq "" (vl-string-trim " \t\r\n" x))))) ;;; test function (defun c:t1 () (setq lst (dip (alf (car (fnsplitl (findfile "acad.exe"))) "*.dwg" t))) (alert (apply 'strcat (mapcar '(lambda (x)(strcat x "\n")) lst))) ) ;;; select a folder , app finds all files , don't click anything but just start typing and list will be updated with filter you typed ;;; after that all files left will be opened so don't try to open 100 autocad drawings at once... (defun c:t2 ( / fol lst dip-list) (if (and (setq fol (GetShellFolder "Select folder to search")) (vl-consp (setq lst (alf fol "*.*" t))) (vl-consp (setq dip-list (dip lst)))) (foreach f dip-list (ShellOpen f))))

@mostafa_mashhadi In simplest terms: (command "._line" pause "_per" pause); draw a line using the "per" (perpendicular) object snap. 1st PAUSE is selected "P1", 2nd PAUSE is the selected point on the line. (setq p2 (getvar "lastpoint")); P2 stores the last point selected, modified to be perpendicular to the line Did you want a more mathematical solution? Please be more specific. - Is the existing line segment just a LINE or a part of a POLYLINE, could it be both? Here is another trick solution I have used which doesn't require that much code: (defun c:foo (/ rp lp1 lp2 a p2 pp sl) (if (and (setq sl (entsel "\nPick a point on the line: ")) (setq rp (cadr sl) lp1 (osnap rp "mid") lp2 (osnap rp "end") a (angle lp1 lp2)) (setq p2 (getpoint "\nSelect Perpendicular source point: ")) ) (progn (setq pp (inters lp1 lp2 p2 (polar p2 (+ a (/ pi 2)) 1.0) nil)) (command "._line" "_non" pp "_non" p2 "") (princ (strcat "\nPerpendicular Coordinate: " (rtos (car pp)) "," (rtos (cadr pp)) "," (rtos (caddr pp)))) ) ) (princ) ) NOTE: the coordinates of the point you want are stored in variable "pp". EDIT - I updated the 1st pick to be a select box for the line for easier selection.

you could rewrite your while loops to : (while (and (> i 0) (not (wcmatch (substr textstring i 1) "#"))) (setq i (1- i))) (while (and (> i 0) (wcmatch (substr textstring i 1) "#")) (setq i (1- i))) this may fix some or all of your problems , it depends on the format of your texts. If your text ends with some letters you still have to append those too. for example (I disabled entsel and replaced it with a fix text) (defun c:IncrementTextNumber ( / ent entData textString i numEnd numStart numericPart numberValue newNumberValue newNumericPart newTextString ) ;(setq ent (car (entsel "\nSelect the text to increment: "))) ; Select the text entity (setq ent t) (if ent (progn ;(setq entData (entget ent)) ; Get the entity data ;(setq textString (cdr (assoc 1 entData))) ; Extract the text string ;;; *** testing (setq textString "123abc456def789ghi") ;; Find the position of the last numeric part (setq i (strlen textString)) ;(while (and (> i 0) (not (numberp (atoi (substr textString i 1))))) (setq i (1- i)) ) (while (and (> i 0) (not (wcmatch (substr textstring i 1) "#"))) (setq i (1- i))) ;; Find the start of the numeric part (setq numEnd i) ;(while (and (> i 0) (numberp (atoi (substr textString i 1)))) (setq i (1- i)) ) (while (and (> i 0) (wcmatch (substr textstring i 1) "#")) (setq i (1- i))) (setq numStart (+ i 1)) ;; Extract and increment the number (setq numericPart (substr textString numStart (- numEnd numStart -1))) (setq numberValue (atoi numericPart)) (setq newNumberValue (+ numberValue 1)) ;; Keep leading zeros (setq newNumericPart (rtos newNumberValue 2 0)) (while (< (strlen newNumericPart) (strlen numericPart)) (setq newNumericPart (strcat "0" newNumericPart)) ) ;; Replace the old number with the new number (setq newTextString (strcat (substr textString 1 (1- numStart)) newNumericPart)) (if (< numEnd (strlen textstring)) (setq newTextString (strcat newTextString (substr textString (1+ numEnd))))) ;| ;; Update the text in the drawing (entmod (subst (cons 1 newTextString) (assoc 1 entData) entData)) (entupd ent) |; (alert (strcat "Org. text : " (vl-princ-to-string textString) "\nNew text : " (vl-princ-to-string newTextString))) (princ "\nText updated successfully.") ) (princ "\nNo text selected.") ) (princ) ) (c:IncrementTextNumber)

Try this: (defun c:foo (/ o s) (if (setq s (ssget ":L" '((0 . "*TEXT")))) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) (setq o (vlax-ename->vla-object e)) (if (= "TEXT" (cdr (assoc 0 (entget e)))) (vla-put-textstring o (strcat "%%O" (vl-string-left-trim "%%O" (vla-get-textstring o)))) (vla-put-textstring o (strcat "\\O" (vl-string-left-trim "\\O" (vla-get-textstring o)))) ) ) ) (princ) )

Often I have to (ok , I want to) edit text (or blocks) directly on screen that are in a sort of table like order. Then it would be nice to be able sort it in rows & columns. In a perfect world all items would be spaced evenly. But we're not living in a perfect world now are we? Besides , that would be boring. Had something like this written a very long time ago but lately needed to be able to see if sorting order was correct before doing my stuff. So also for the fun of it I created mini app to sort things out (but not in my head) Anyways , added routine including a couple of tiny test functions. My own needs are a little bit more complex because need to be able to apply it on (sometimes specific) attributes in blocks too , but I leave the specialities for you little dragons Working is as follows: Select a group of simple text's (you can use attached drawing). The shape of your selection determines if you sort by row or by column (landscape means rows , portrait means columns. It uses the boundary size from 1st item in selection as a fuzz factor , some blocks are a little up , some a little down etc. This you can check by selecting the blocks on the left side of the sample drawing. After you made selection all insertionpoints (or text alignment points) the points are marked with blue number indication their rank on the social ladder. After this I use (grread) in a loop where you can use Tab to switch between ByRow & ByColumn , Spacebar to cycle in which Quadrant to start numbering and Enter means you're a happy human of planet earth. (C:t1) just shows you the list , (C:t2) you can replace the texts with another string. Rlx-Sort-SS.dwg RlxSortSS.lsp

like this? ; (SplitStr "a,b" ",") -> ("a" "b") (defun SplitStr (s d / p) (if (setq p (vl-string-search d s))(cons (substr s 1 p)(SplitStr (substr s (+ p 1 (strlen d))) d))(list s))) (nth 2 (splitstr "-1|NCC|2.54|30|0|Auto|0|1|0|2|0|0|2|0|False|0|0" "|"))

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

@harimaddddy It has to do with how you are getting the elevation numbers from the text: 1) since there is more than 1 text, the 1st entity in the selection set is not always the "EL. X", 2) the negative "-" sign does not equate to a number and it skips it in your loop to look for numbers. It's better just to look for a specific string and parse it as always having the same format. Other things: - Doing a "move to nowhere" is not the best way to get the non-text out of the selection set. it's better just to iterate through the selection and filter out the non-text entities into a new selection set. - Note I use command modifiers as standard practice, "_" helps if using non-english versions, "." ensures you are always using the original AutoCAD command even if someone has over written it with a LISP function. - I added some error handling "IF" statements to prevent errors if the user doesn't select the proper items or if they do not select / enter anything for the displacement points. - I use "_non" modifiers on commands that ask for points to prevent any object snaps from interfering with the copies. Not totally necessary, but I do it standard whenever i use predefined points in a command. - I localized all the variables - I added undo marks and turned off the CMDECHO system variable to get rid of all the extra prompts being shown. Here is my update to your program: ; Source:https://www.cadtutor.net/forum/topic/68426-create-automatic-level-in-metric/ ; Re-written by PJK 11/14/2024 (Defun c:BT (/ a b ct i lset oe n sst sset str te tv) (command "._undo" "_be") (setq oe (getvar "cmdecho")) (setvar "cmdecho" 0) (if (setq sst (ssget)) (progn (setq sset (ssget "P" '((0 . "TEXT"))) lset (ssadd) ) ; Filter out non-text and add to new selection "lset" (repeat (sslength sst) (if (/= "TEXT" (cdr (assoc 0 (entget (ssname sst (setq i (if i (1+ i) 0))))))) (ssadd (ssname sst i) lset) ) ) ; search through the text selection set to find the Elevation note. (repeat (sslength sset) (setq te (ssname sset (setq n (if n (1+ n) 0))) tv (cdr (assoc 1 (entget te))) ) ; if the prefix is found, (if (= "EL." (substr tv 1 3)) (progn ; get the numeric value and save the entity. (setq str (distof (substr tv 5)) ct te) ; remove it from the selection set. (ssdel te sset) ) ) ) ; if everything is found and the source and destination points are supplied, (if (and lset sset str (setq a (getpoint "\n Specify the source point: ")) (Setq b (getpoint a "\n Specify the Desitnation point: ")) ) (progn ;; Copy the elevation text up. (command "._copy" ct "" "_non" a "_non" b) ;; change the elevation text to the new value. (command "change" (entlast) "" "" "" "" "" "" (strcat "EL. " (rtos (+ str (- (cadr B )(cadr A))) 4 2))) ; Copy the rest of the stuff. (command "._Copy" lset sset "" "_non" a "_non" b) ) (princ "\nWrong selection or no displacement supplied.") ) ) ) (command "._undo" "_end") (setvar "cmdecho" oe) (princ) )

Waiting for dwg but I would use. Note space after setq in some cases with no space can be interpreted as a defun. Makes code easier to read. (Setq sst (ssget '(0 . "TEXT,LINE")))

A very simple answer is, it is your turn to do a little home work and learn at same time. Google "RTOS Autodesk" Have a look in the code you should be able to find it very quickly what to change.

@CivilTechSource you dont need to start a new topic this request can be added to your other post. Admin please merge into other post. Just a comment as your using multi if's it is probably better to start coding using a COND.

Hi @CivilTechSource, You need to add a (princ) (choose one of these): - the first one you can add (princ) inside of each "progn" after (princ "\nOhhhh.....) and (princ "\nAll.....) - the second one you can add (princ) after "if" statement, before or after ";----" in your code. Adding a (princ) you will get a "clean" output in command line.

What is interesting is that mline which allows multiple lines does not have the arc option. So dline in a way was more advanced. Again Autodesk no update since 1992 rather probably look at it as a to simple task so no update, but there happy to keep taking your money for upgrades.

I've now incorporated this feature into Version 1.1.

The short answer is that you have specified too much of a gap. The CIRC1 shape at a scale of 0.04 is 0.08 in diameter. So the space (negative distance) should be 0.08, and you have specified 0.05+0.05=0.10 which gives the 0.02 gap. I suspect you are just beginning to learn about linetype definitions, but to correct your code, I would amalgamate the two line sections and also the two space sections into one each. You do not need an x dimension because the insertion point of CIRC1 is at the left hand quadrant point. This would give the code line to be:- A, .4,[CIRC1,ltypeshp.shx,s=.04],-0.08

Thank you everyone! @mhupp I really like the use of grread, @pkenewell 's code worked well too. These will get me where I need. @BIGAL As always thank you. I am trying to avoid using DCL for this one, I'm getting lazy and just want to hit a key a few hundred time a day....lol Thanks Again.

So its pretty simple using grread to run sub commands allowing you to switch between the four different types. kinda follows the same principles of pkenewell's code. except its four smaller lisps called from one main lisp. if you wanted to use other buttons you would have to look them up. I think those are for the numpad keys. (defun c:CDS8EA () (entmake '((0 . "LAYER") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord") (2 . "FINAL MEAS") (70 . 0) (62 . 1) (290 . 0))) ;change 62 to the coler you want (setvar 'clayer "FINAL MEAS") (command "-dimstyle" "R" "8 ALN END ARROW") (while (setq pt (getpoint)) (command "_.LINEARDIMENSION" pt) (while (= (getvar "cmdactive") 1) (command pause) ) ) ) (defun C:MyDims (/ *error* P thisdrawing) (defun *error* () (vl-cmdf nil nil nil) ;clear (if (not (member *error* '("Console break" "Function cancelled" "quit / exit abort"))) (princ (strcat "\nError: " errmsg)) ) (setvar 'cmdecho 1) ) (setvar 'cmdecho 0) (setq P T) (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object))) (prompt "\nUse Enter to Exit") (while P (while (/= (car (setq key (grread))) 2)) (setq key (cadr key)) (cond ((= key 49) ;#1 key (C:CDS8EA) ) ((= key 50) ;#2 key ) ((= key 51) ;#3 key ) ((= key 52) ;#4 key ) ((= key 53) ;#5 key ) ((= key 54) ;#6 key ) ((= key 55) ;#7 key ) ((= key 56) ;#8 key ) ((= key 57) ;#9 key ) ((= key 13) ;#Enter key (setq P nil) ) ) ) (setvar 'cmdecho 1) (princ) )

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.

The following offers another method using a temporary saved view - the advantage being that the user can adjust the view plane in addition to zooming & panning: (defun c:test ( / *error* doc idx obj vpo vwc vwn ) (defun *error* ( msg ) (if (and (= 'vla-object (type obj)) (vlax-write-enabled-p obj)) (vla-delete obj) ) (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))) (princ (strcat "\nError: " msg)) ) (princ) ) (setq doc (vla-get-activedocument (vlax-get-acad-object)) vwc (vla-get-views doc) idx 0 ) (while (itemp vwc (setq vwn (strcat "$temp" (itoa (setq idx (1+ idx))))))) (setq obj (vla-add vwc vwn) vpo (vla-get-activeviewport doc) ) (foreach prp '(center direction height target width) (vlax-put-property obj prp (vlax-get-property vpo prp)) ) (getpoint "\nPan & zoom around...") (vla-setview vpo obj) (vla-put-activeviewport doc vpo) (*error* nil) (princ) ) (defun itemp ( col key ) (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list col key)))) ) (vl-load-com) (princ)

If you don't understand the code ask, most people will add explanations line by line. Explaining what is going on. Big list of VLA functions attached then just google what your maybe trying to understand. Sorry no author name in the Autolisp functions. The_Visual_LISP_Developers_Bible.pdf Books such as by Reonaldo Togeros, can get on Kindle as Ebook nice thing is can copy and paste code. List of all vl commands.txt AUTOLISP FUNCTIONS CATOGRIZATION.pdf