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

@EIA You can use a dynamic block. А-А.dwg

Why not something different...? ;************************ G L A V C V S ************************* ;************************** F E C I T *************************** (defun c:txtIncrem (/ tam capa ind para a txsel lstent le l s dameTexto errores error0) (defun errores (mens) (setq *error* error0) (prin1) ) (defun dameTexto (/ tx) ;;; WRITE HERE THE CODE YOU NEED TO CUSTOMIZE THE TEXT YOU WANT TO ENTER OR CREATE (cond ((= (strlen (setq tx (itoa (setq ind (+ ind 1))))) 1) (strcat "00" tx) ) ((= (strlen tx) 2) (strcat "0" tx) ) (T tx) ) ) (while (not para) (if (setq ent (car (entsel "\nSelect index text..."))) (if (= (cdr (assoc 0 (setq lstent (entget ent)))) "TEXT") (if (wcmatch (setq ind (cdr (assoc 1 lstent))) "#,##,###,####") (setq ind (atoi ind) capa (cdr (assoc 8 lstent)) a (cdr (assoc 40 lstent)) para T) (princ "\n*** The selected object is not valid. Please, try again... ***") ) ) (setq para T) ) ) (setq error0 *error* *error* errores ) (setq tam (* (getvar "pickbox") (/ (GETVAR "VIEWSIZE") (CADR (GETVAR "SCREENSIZE")))) para nil) (princ "\nSelect text to modify or insert new text (RIGHT CLICK for exit)...") (while (and (setq l (grread T (if s 4 13) (if s 2 0))) (member (car l) '(5 3))) (if (setq s (ssget "_C" (list (- (car (setq p (cadr l))) tam) (- (cadr p) tam)) (list (+ (car p) tam) (+ (cadr p) tam)) (list (cons 0 "TEXT")) ) ) (cond ((= (car l) 3) (entmod (subst (cons 1 (dameTexto)) (assoc 1 (setq le (entget (ssname s 0)))) le)) ) ;Here are other possible cases ) (cond ((= (car l) 3) (entmake (list '(0 . "TEXT") (cons 8 capa) (cons 40 a) (cons 1 (dameTexto)) (cons 10 (list (car p) (cadr p) 0.0)) ) ) ) ;Here are other possible cases ) ) ) (princ) )

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

