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

PS: Someday you'll win one of those public tenders, and when that happens, I hope you'll come over here and have a coffee with one of us Good luck!

Hi @PGia I think this should meet your needs. I could say I wrote it from scratch just for you, but really, I also did it for myself. I had a good time revisiting old concepts. As I said, this is much easier to do with Map or Civil3D, creating topologies and manipulating them with the 'mnt*' functions. But writing this code has helped me prove that these tools can also be done in Lisp, with reasonably good results. The expressions are in my language. You'll have to translate them into yours. ;******************* G L A V C V S ******************* ;********************* F E C I T ********************* (defun c:spf>PGia (/ conj cj cjP ent n lstent en ex d pt i l lC lCs cE ltS ltV ltds s lSV actEtqs selR) (defun lSV (l / p r) (setq ltS (cons (list (setq s (vlax-ename->vla-object (car l))) (cadr l)) ltS) lCs (cons (list s (last l)) lCs)) (foreach x (reverse (cdr l)) (if p (if (not (member x ltds));ltds es la lista de los ya tocados (if (setq r (assoc p ltV)) (setq ltV (subst (list (car r) (+ (cadr r) (vla-get-area x))) r ltV) ltds (cons x ltds));ltV es una lista en que se asocia el identificador de las lineas contenedoras con la suma de la áreas de las contenidas (setq ltV (cons (list p (vla-get-area x)) ltV) ltds (cons x ltds)) ) ) ) (setq p x) ) ) (defun actEtqs (/ a b c e p pc l et tx) (foreach v (reverse ltS) (setq e (car v) p (cadr v) pc (last v)) (if (= (vla-get-layer e) "US") (setq l (cadr (assoc e lCs)) tx (vl-some '(lambda (x) (if (equal (cadr x) l) (vla-get-textstring (car x)))) ltS)) (setq tx nil) ) (if (/= (vla-get-layer e) "GEN") (vla-put-color p 6)) (vla-put-textstring e (strcat (if tx (strcat tx "-") "") (vla-get-textstring e) ":" (rtos (- (vla-get-area p) (if (setq a (assoc p ltV)) (cadr a) 0)) 2 2)) ) ) ) (defun selR (p / r s l lt en ex cj n o r4 f) (defun r2+ (p l r / i b) (vl-some '(lambda(g) (= 2 (setq r (if (foreach a (cons (last l) l) (if b (if (inters p (polar p g d) b (setq b a)) (setq i (not i))) (setq b a)) i) (+ r 1) r)))) '(0 1.5708 3.141592 4.71239) ) ) (if (setq cj (ssget "_F" (list p (list (car p) (+ (cadr p) (getvar "viewsize")))) (list '(0 . "LWP*") (cons 8 "PRMTR") '(-4 . "&=") '(70 . 1)) ) ) (while (setq e (ssname cj (setq n (if n (1+ n) 0)))) (if (r2+ p (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget e))) 0) (progn (setq l (cons (vlax-ename->vla-object e) l)) (if (ssmemb e cjP) (ssdel e cjP))) ) ) ) (if l (vl-sort l '(lambda (a b) (< (vla-get-Area a) (vla-get-Area b))))) ) (setq en (getvar "extmin") ex (getvar "extmax") n -1 d (max (- (car ex) (car en)) (- (cadr ex) (cadr en))) ) (vla-zoomExtents (vlax-get-acad-object)) (setq cjP (ssget "x" (list '(0 . "LWP*") (cons 8 "PRMTR") '(-4 . "&=") '(70 . 1)))) (if (setq conj (ssget "_X" '((0 . "TEXT") (8 . "GEN,US")))) (while (setq ent (ssname conj (setq n (1+ n)))) (setq lstent (entget ent) pt (cdr (assoc 10 lstent))) (if (setq l (selR pt)) (lSV (cons ent l)) (princ (strcat "\n*** Etiqueta " (cdr (assoc 1 lstent)) " huerfana"))) ) ) (if (> (sslength cjP) 0) (alert "ATENCION: Hay polilíneas sin asignar")) (alert (strcat "Numero de perímetros procesados: " (itoa (length ltS)))) (actEtqs) (princ) )

See attached code. 1. run the lisp in paper space. 2. the lisp prompt you to select a point on the block IN PAPER SPACE!! - click on the block. 3. click on the start point of the MLeader arrow - you are in paper space, no wories... 4. place the MLeader. 5. if you want to label another block go ahead. 6. to exit hit escape key or mouse right click. EDIT: the lisp works in model space as well. (defun c:MLeaderWBlname( / *error* temperr osnp tm tagname ptms ss ensel obj obj1 nam);ptps ptps1 (setq temperr *error*);store *error* (setq *error* trap1);re-assign *error* (setq osnp (getvar "OSMODE")) (setvar "OSMODE" 0) (setq tm (getvar "TILEMODE")) (princ "Select object in paper space,select start point of MLeader,exit with esc'") (while 1 (if (= tm 0);if in paper space (progn (getpoint) ;;get point in paper space on the target object (command "._MSPACE") (setq ptms (cadr (grread t)));;get the point where the cursor is on the target object in model space (setq ss (ssget ptms));;selction set of the object crossing the ptms point (setq obj(ssname ss 0)) (command "._PSPACE") );progn (progn ;in model space (setq ensel (entsel "\nSelect Block: ")) ;select the block object to copy (setq obj (car ensel)) ;set the block object to varaible );progn );if (setq obj1 (vlax-ename->vla-object obj)) (setq nam (vlax-get-property obj1 (if (vlax-property-available-p obj1 'effectivename) 'effectivename 'name ) ) ) (command "_mleader" "H" pause pause nam) );end while (setq *error* temperr) (princ) ) (defun trap1 (errmsg) (command "._PSPACE") (SETVAR "OSMODE" osnp) (princ) )

I saw an interesting math problem. A group of mice find a round cheese and start eating it. At first, they spread evenly around the perimeter of the cheese and start eating at the same time, at the same speed. The first mouse will advance in the direction of the second, the second mouse will advance in the direction of the third, ...the last mouse will advance in the direction of the first. Draw the cheese after the mice meet. Here are my cheeses eaten by 3, 5 and 10 mice. And here is the Lisp I wrote. (defun c:cheese() (setq mice 10 micePoz nil ang1 (/ PI 0.5 mice) ang 0 R 100.0 seg 0.1 continue T) (entmake (list (cons 0 "CIRCLE") (list 10 0.0 0.0) (cons 40 R) (cons 62 2))) (repeat mice (setq micePoz (cons (list (* R (sin (setq ang (+ ang ang1)))) (* R (cos ang))) micePoz)) ) (While continue (setq i -1 nextPoz nil) (repeat mice (setq i (1+ i) j (rem (1+ i) mice)) (setq m1 (nth i micePoz) m2 (nth J micePoz) dist (distance m1 m2) p (/ seg dist)) (setq nextPoz (cons (list (+ (car m1) (* p (- (car m2) (car m1)))) (+ (cadr m1) (* p (- (cadr m2) (cadr m1))))) nextPoz)) ) (setq nextPoz (reverse nextPoz) i -1) (repeat mice (entmake (list (cons 0 "LINE") (cons 10 (nth (setq i (1+ i)) micePoz)) (cons 11 (nth i nextPoz)) (cons 62 (+ 3 (* i 1))))) ) (setq micePoz nextPoz nextPoz nil) (setq continue (> dist (* 1 seg))) ) ) Finally, here's a mouse looking for the next cheese. (defun c:mouse() (setq db (list -5.5 -0.15 1.0 3.8 5.9 -5.3 -2.0 1.6 1.1 2.3 -20.8 -18.4 19.3 1.0 1.3 -19.2 -8.9 11.4 0.7 1.1 -30.2 -16.6 25.2 0.7 0.8 -5.1 -17.9 14.2 1.4 1.7 11.8 -68.0 69.2 1.8 1.88 39.3 -121.0 127.0 1.9 1.9 -2.4 1.6 2.5 5.9 0.6 0.6 3.6 1.2 2.5 3.7 2.7 2.2 3.8 2.1 2.5 12.0 -225.6 226.7 1.6 1.6 13.4 -3.4 4.6 1.1 1.6 15.6 1.3 0.6 4.3 5.1 15.4 1.6 0.9 5.1 0.9 17.1 3.8 1.8 3.1 4.1 16.1 3.9 0.9 2.0 3.1 15.8 4.6 0.1 5.7 2.0 17.0 3.8 1.4 2.6 4.3 16.1 1.4 1.3 0.0 1.2 15.7 1.3 1.6 4.7 0.0 16.0 6.7 7.0 4.5 4.7 13.17 -5.1 5.1 1.3 2.1 13.7 -7.4 6.0 2.6 2.7 10.4 -5.8 2.2 2.7 3.2 8. -5.9 0.3 3.2 4.9 8.4 -5.4 0.8 4.9 5.9 14.6 -6.1 5.5 3.0 3.1 9.7 -5.7 0.6 3.1 4.5 9.7 -5.8 0.55 4.5 0.2 11.3 -4.9 1.4 3.3 4.2 10.8 -5.8 0.4 4.2 0.34 8.4 -6.7 2.9 0.4 0.9 11.8 -2.2 2.7 3.7 4.1 -1.9 -1.2 4.0 5.0 5.9 -4.1 6.3 11.7 4.5 5.0 -0.5 4.9 7.0 2.9 3.4 -5.9 6.1 1.4 0.5 2.9 -7.8 5.0 3.7 6.2 0.5 -8.4 -3.4 2.8 3.5 0.2 -9.1 -3.6 2.1 2.7 3.5 62.2 -41.66 82.9 2.6 2.7 -3.5 -0.6 5.4 1.7 2.6 -1.8 -10.3 15.8 1.5 1.7 -5.2 -5.9 1.9 5.4 6.1 -2.7 -8.6 1.8 2.3 2.9 -4.2 -8.3 0.3 2.9 5.0 -4.2 -8.2 0.4 5.0 6.0 -2.6 -8.3 1.3 2.7 3.6 -3.3 -8.7 0.4 3.6 0.1 -1.3 -8.1 1.7 2.8 3.6 -2.7 -8.8 0.2 3.6 5.8 -3.5 -8.3 1.2 5.8 6.3 2.5 -8.0 4.9 3.1 3.2 -2.0 -8.3 0.4 3.2 5.3 -2.0 -8.3 0.5 5.3 0.7 0.6 -5.8 3.2 3.7 3.9 -1.2 -6.9 1.0 2.9 3.7 0.5 4.5 11.4 4.2 4.8 1.7 -7.1 0.2 0.2 1.7 1.1 -7.2 0.9 5.0 0.2 0.2 -2.7 5.5 4.7 4.9 0.4 -9.4 1.3 1.6 2.8 -0.6 -9.1 0.27 2.8 4.8 -0.6 -8.7 0.7 4.8 5.4 1.2 -9.8 1.5 2.1 2.7 0.3 -9.4 0.4 2.7 5.3 -1.1 -7.4 2.9 5.3 5.6 2.4 -9.45 1.2 2.2 3.3 1.5 -9.67 0.4 3.2 6.2 2.9 -9.6 1.0 2.2 3.2 2.5 -9.0 0.3 6.0 2.2 2.9 -9.1 0.2 2.9 0.3 5.4 -8.5 2.4 1.9 3.4 2.9 -2.0 4.6 5.1 0.56 0.8 3.1 3.0 4.6 5.9 -2.3 4.5 6.4 5.8 0.1 2.4 4.7 1.7 0.1 1.9 6.3 -6.7 13.8 1.9 2.1 0.0 3.1 2.2 2.1 2.7 -11.7 -3.86 1.5 5.5 1.0 4.6 0.3 6.1 4.8 1.8) ) (setq i 0) (repeat 82 (entmake (list (cons 0 "ARC") (list 10 (nth i db) (nth (1+ i) db)) (cons 40 (nth (+ 2 i) db)) (cons 50 (nth (+ 3 i) db)) (cons 51 (nth (+ 4 i) db)))) (setq i (+ 5 i)) ) ) Do you have other solutions for this cheese problem?

I don't think the person with the problem should get any credit..... Big, Gigantic, Massive kudo's to Steven P here..... (and also to Lee, ronjonp, BigAl, mhupp, Tharwat, hanhphuc, SLW210, rlx, and SO MANY MORE who have helped me in the past!!!!!!)

A big hint. With real big table creation you sit there and watch the wheels turning but if you set (vla-put-regeneratetablesuppressed obj :vlax-true) the table will be made in like a second or 2 for say 500 rows. You need to set the value to false to see result. So making a new table is possible.

Here is my solution. (defun c:3Dppad ( / js pad total_horizontal_length l_pt pt_start pt_end inter_dist n start_z end_z ratio num_points) (princ "\nOdaberite 3D poliliniju.") ;; Selektovanje 3D polilinije (setq js (ssget '((0 . "POLYLINE")))) ; Samo polilinije ;; Proverava da li je izbor prazan (if (not js) (progn (princ "\nNeprazan ili nevalidan izbor polilinije!") (exit) ;; Izlazi iz komande ) ) ;; Dobijanje VLA objekta za odabranu poliliniju (setq ename (vlax-ename->vla-object (ssname js 0))) ;; Računanje ukupne horizontalne dužine polilinije (X, Y ravnina) (setq total_horizontal_length 0.0) (setq num_points (fix (vlax-curve-getEndParam ename))) ;; Ukupan broj verteksa ;; Provera da li polilinija ima verteksa (if (<= num_points 0) (progn (princ "\nPolilinija nema validne vertekse!") (exit) ) ) ;; Petlja za računanje horizontalne dužine (setq n 0) (while (< n num_points) (setq pt_start (vlax-curve-getPointAtParam ename (float n)) ;; Početna tačka na n-tom verteksu pt_end (vlax-curve-getPointAtParam ename (float (1+ n))) ;; Sledeća tačka ;; Provera da li su tačke validne inter_dist 0.0 ) ;; Ako su obe tačke validne (if (and pt_start pt_end) (progn ;; Izračunaj horizontalnu distancu (setq inter_dist (distance (list (car pt_start) (cadr pt_start)) (list (car pt_end) (cadr pt_end))) ;; Horizontalna distanca total_horizontal_length (+ total_horizontal_length inter_dist)) ;; Dodaj horizontalnu distancu ;; Ispis horizontalne dužine do trenutnog verteksa (princ (strcat "\nHorizontalna dužina do verteksa " (itoa n) " je: " (rtos total_horizontal_length 2 2) " jedinica.")) ) ) (setq n (1+ n)) ) ;; Dobavljanje željenog nagiba od korisnika (setq pad (getreal "\nUnesite željeni pad (slope) u procentima: ")) (setq pad (/ pad -100.0)) ;; Pretvaranje u decimalni oblik ;; Računanje visine na osnovu nagiba (pad * ukupna horizontalna dužina) (setq start_z (getreal "\nUnesite Z koordinatu početne tačke: ")) (setq end_z (+ start_z (* pad total_horizontal_length))) ;; Z koordinata poslednje tačke ;; Kreiranje liste za nove tačke (setq l_pt '()) ;; Interpolacija visina između prve i poslednje tačke (setq n 0) (setq horizontal_length_so_far 0.0) ;; Horizontalna dužina do trenutnog verteksa (while (<= n num_points) (setq pt_start (vlax-curve-getPointAtParam ename (float n))) ;; Dohvata n-tu tačku ;; Provera validnosti tačke (if pt_start (progn ;; Sprečavanje deljenja sa nulom (if (>= num_points 0) (setq ratio (/ horizontal_length_so_far total_horizontal_length)) ;; Izračunaj ratio (setq ratio 0.0) ) ;; Interpolacija Z koordinate uzimajući u obzir horizontalnu dužinu do verteksa (setq interpolated_z (+ start_z (* ratio (- end_z start_z)))) ;; Interpolacija Z ;; Dodaj novu tačku s novom Z koordinatom u listu (setq l_pt (cons (list (car pt_start) (cadr pt_start) interpolated_z) l_pt)) ) ) ;; Dodaj horizontalnu dužinu trenutnog verteksa (if (<= n (1- num_points)) ;; Osigurati da ne idemo van granica (setq next_pt_start (vlax-curve-getPointAtParam ename (float (1+ n))) ;; Sledeća tačka inter_dist (distance (list (car pt_start) (cadr pt_start)) (list (car next_pt_start) (cadr next_pt_start))) ;; Horizontalna distanca horizontal_length_so_far (+ horizontal_length_so_far inter_dist)) ;; Akumuliraj horizontalnu dužinu ) (setq n (1+ n)) ) ;; Kreiranje nove 3D polilinije sa zadatim nagibom (vla-put-Layer (vlax-invoke (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))) 'Add3DPoly (apply 'append (reverse l_pt))) (vla-get-Layer (ssname js 0))) (princ "\nNova 3D polilinija je uspešno kreirana sa zadatim nagibom.") (princ) ;; Završavanje funkcije bez greške )

that was is a galaxy far far away , when my hair wasn't turning gray yet ... I actually totally forgotten about this one hahaha , thanx for reminding me good thing about dementia is I can watch Star Trek over and over again https://www.cadtutor.net/forum/topic/65061-happy-easter/#comment-536101

This one works on my system: (command "shell" "chrome https://www.nhm.ac.uk/discover/dino-directory/name/name-az-all.html") The "explorer" opens the windows explorer.

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

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

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

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

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