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

; 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" "|"))

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

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

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

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

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

Like you @tombu we had a dwt which had all the blocks required for CIV3D and yes waiting for the palette to display was a pain, the old fashioned using a POP Image menu was much easier to use, and you could select via subject rather than all.

If it doesn't work - could try vl-princ-to-string or vl-prin1-to-string see if that works in your code or in string to list

@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) )

Here's another, not quite as advanced as CAB's BreakAll program, but I had fun writing it - (defun c:breakwith ( / *error* brk brl ent ftr idx sel ) (defun *error* ( msg ) (LM:endundo (LM:acdoc)) (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))) (princ (strcat "\nError: " msg)) ) (princ) ) (setq ftr (list '(0 . "ARC,CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE") '(-4 . "<NOT") '(-4 . "<AND") '(0 . "POLYLINE") '(-4 . "&") '(70 . 80) '(-4 . "AND>") '(-4 . "NOT>") (if (= 1 (getvar 'cvport)) (cons 410 (getvar 'ctab)) '(410 . "Model")) ) ) (LM:startundo (LM:acdoc)) (cond ( (not (setq sel (LM:ssget "\nSelect objects to break: " (list "_:L" ftr))))) ( (not (setq brk (LM:ssget "\nSelect breaking edges: " (list ftr))))) ( (progn (repeat (setq idx (sslength brk)) (setq idx (1- idx) ent (ssname brk idx) ) (if (not (ssmemb ent sel)) (setq brl (cons (vlax-ename->vla-object ent) brl)) ) ) (null brl) ) (princ "\nAll selected breaking edges were also selected to be broken.") ) ( (repeat (setq idx (sslength sel)) (setq idx (1- idx)) (breakwithlist (ssname sel idx) brl 1) ) ) ) (*error* nil) (princ) ) (defun breakwithlist ( ent lst mxd / cmd enl obj pnt pt1 pt2 tmp ) (cond ( (< 256 mxd)) ;; Just in case ( (setq obj (vlax-ename->vla-object ent) pt1 (vlax-curve-getstartpoint ent) pt2 (vlax-curve-getendpoint ent) pnt (vl-some '(lambda ( x ) (vl-some '(lambda ( p ) (if (and (not (equal p pt1 1e-8)) (not (equal p pt2 1e-8)) ) p ) ) ( (lambda ( l / r ) (repeat (/ (length l) 3) (setq r (cons (mapcar '(lambda ( a b ) a) l '(0 1 2)) r) l (cdddr l) ) ) (reverse r) ) (vlax-invoke obj 'intersectwith x acextendnone) ) ) ) lst ) ) (setq enl (entlast) cmd (getvar 'cmdecho) pnt (trans pnt 0 1) ) (while (setq tmp (entnext enl)) (setq enl tmp) ) (setvar 'cmdecho 0) (vl-cmdf "_.break" (list ent pnt) "_f" "_non" pnt "_non" pnt) (setvar 'cmdecho cmd) (if (entnext enl) (breakwithlist ent lst (1+ mxd)) ) (while (setq enl (entnext enl)) (breakwithlist enl lst (1+ mxd)) ) ) ) ) ;; ssget - Lee Mac ;; A wrapper for the ssget function to permit the use of a custom selection prompt ;; msg - [str] selection prompt ;; arg - [lst] list of ssget arguments (defun LM:ssget ( msg arg / sel ) (princ msg) (setvar 'nomutt 1) (setq sel (vl-catch-all-apply 'ssget arg)) (setvar 'nomutt 0) (if (not (vl-catch-all-error-p sel)) sel) ) ;; Start Undo - Lee Mac ;; Opens an Undo Group. (defun LM:startundo ( doc ) (LM:endundo doc) (vla-startundomark doc) ) ;; End Undo - Lee Mac ;; Closes an Undo Group. (defun LM:endundo ( doc ) (while (= 8 (logand 8 (getvar 'undoctl))) (vla-endundomark doc) ) ) ;; Active Document - Lee Mac ;; Returns the VLA Active Document Object (defun LM:acdoc nil (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object)))) (LM:acdoc) ) (vl-load-com) (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.

;;; rlx 2024-10-01 - https://www.cadtutor.net/forum/topic/91692-request-for-assistance-in-editing-texts/ (defun c:Mehrdad ( / doc actLay actDoc actDocs actApp actDbx AllOpen dir lst x-list y-list y z save data) (vl-load-com) (setq x-list (list 252.0 280.0 360.0 375.0 388.0) y-list (list 26.5 33.0 39.5 46.0 52.5 59.0 65.5) z 0.0) ;;; if you another date , change line to something like (setq date "01-02-25") (setq date (now)) (setq s-list (list date "APPROVED FOR CONSTRUCTION" "R.S" "A.SH" "A.SH")) ;;; set y coordinate for row D1 (setq y (nth 1 y-list)) (if (and (setq dir (GetShellFolder "Select Folder")) (vl-consp (setq lst (alldrawings dir)))) (foreach dwg lst (if (setq doc (odbx_open dwg)) (progn (mapcar '(lambda (txt x) (addtext_dbx doc txt (list x y z) 3.125)) s-list x-list) (if (vl-catch-all-error-p (setq save (vl-catch-all-apply 'vla-saveas (list doc dwg)))) (alert (strcat "Save error: " (vl-catch-all-error-message save) "\ndrawing : " (vl-princ-to-string dwg)))) ) (princ (strcat "\nUnable to open : " dwg)) ) ) ) (_ReleaseAll) (princ "\nDone.") (princ) ) ;;; --- Odbx ---------------------------------------------- Begin Odbx Section ----------------------------------------------- Odbx --- ;;; (defun GetAllOpenDocs () (or actApp (setq actApp (vlax-get-acad-object))) (or actDoc (setq actDoc (vla-get-ActiveDocument actApp))) (or actDocs (setq actDocs (vla-get-documents actApp))) (vlax-for doc actDocs (if (= 1 (vlax-variant-value (vla-getvariable doc "DWGTITLED"))); no nameless drawings (setq AllOpen (cons (cons (strcase (vla-get-fullname doc)) doc) AllOpen)))) ) (defun _ReleaseAll () (mapcar '(lambda(x) (if (and (= 'vla-object (type x)) (not (vlax-object-released-p x))) (vlax-release-object x))(set x nil)) (list 'doc 'actLay 'actDoc 'actDocs 'actApp 'actDbx))(gc)) (defun _InitObjectDBX ()(or actApp (setq actApp (vlax-get-acad-object))) (or actDoc (setq actDoc (vla-get-ActiveDocument actApp)))(or AllOpen (setq AllOpen (GetAllOpenDocs))) (setq actDbx (vl-catch-all-apply 'vla-getinterfaceobject (list actApp (dbx_ver)))) (if (or (null actDbx)(vl-catch-all-error-p actDbx))(progn (princ "\nObjectDbx not available")(setq actDbx nil))) actDbx ) (defun odbx_open ( $dwg / _pimp doc) (or AllOpen (GetAllOpenDocs)) (defun _pimp (s) (strcase (vl-string-trim " ;\\" (vl-string-translate "/" "\\" s)))) (cond ((or (void $dwg) (not (findfile $dwg)))(princ "\nInvalid drawing")(setq doc nil)) ((not (or actDbx (_InitObjectDBX)))(princ "\nObjectDbx not available")(setq doc nil)) ((setq doc (cdr (assoc (_pimp $dwg) AllOpen)))) ((vl-catch-all-error-p (vl-catch-all-apply 'vla-Open (list actDbx (findfile $dwg)))) (princ "\nUnable to open drawing.")(setq doc nil)) (t (setq doc actDbx))) doc ) (defun odbx_close ( %doc ) (if (and (= 'vla-object (type %doc)) (not (vlax-object-released-p %doc)))(progn (vlax-release-object %doc))(setq %doc nil))) (defun dbx_ver ( / v) (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v))))) ;;; --- Odbx ---------------------------------------------- End Odbx Section ------------------------------------------------- Odbx --- ;;; ;;; --- Tiny Lisp ---------------------------------------- Begin of Tiny Lisp ------------------------------------------- Tiny Lisp --- ;;; ; 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)) "\\"))) ;;; (getsubfolders "c:/temp/lisp") (defun getsubfolders ( d / l r s )(setq d (Dos_Path d))(setq l (list (vl-string-trim "/\\" d)))(while l (setq s nil) (foreach d l (setq s (append s (mapcar (function (lambda (x)(strcat d "\\" x))) (vl-remove-if (function (lambda (x)(member x '("." ".."))))(vl-directory-files d nil -1)))))) (setq r (append s r) l s)) (cons d (mapcar 'Dos_Path r)) ) (defun Dos_Path ($p) (if (= (type $p) 'STR) (strcase (strcat (vl-string-right-trim "\\" (vl-string-translate "/" "\\" $p)) "\\")) "")) (defun alldrawings ( d / s l r) (setq l (mapcar 'Dos_Path (getsubfolders d))) (foreach s l (setq r (append r (mapcar '(lambda (x)(strcat s x))(vl-directory-files s "*.dwg" 1))))) r) ;;; s = string , p = insertion point , h = text height (defun addtext_dbx (d s p h / o a) (setq o (vla-AddText (vla-get-ModelSpace d) s (vlax-3d-point p) h))) ;;; s = string , p = insertion point , h = text height (defun addtext_dbx (d s p h / o a stls) (addTextStyle_dbx d "HTX1" "arial.ttf") (setq o (vla-AddText (vla-get-ModelSpace d) s (vlax-3d-point p) h)) (vla-put-StyleName o "HTX1") ;;; just optional for easy viewing (vla-put-color o acRed) ) (defun addTextStyle_dbx (doc stl fnt / styles style stl-obj Fnt-Ext) (setq styles (vla-get-textstyles doc)) (if (vl-catch-all-error-p (setq style (vl-catch-all-apply 'vla-item (list styles stl)))) (setq stl-obj (vla-add styles style)) (setq stl-obj style)) (setq Fnt-Ext (vl-filename-extension fnt)) (if (= Fnt-Ext ".ttf")(setq fnt (strcat "C:\\Windows\\Fonts\\" fnt))) (setq fnt (findfile fnt)) (vla-put-fontfile stl-obj fnt) ) ;;; "01-10-24" (defun now ( / ns) (setq ns (rtos (getvar "CDATE")) ns (strcat (substr ns 7 2) "-" (substr ns 5 2) "-" (substr ns 3 2)))) (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))))) ;;; --- Tiny Lisp ---------------------------------------- Begin of Tiny Lisp ------------------------------------------- Tiny Lisp --- ;;; (c:Mehrdad)

That might be the worst thing I've ever heard. Thing about bosses is, from time-to-time, they need to be reminded they don't always have the answers.

@smitaranjan This is how TBA lisp works. See the attached video. You don't need to manually copy and paste TEXT or MTEXT inside of block! After selection set is finished you just need to pick a point where to insert block one by one. If this fit for your needs, use it. Best regards. TBA.mp4

I'll be honest, I didn't understand what you were asking for originally Now I see this lisp I understand, and it has the gears in my mind turning with possibilities haha Knew you were in good hands.. Have a great weekend both

@pkenewellThis works perfectly. I can usually see how the programs work, but this work of genius, i can't get my head around... I have a couple of projects coming up where this would be used around 10 times each. Thank you my friend

@Sharper Actually I'm back from Holiday now so no problem . Hope your Holiday is going well. Just let me know how it works when you have time to look at it.