Hi In this new version, it's possible to enter the text before the first text you want to insert from the keyboard or, as before, select it on the screen. Additionally, it will now increment numeric, alphabetic, or alphanumeric text strings without any restrictions (except for non-alphanumeric characters, of course). @leonucadomi As for your suggestion to extend the code's functionality to block attributes, I may do something about this in the future. However, I'm sure there must be simpler routines that would do the job just as well. There are several block experts on this forum who will probably have something to say about this. But if not, I'll try to do it myself. ;************************ G L A V C V S ************************* ;************************** F E C I T *************************** (defun c:txtIncrem (/ tam capa ind para a c cl txsel le l s dameTexto obtcad ent loc tipC nC ps add errores error0 ) (defun errores (mens) (setq *error* error0) (prin1) ) (defun dameTexto (cad / v r l daleVuelta) ;;; WRITE HERE THE CODE YOU NEED TO CUSTOMIZE THE TEXT YOU WANT TO ENTER OR CREATE (defun daleVuelta (a) (cond ((and (> a 64) (< a 91)) (if (> (setq a (+ a 1)) 90) (setq a -65) a)) ((and (> a 96) (< a 123)) (if (> (setq a (+ a 1)) 122) (setq a -97) a)) ((and (> a 47) (< a 58)) (if (> (setq a (+ a 1)) 57) (setq a -48) a)) ) ) (foreach v (reverse (vl-string->list cad)) (if (or (not r) (minusp r)) (setq l (cons (abs (setq r (daleVuelta v))) l)) (setq l (cons v l)) ) ) (vl-list->string (if (minusp r) (cons (if (= r -48) 49 (car l)) l) l)) ) (setq error0 *error* *error* errores ) (princ (setq s "Select PREVIOUS number text or type it... ")) (while (not para) (setq l (grread T 13 2)) (if (not (listp (cadr l))) (if (member (car l) '(2 3 11 25)) (cond ((or (= (cadr l) 13) (= (car l) 25)) (if (and c (not (wcmatch c "*.*"))) (setq ind c para T) (if (not c) (setq para T)) ) ) ((> (cadr l) 31) (setq c (if c (strcat c (chr (cadr l))) (chr (cadr l)))) (prompt (strcat "\r" s c)) ) ((= (cadr l) 8) (if (setq c (if c (substr c 1 (- (strlen c) 1)))) (prompt (strcat "\r" s c)) ) ) ) ) (if (= (car l) 3) (if (and (setq e (nentselp (cadr l))) (= (cdr (assoc 0 (setq le (entget (setq e (car e)))))) "TEXT")) (if (not (wcmatch (setq ind (cdr (assoc 1 le))) "*.*")) (setq capa (cdr (assoc 8 le)) a (cdr (assoc 40 le)) cl (cdr (assoc 62 le)) para T) (princ "\n*** The selected object is not valid. Please, try again... ***") ) ) ) ) ) (setq para nil) (if (not capa) (while (not para) (if (and (setq e (car (entsel "\nLAYER/HEIGHT: Select a sample text object (ENTER or RIGHT CLICK to type it)... "))) (setq l (entget e)) ) (if (= (cdr (assoc 0 l)) "TEXT") (setq capa (cdr (assoc 8 l)) a (cdr (assoc 40 l)) para T) (princ "\n*** The selected object is not a TEXT. Please, try again... ***") ) (if (not capa) (if (setq capa (getstring "\nType Layer name: ")) (if (tblsearch "layer" capa) (if (not (setq a (getreal "\nType Height: "))) (setq capa (princ "\n*** A valid height has not been specified. Please, type it again... ***") capa nil) (setq para T) ) (setq capa (princ "\n*** Specified layer does not exist. Please, type it again... ***") capa nil) ) ) ) ) ) ) (setq tx (dameTexto ind)) (while (and (setq l (grread T (if s 4 13) (if s 2 0))) (member (car l) '(5 3))) (prompt (strcat "\rSelect text to modify or insert new text \"" tx "\" (RIGHT CLICK for exit)")) (setq tam (* (getvar "pickbox") (/ (GETVAR "VIEWSIZE") (CADR (GETVAR "SCREENSIZE")))) para nil) (if (setq s (ssget "_C" (list (- (car (setq p (cadr l))) tam) (- (cadr p) tam)) (list (+ (car p) tam) (+ (cadr p) tam)) (list (cons 0 "TEXT")) ) ) (cond ((= (car l) 3) (entmod (subst (cons 1 tx) (assoc 1 (setq le (entget (ssname s 0)))) le)) (setq tx (dameTexto tx)) ) ;;; HERE MORE CASES ?... ) (cond ((= (car l) 3) (entmake (list '(0 . "TEXT") (cons 8 capa) (cons 62 (if cl cl 256)) (cons 40 a) (cons 1 tx) (cons 10 (list (car p) (cadr p) 0.0)) ) ) (setq tx (dameTexto tx)) ) ;;; HERE MORE CASES ?... ) ) ) (princ) )

This give a point at min z on 3Dpolyline. (vl-load-com) (defun c:min_z ( / js obj ename pr pt lst_pt lst_z id_seg nw_pt) (princ "\nSelect 3DPolylines: ") (while (null (setq js (ssget '((0 . "POLYLINE") (-4 . "&") (70 . 8))))) (princ "\nObjects not valid!") ) (repeat (setq n (sslength js)) (setq obj (ssname js (setq n (1- n))) ename (vlax-ename->vla-object obj) pr -1 lst_pt nil ) (repeat (if (zerop (vlax-get ename 'Closed)) (1+ (fix (vlax-curve-getEndParam ename))) (fix (vlax-curve-getEndParam ename))) (setq pt (vlax-curve-GetPointAtParam ename (setq pr (1+ pr))) lst_pt (cons pt lst_pt) ) ) (setq lst_z (mapcar 'caddr lst_pt) id_seg (- (length lst_z) (length (member (apply 'min lst_z) lst_z))) ) (setq nw_pt (vlax-invoke (if (eq (getvar "CVPORT") 1) (vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object))) (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))) ) 'AddPoint (nth id_seg lst_pt) ) ) (vla-put-Normal nw_pt (vlax-3d-point '(0 0 1))) ) (prin1) )

Try changing this line : (setq gap (getvar "dimtxt")) To this line : (setq gap (* 2.0 (getvar "dimtxt")))

I am on holidays back tomorrow will have a look at it

Also, if the "MTEXT" is, you can select all desired "MTEXT" and from "PROPERTIES" tab, select "Text frame". That is the easiest way to do and make a boundary around text. If the "TEXT" is, you can use a built-in function in CAD "TXT2MTXT", select all "TEXT" entities and convert it in "MTEXT" and than add a frame.

Here is the little modification that was missing: you already have the functionality But you should simplify the code a bit. One test you could do is to obtain the triangles using minimum circles to compare the differences. Do your tests (defun SX:M3DFACEF3DPL (/ enameOne enameSecond old_layer layerNameBase dataOne ptOne ptlistOne dataSecond ptSecond ptlistSecond len i j pt1 pt2 pt3 ind1 ind2 decideTRI ang_sub_ref ) (defun decideTRI (/ a b c d pt1Lst1 pt2Lst1 pt1Lst2 pt2Lst2 selecTRIbase->Lista1 selecTRIbase->Lista2 TRI_transgresor? ) (defun selecTRIbase->Lista1 () (setq pt1 pt1Lst1 pt2 pt2Lst1 pt3 pt1Lst2 ind1 (+ ind1 1) ) ) (defun selecTRIbase->Lista2 () (setq pt1 pt1Lst2 pt2 pt2Lst2 pt3 pt1Lst1 ind2 (+ ind2 1) ) ) (defun TRI_transgresor? (pt2 pt3 / lst1 lst2 n m pto1 pto2 lista para val ind pt2D) (defun pt2D (pt3D) (list (car pt3D) (cadr pt3D)) ) (setq pt2 (polar (pt2D pt2) (angle pt2 pt3) 0.01) pt3 (polar (pt2D pt3) (angle pt3 pt2) 0.01) lst1 (foreach ind '(-2 -1 0 1 2) (if (and (not (minusp (+ ind1 ind))) (setq val (nth (+ ind1 ind) ptlistOne)) ) (setq lst1 (append lst1 (list (pt2D val)))) ) ) lst2 (foreach ind '(-2 -1 0 1 2) (if (and (not (minusp (+ ind2 ind))) (setq val (nth (+ ind2 ind) ptlistSecond)) ) (setq lst2 (append lst2 (list (pt2D val)))) ) ) ) (setq m 0) (while (and (not para) (setq lista (nth m (list lst1 lst2)))) (setq n 0) (while (and (not para) (setq pto2 (nth (+ n 1) lista))) (setq pto1 (nth n lista)) (if (inters pt2 pt3 pto1 pto2) (setq para T) ) (setq n (+ n 1)) ) (setq m (+ m 1)) ) para ) (setq pt1Lst1 (nth ind1 ptlistOne) pt2Lst1 (nth (1+ ind1) ptlistOne) pt1Lst2 (nth ind2 ptlistSecond) pt2Lst2 (nth (1+ ind2) ptlistSecond) ) (if (and pt1Lst1 pt2Lst1 pt1Lst2 pt2Lst2) (if (= (min (setq a (abs (- (abs (ang_sub_ref (nth ind1 ptlistOne) (nth (1+ ind1) ptlistOne) (nth ind2 ptlistSecond) ) ) (/ pi 2.0) ) ) ) (setq b (abs (- (abs (ang_sub_ref (nth ind2 ptlistSecond) (nth (1+ ind2) ptlistSecond) (nth ind1 ptlistOne) ) ) (/ pi 2.0) ) ) ) ) a ) (if (not (TRI_transgresor? pt2Lst1 pt1Lst2)) (selecTRIbase->Lista1) (selecTRIbase->Lista2) ) (if (not (TRI_transgresor? pt2Lst2 pt1Lst1)) (selecTRIbase->Lista2) (selecTRIbase->Lista1) ) ) (setq lst (list pt1Lst1 pt2Lst1 pt1Lst2 pt2Lst2) lst (vl-remove nil lst) ind1 (+ ind1 10) ind2 (+ ind2 10) pt1 (nth 0 lst) pt2 (nth 1 lst) pt3 (nth 2 lst) ) ) ) (defun ang_sub_ref (pta ptb pt1 / ang_result ang_ref ang ang_desde_ptb) (setq ang_ref (angle pta ptb) ang_desde_ptb (angle ptb pt1) ) (cond ((< (abs (setq ang (- ang_ref ang_desde_ptb))) PI) ang ) ((and (> (abs (setq ang (- ang_ref ang_desde_ptb))) PI) (<= ang_ref PI) ) (+ ang_ref (- (* 2 PI) ang_desde_ptb)) ) ((and (> (abs (setq ang (- ang_ref ang_desde_ptb))) PI) (> ang_ref PI) ) (- (- ang_ref (* 2 PI)) ang_desde_ptb) ) (T (princ "\n***Caso no esperado en ang_sub_ref") ) ) ) ;;; (command-s "_UNDO" "BE") (setq enameOne (car (entsel "\nSelect the first 3DPOLYLINE:")) enameSecond (car (entsel "\nSelect the second 3DPOLYLINE:")) ) (while (or (= enameOne nil) (not (= "POLYLINE" (cdr (assoc 0 (entget enameOne))))) ) (if (= enameOne nil) (progn (prompt "\nNothing was selected. Try again...") (setq enameOne (car (entsel "\nSelect the first 3DPOLYLINE:"))) (princ) ) (progn (prompt "\nSelected entity must be 3DPOLYLINE. Try again..." ) (setq enameOne (car (entsel "\nSelect the first 3DPOLYLINE:"))) (princ) ) ) ) (while (or (= enameSecond nil) (not (= "POLYLINE" (cdr (assoc 0 (entget enameSecond))))) ) (if (= enameSecond nil) (progn (prompt "\nNothing was selected. Try again...") (setq enameSecond (car (entsel "\nSelect the second 3DPOLYLINE:")) ) (princ) ) (progn (prompt "\nSelected entity must be 3DPOLYLINE. Try again..." ) (setq enameSecond (car (entsel "\nSelect the second 3DPOLYLINE:")) ) (princ) ) ) ) (setq old_layer (getvar 'clayer) layerNameBase (cdr (assoc 8 (entget enameOne))) ) (setvar 'clayer layerNameBase) ;;; (setq objOne (vlax-ename->vla-object enameOne) ;;; objSecond (vlax-ename->vla-object enameOne) ;;; ) (setq dataOne (entget enameOne)) (while (/= (cdr (assoc 0 dataOne)) "SEQEND") (setq ptOne (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dataOne) ) ) (if (/= (nth 0 (nth 0 ptOne)) 0.0) (setq ptlistOne (cons ptOne ptlistOne)) ) (setq dataOne (entget (entnext (cdr (assoc -1 dataOne))))) ) (setq ptlistOne (mapcar 'car ptlistOne)) ; lista de puntos de la primera polil铆nea 3D (setq dataSecond (entget enameSecond)) (while (/= (cdr (assoc 0 dataSecond)) "SEQEND") (setq ptSecond (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dataSecond ) ) ) (if (/= (nth 0 (nth 0 ptSecond)) 0.0) (setq ptlistSecond (cons ptSecond ptlistSecond)) ) (setq dataSecond (entget (entnext (cdr (assoc -1 dataSecond))))) ) (setq ptlistSecond (mapcar 'car ptlistSecond)) ; lista de puntos de la segunda polil铆nea 3D (setq ptlistOne (reverse ptlistOne)) (setq ptlistSecond (reverse ptlistSecond)) ;;; (if (> (length ptlistOne) (length ptlistSecond)) ;;; (progn ;;; (setq len (length ptlistOne) ;;; i 0 ;;; j 0 ;;; ) ;;; ) ;;; (progn ;;; (setq len (length ptlistSecond) ;;; i 0 ;;; j 0 ;;; ) ;;; ) ;;; ) ;;; (while (< i len) ;;; (if (/= (nth (1+ i) ptlistOne) nil) ;;; (entmake (list (cons 0 "3DFACE") ;;; (cons 10 (nth i ptlistOne)) ;;; (cons 11 (nth j ptlistSecond)) ;;; (cons 12 (nth (1+ i) ptlistSecond)) ;;; (cons 13 (nth i ptlistOne)) ;;; ) ;;; ) ;;; ) ;;; (if (and (/= (nth (1+ i) ptlistOne) nil) ;;; (/= (nth (1+ j) ptlistSecond) nil) ;;; ) ;;; (entmake (list (cons 0 "3DFACE") ;;; (cons 10 (nth (1+ i) ptlistOne)) ;;; (cons 11 (nth (1+ j) ptlistSecond)) ;;; (cons 12 (nth i ptlistOne)) ;;; (cons 13 (nth (1+ i) ptlistOne)) ;;; ) ;;; ) ;;; ) ;;; (setq i (1+ i) ;;; j (1+ j) ;;; ) ;;; ) (setq ind1 0 ind2 0 ) (while (and (nth ind1 ptlistOne) (nth ind2 ptlistSecond) (or (nth (1+ ind1) ptlistOne) (nth (1+ ind2) ptlistSecond)) ) (decideTRI) (entmake (list (cons 0 "3DFACE") (cons 10 pt1) (cons 11 pt2) (cons 12 pt3) (cons 13 pt1) ) ) ;;; (getstring "\nPulsa INTRO") ) (setvar 'clayer old_layer) ;;; (command-s "_UNDO" "E") (princ) )

\\n because a single \ is a control character in a string, to write a single \ to the text file you need to add \ (control character) and \ (character you want to use) - special case for \ that you have to specify you want to use it as a \

to get you started ;;; written for rdx 2024-07-12 (defun c:rdx ( / dcl-fp dcl-fn dcl-id continu) (vl-load-com) (rdx_write_dialog) (rdx_start_dialog) (princ (strcat "\nValue of continue last selection : " (vl-princ-to-string continu))) (princ) ) (defun rdx_write_dialog ( ) (if (and (setq dcl-fn (vl-filename-mktemp "tmp" "" ".dcl")) (setq dcl-fp (open dcl-fn "w"))) (mapcar '(lambda (x)(write-line x dcl-fp)) (list "tccz : dialog {" " label=\"Layer Operations\";" " :row{" " :button{label=\"object select\";key=\"object_select\";is_default=true;fixed_width=true;width=4;}" " :button{label=\"Dim Select\";key=\"notuxian\";fixed_width=true;width=4;}" " }" " :row{" " :button{label=\"Isolate Select\";key=\"geli\";fixed_width=true;width=4;}" " :button{label=\"Close Select\";key=\"nogeli\";fixed_width=true;width=4;}" " }" " :row{" " :button{label=\"Lock Select\";key=\"suoding\";fixed_width=true;width=4;}" " :button{label=\"Lock Unselect\";key=\"nosuoding\";fixed_width=true;width=4;}" " }" " :row{" " :button{label=\"Freeze Select\";key=\"dongjie\";fixed_width=true;width=4;}" " :button{label=\"Freeze Unselect\";key=\"nodongjie\";fixed_width=true;width=4;}" " }" " :row{" " :text{value=\"when the command is first executed\";is_enabled=true;fixed_width=true;width=29;fixed_height=true;height=0;}" " }" " :row{" " :button{label=\"Color uniformity\";key=\"bylayer\";fixed_width=true;width=4;}" " :button{label=\"Restore\";key=\"huifu\";fixed_width=true;width=4;}" " }" " :row{" " :button{label=\"Layer Management\";key=\"state\";fixed_width=true;width=4;}" " :button{label=\"cancel\";key=\"cancel\";is_cancel=true;fixed_width=true;width=14;fixed_height=true;height=1;is_enabled=true;}" " }" " :toggle{label=\"Continue last status\";key=\"continu\";fixed_width=true;width=4;}" " }" ) ) ) (if dcl-fp (progn (close dcl-fp)(gc))) ) (defun rdx_start_dialog ( / rtn ) (if (and (< 0 (setq dcl-id (load_dialog dcl-fn))) (new_dialog "tccz" dcl-id)) (progn (action_tile "cancel" "(done_dialog 0)") (action_tile "accept" "(done_dialog 1)") (action_tile "object_select" "(alert \"object select\")(done_dialog 2)") (action_tile "notuxian" "(alert \"Dim Select\")(done_dialog 3)") (action_tile "geli" "(alert \"Isolate Select\")(done_dialog 4)") (action_tile "nogeli" "(alert \"Close Select\")(done_dialog 5)") (action_tile "suoding" "(alert \"Lock Select\")(done_dialog 6)") (action_tile "nosuoding" "(alert \"Lock Unselect\")(done_dialog 7)") (action_tile "dongjie" "(alert \"Freeze Select\")(done_dialog 8)") (action_tile "nodongjie" "(alert \"Freeze Unselect\")(done_dialog 9)") (action_tile "bylayer" "(alert \"Color uniformity\")(done_dialog 10)") (action_tile "huifu" "(alert \"Restore\")(done_dialog 11)") (action_tile "state" "(alert \"Layer Management\")(done_dialog 12)") (action_tile "continu" "(setq continu $value)") (setq rtn (start_dialog)) (unload_dialog dcl-id) (vl-file-delete dcl-fn) ) (princ "\nUnable to start dialog") ) (if (null continu)(setq continu "0")) (cond ((= rtn 0) (princ "\nYou clicked on cancel")) ((= rtn 1) (princ "\nYou clicked on ok")) ((= rtn 2) (object_select)) ((= rtn 3) (notuxian)) ((= rtn 4) (geli)) ((= rtn 5) (nogeli)) ((= rtn 6) (suoding)) ((= rtn 7) (nosuoding)) ((= rtn 8) (dongjie)) ((= rtn 9) (nodongjie)) ((= rtn 10) (bylayer)) ((= rtn 11) (huifu)) ((= rtn 12) (state)) ) ) (defun object_select ()(alert "under construction - object_select")) (defun notuxian ()(alert "under construction - notuxian")) (defun geli ()(alert "under construction - geli")) (defun nogeli ()(alert "under construction - nogeli")) (defun suoding ()(alert "under construction - suoding")) (defun nosuoding ()(alert "under construction - nosuoding")) (defun dongjie ()(alert "under construction - dongjie")) (defun nodongjie ()(alert "under construction - nodongjie")) (defun bylayer ()(alert "under construction - bylayer")) (defun huifu ()(alert "under construction - huifu")) (defun state ()(alert "under construction - state")) alternative for your dcl code : (defun rdx_write_dialog ( ) (if (and (setq dcl-fn (vl-filename-mktemp "tmp" "" ".dcl")) (setq dcl-fp (open dcl-fn "w"))) (mapcar '(lambda (x)(write-line x dcl-fp)) (list "tccz : dialog {label=\"Layer Operations\";" ":boxed_row {label=\"Select layer operation : \";" ":column {:bt {label=\"Object Select\";key=\"object_select\";}:bt {label=\"Isolate Select\";key=\"geli\";}" ":bt {label=\"Lock Select\";key=\"suoding\";}:bt {label=\"Freeze Select\";key=\"dongjie\";}}" ":column {:bt {label=\"Dim Select\";key=\"notuxian\";}:bt {label=\"Close Select\";key=\"nogeli\";}" ":bt {label=\"Lock Unselect\";key=\"nosuoding\";}:bt {label=\"Freeze Unselect\";key=\"nodongjie\";}}}" "spacer;" ":boxed_row {label=\"When the command is first executed : \";" ":column {:bt {label=\"Layer Management\";key=\"state\";}:bt {label=\"Restore\";key=\"huifu\";}}" ":column {:bt {label=\"Color Uniformity\";key=\"bylayer\";}:bt {label=\"Future\";key=\"future\";}}}" ":toggle {label=\"Continue last status\";key=\"continu\";}spacer;ok_cancel;}" "bt :button {width=26;fixed_width=true;}" ) ) ) (if dcl-fp (progn (close dcl-fp)(gc))) )

This is partly a data problem. You might be able to create a dynamic block, which you can move and scale to fit the various sizes of column (or footing or whatever). The block contains attributes for each piece of data, which you can read/export fairly easily. It's also easy to select a specific type of block, put them in a set, and process each one. It's also partly a drafting problem. With different lengths for the codes, it's hard to use separate attributes, because they'll overlap. You could include code to input/validate and output/filter a group of codes, but there's no way to prevent someone from manually breaking your system. I can't tell what the "position numbers" mean, so I can't tell you how to generate them. There is software out there for drawing and labeling rebar. Some of them cost money. I don't know if you can generate the labels the way you need to, or if there's a way to customize them. AutoLISP has the benefit of being free (apart from the time you spend writing and debugging it), and it's infinitely customizable.

I was looking for the original on Cadalyst, but this appears to be an update to that one. Make a New Linetype with Text Here is the latest on Cadalyst. There is another out there called LtFly.

A linetype can be read from a .lin file no need for code. *HOT_WATER_SUPPLY,Hot water supply ---- HW ---- HW ---- HW ---- A,12.7,-5.08,["HW",STANDARD,S=2.54,R=0.0,X=-2.54,Y=-1.27],-5.08 We had custom.lin with lots of linetypes and would preload into our dwt so ready to go. Or Linetype Load 1 or more linetype into a dwg. ;load missing linetypes ;;; returns: T if loaded else nil (loadLinetype doc "Fence" "custom.lin") (loadLinetype doc "Tree" "custom.lin") (setq doc (vla-get-activedocument (vlax-get-acad-object))) ; open database (defun loadLinetype (doc LineTypeName FileName) (if (and (not (existLinetype doc LineTypeName)) (vl-catch-all-error-p (vl-catch-all-apply 'vla-load (list (vla-get-Linetypes doc) LineTypeName FileName ) ) ) ) nil T ) ) (defun existLinetype (doc LineTypeName / item loaded) (vlax-for item (vla-get-linetypes doc) (if (= (strcase (vla-get-name item)) (strcase LineTypeName)) (setq loaded T) ) ) )

oh, found a function of Lee Mac that does exactly what i want.

Code 43 is for global width .. you can also entmod the items without the need to create the layer: (defun c:foo (/ s) (if (setq s (ssget "_X" '((0 . "*POLYLINE") (43 . 0.)))) (foreach e (mapcar 'cadr (ssnamex s)) (entmod (append (entget e) '((8 . "vm_symb_kont"))))) ) (princ) ) You could also use this filter but it only guarantees that the first occurrence is = 0, others could be different. (setq s (ssget "_X" '((0 . "*POLYLINE") (40 . 0.))))

Here's another: (mapcar 'vl-princ-to-string (read (strcat "(" (vl-string-translate "|" " " "-1|NCC|2.54|30|0|Auto|0|1|0|2|0|0|2|0|False|0|0") ")") ) ) ;; ("-1" "NCC" "2.54" "30" "0" "AUTO" "0" "1" "0" "2" "0" "0" "2" "0" "FALSE" "0" "0")