Leaderboard

I make it the last 330 (assoc 330 (reverse.....))

I don't know how to ask user to Select a cell or test that a cell has been selected. so just do that before running this command. maybe someone can figure that out. ;;----------------------------------------------------------------------------;; ;; Delete current row from table _O = Operation _RO = delete ROw _Q = Quit (defun C:DCR(\) ;ask user to select a cell and wait for selection (setvar 'cmdecho 0) (command "_EditTableCell" "_O" "_RO" "_Q") (setvar 'cmdecho 1) (princ) )

As Steven stated earlier , it's the 330 GC and this is if the object associated with hatch object otherwise the 330 will be only one and related to the session where the object positioned / located.

(defun compare-elements (a b sortspec) ( (lambda (x y test) (if (and (equal x y ) (cdr sortspec)) (compare-elements a b (cdr sortspec)) (apply test (list x y)) ) ) (nth (cdar sortspec) a) (nth (cdar sortspec) b) (caar sortspec) ) ) (defun complex-sort (alst sortspec) (vl-sort alst '(lambda (a b) (compare-elements a b sortspec) ) ) ) (defun c:barcnt ( / ss lst tot ent atts att ent1 x mld obj) (setq ss (ssget "X" (list (cons 0 "MULTILEADER")(cons 8 "rebar Tag")(cons 410 "Model")))) (setq lst '()) (repeat (setq x (sslength ss)) (setq ent (entget (ssname ss (setq x (1- x))))) (setq atts (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 302)) ent))) (setq atts (list (nth 1 atts)(nth 2 atts)(nth 3 atts) (cdr (assoc -1 ent)))) (setq lst (cons atts lst)) ) (setq lst (complex-sort lst '((< . 0) (< . 1) (< . 2)))) (setq tot 1 x 0) (repeat (length lst) (setq ent1 (nth x lst)) (setq mld (vlax-ename->vla-object (nth 3 ent1))) (vlax-for obj (vla-item (vla-get-blocks (vla-get-document mld)) (vla-get-contentblockname mld)) (if (and (= "AcDbAttributeDefinition" (vla-get-objectname obj)) (= :vlax-false (vla-get-constant obj)) ) (progn (setq oid (vla-get-objectid obj)) (if (= (vla-get-tagstring obj) "POS") (vla-setblockattributevalue mld oid (rtos tot 2 0) ) ) ) ) ) (setq x (1+ x) tot (1+ tot)) ) (princ) ) (c:barcnt)

Typo fixed thanks Steven P.

I think it pulls from the drawing? so having that set before you make the block should work. https://help.autodesk.com/view/ACD/2024/ENU/?guid=GUID-A58A87BB-482B-4042-A00A-EEF55A2B4FD8 (setvar "insunits" 4) ;4 is mm if not did a little rewrite of this lisp for less spam ;;----------------------------------------------------------------------------------------;; ;; Update all Block definions units in drawing (defun C:blkunits (/ u untlst) (vl-load-com) (setq untlst '(("0" "Unitless) ("1" "Inches") ("2" "Feet") ("3" "Miles") ("4" "Millimeters") ("5" "Cenimeters") ("6" "Meters") ("7" "Kilometers") ("8" "Microinches") ("9" "Mils") ("10" "Yards") ("11" "Angstroms" ("12" "Nanometers") ("13" "Microns") ("14" "Decimeters") ("15" "Dekameters") ("16" "Hectometers" ("17" "Gigameters") ("18" "Astronomical") ("19" "Light Years" ("20" "Parsecs") ) (prompt "\nEnter Number to Change Block Units:") (prompt "\n0:Unitless, 1:Inches, 2:Feet, 3:Miles, 4:Millimeters, 5:Cenimeters") (prompt "\n6:Meters, 7:Kilometers, 8:Microinches, 9:Mils, 10:Yards") (prompt "\n11:Angstroms, 12:Nanometers, 13:Microns, 14:Decimeters, 15:Dekameters") (prompt "\n16:Hectometers ,17:Gigameters, 18:Astronomical, 19:Light Years, 20:Parsecs") (initget "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20") (setq u (getkword "\nEnter New Block Units <0>: ")) (cond ((= u nil) (vlax-for blk (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object))) (vlax-put-property blk "Units" 0) ) ) (t (vlax-for blk (vla-get-Blocks (vla-get-activedocument (vlax-get-acad-object))) (vlax-put-property blk "Units" u) ) ) ) (prompt (strcat "\nBlock Units Updated to " (cdr (assoc u untlst)))) (princ) ) *untested and written in notepad.

There is a formula for an area using points, so disregard the Z and it will give Plan area, if using CIV3D can get 3dfaces and work out the planar area of each 3d face. So the correct response is that there are 2 area solutions. Sorry forget where I found this, gives theory for XY points. (DEFUN C:FACEAREA.LSP ( / MYERROR OLDERROR SS EN ED P1 P2 P3 P4 AREA3P FAREA) ;;------- SUBROUTINES -------- (DEFUN AREA3P (P1 P2 P3 / A B C S) (SETQ A (DISTANCE P1 P2) B (DISTANCE P2 P3) C (DISTANCE P3 P1) S (* 0.5 (+ A B C)) ) (SQRT (* S (- S A) (- S B) (- S C) ) ) ) ;;=========== MAIN ROUTINE =============== (SETQ X 0) (SETQ TOTAREA 0.0) (SETQ SS (SSGET "X" '((0 . "3DFACE")))) (SETQ Y (SSLENGTH SS)) (IF (= SS NIL) (PROGN (GETSTRING "\NNO 3D FACES . PRESS ANY KEY WHEN READY ") (EXIT) ) ) (SETQ Y (SSLENGTH SS)) (REPEAT Y (SETQ EN (SSNAME SS X) ED (ENTGET EN) P1 (CDR (ASSOC 10 ED)) P2 (CDR (ASSOC 11 ED)) P3 (CDR (ASSOC 12 ED)) P4 (CDR (ASSOC 13 ED)) ) (SETQ FAREA (+ (AREA3P P1 P2 P3) (AREA3P P3 P4 P1))) (SETQ TOTAREA (+ TOTAREA FAREA)) (PRINC "\NAREA: ") (PRINC TOTAREA) (PRINC) (SETQ X (+ X 1)) ) ; REPEAT ) ;DEFUN (DEFUN C:3FA () (C:FACEAREA) ) (PRINC "FACEAREA LOADED. TYPE FACEAREA OR 3FA TO RUN.") (PRINC)

If a hatch is associated to an object then you can find it attached in the dxf codes of the host object between the reactor opened & closed brackets. Happy digging.

I use pdmode all the time as just remember 1 number.

The centre of the polyline is marked by a point, I assume the circle is your point style? Use the command ptype to adjust the point style, your point can be relative (the size changes as you zoom) or absolute (it won't change, gets bigger or smaller as you zoom) - set it to absolute and it will stay the same

Right, 3rd time I have written part 2 without posting...... So option 1 is to look at what I offered above, and looking through it I have included Lee Macs Unformat code - which of course does everything as expected (he is frustratingly good at this LISP stuff). You can just use that and apply it to 'text02' in the code. Dead easy but not quite right - it also unformats the new line characters (which I needed to do to do text join, mtext to dtext).. however I added this in below and commented it out just because. So use SMT2 (from above)_ instead which will remove colour, font, height and width - the main ones but not say, new lines, indents and a load of others Anyway, try this version and let me know how it works (defun StripString (String / cstr1 cstr2 nString cnt1 tstr1) ; Strips out formation for color, font, height and width. (setq cnt1 1) (while (and (setq cstr1 (substr String 1 1)) (> (strlen String) 0)) (if (= cstr1 "\\") (progn (setq cstr2 (substr String 2 1)) (if (member (strcase cstr2) '("C" "F" "H" "W")) (progn (while (/= (substr String cnt1 1) ";") (setq cnt1 (1+ cnt1)) ); while (setq String (substr String (1+ cnt1) (strlen String))) (setq cnt1 1) ); progn (progn (if nString (setq nString (strcat nString (substr String 1 1))) (setq nString (substr String 1 1)) ); if (setq String (substr String 2 (strlen String))) ); progn ); if ); progn (progn (if nString (setq nString (strcat nString (substr String 1 1))) (setq nString (substr String 1 1)) ); if (setq String (substr String 2 (strlen String))) ); progn ); if ); while (setq tstr1 (vl-string->list nString)) (if (and (not (member 92 tstr1)) (member 123 tstr1)) (setq tstr1 (vl-remove-if '(lambda (x) (or (= x 123) (= x 125))) tstr1)) ); if (vl-list->string tstr1) ) (defun getent ( aprompt / enta entb pt ) (princ "\n") (setq enta (car (nentsel aprompt))) (setq pt (cdr (assoc 10 (entget enta))) ) ;;;;fix for nenset or entsel requirements (setq entb (last (last (nentselp pt)))) (if (and (/= entb nil) (/= (type entb) 'real) ) (progn (if (wcmatch (cdr (assoc 0 (entget entb))) "ACAD_TABLE,*DIMENSION,*LEADER")(setq enta entb)) ) ) enta ) ;;;;;;;;;;;;;;;;;;;;;; (defun gettextdxfcodes ( entlist1 / dxfcodes) ;;DXF codes containing texts (setq dxfcodes (list 3 4 1 172 304)) ;;general (if (= (cdr (assoc 0 entlist1)) "DIMENSION") ;;If Dimension (progn (if (= (cdr (assoc 1 entlist1)) nil) (setq dxfcodes (list 4 42 172 304)) ;;No 3, add 42 for dimension value (if (and (= (wcmatch "<>" (cdr (assoc 1 entlist1))) nil)(= (wcmatch "\"\"" (cdr (assoc 1 entlist1))) nil) ) (setq dxfcodes (list 4 1 172 304)) ;;No 3, no 42 for dimension value (setq dxfcodes (list 4 1 42 172 304)) ;;Somehow combine 1 and 42 here, text replace and so on. ) ;end if ) ;end if ));end progn end if Dimensions (if (= (cdr (assoc 0 entlist1)) "MULTILEADER") ;;Is MultiLeader (progn (setq dxfcodes (list 304)) ));end progn end if Dimensions dxfcodes ) ;;;;;;;;;;;;;;;;;;;;;; (defun getfroment (ent listorstring entcodes / acount acounter mytext newtext stringtext) ;;get dotted pairs list (setq entlist (entget ent)) (setq enttype (cdr (assoc 0 entlist))) (setq acount 0) (while (< acount (length entlist)) (setq acounter 0) (while (< acounter (length entcodes)) (setq entcode (nth acounter entcodes)) (if (= (car (nth acount entlist)) entcode ) (progn (setq newtext (cdr (nth acount entlist))) (if (numberp newtext)(setq newtext (rtos newtext))) ;fix for real numbers (setq mytext (append mytext (list (cons (car (nth acount entlist)) newtext) )) ) );end progn );end if (setq acounter (+ acounter 1)) );end while (setq acount (+ acount 1)) );end while ;;get string from dotted pair lists (if (= listorstring "astring") ;convert to text (progn (if (> (length mytext) 0) (progn (setq acount 0) (setq temptext "") (while (< acount (length mytext)) (setq temptext (cdr (nth acount mytext)) ) (if (= (wcmatch temptext "LEADER_LINE*") nil)()(setq temptext "")) ;;Fix for Multileader 'Leader_Line' Text (if (= stringtext nil) (setq stringtext temptext) (setq stringtext (strcat stringtext temptext )) );end if (setq acount (+ acount 1)) );end while );end progn );end if (if (= stringtext nil)(setq stringtext "")) (setq mytext stringtext) );end progn );end if mytext ) ;;;;;;;;;;;;;;;;;;;;;; (defun gettextasstring ( enta entcodes / texta ) (if (= (getfroment enta "astring" entcodes) "") () (setq texta (getfroment enta "astring" entcodes)) ) texta ) ;;;;;;;;;;;;;;;;;;;;;; (defun dimensionfix ( ent1 entlist1 entlist2 text01 deldim / ) (if (= "DIMENSION" (cdr (assoc 0 entlist1))) (progn (if (= deldim "del") (txtcleardim ent1 entlist1) ) (if (and (/= "DIMENSION" (cdr (assoc 0 entlist2)))(= text01 nil))(setq text01 (gettextasstring ent1 (list 42)))) ) ) text01 ) ;;;;;;;;;;;;;;;;;;;;;; (defun deletelistitem (mylist itemtodelete / acounter nextitem) ;;delete a list item (setq acounter 0) (while (< acounter (length mylist) ) (setq nextitem (car mylist)) (setq mylist (cdr mylist)) ;;chop off first element (if (/= nextitem itemtodelete) (progn (setq mylist (append mylist (list nextitem))) ;stick next item to the back );end progn );end if (setq acounter (+ acounter 1)) );end while (setq nextitem (car mylist)) (setq mylist (cdr mylist)) (setq mylist (append mylist (list nextitem))) mylist ) ;;;;;;;;;;;;;;;;;;;;;; (defun deletedxfdata ( delent delentlist entcodes / acount acounter ) (setq acounter 0) (setq acount 0) (while (< acount (length entcodes)) (while (< acounter (length delentlist)) (if (= (car (nth acounter delentlist) ) (nth acount entcodes) ) (progn (entmod (setq delentlist (subst (cons (nth acount entcodes) "") (nth acounter delentlist) delentlist))) (entupd delent) ) ) (setq acounter (+ acounter 1)) );end while (setq acount (+ acount 1)) );end while delentlist ) ;;;;;;;;;;;;;;;;;;;;;; (defun removemtextformats (texta / acount mtextformat mtextformatting) ;;Just for mtext to text conversions: (setq texta (LM:UnFormat texta "" )) texta ) ;;-------------------=={ 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" . "[\\\\]({)|{") ("" . "5.0000LEADER_LINE2.0000") ) (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 ) ) ) ) (defun addinnewtext (newtext newentlist newent / ) (if (/= newtext nil) (progn (if (= (cdr (assoc 0 newentlist)) "DIMENSION") (progn ;;ent mod method, stops working at 2000-ish characters (entmod (setq newentlist (subst (cons 1 newtext) (assoc 1 newentlist) newentlist))) (entupd newent) );end progn ;Fix here for attdef or attrib to be dxf code 2 (progn ;;vla-put-text string for large text blocks + 2000 characters? (vla-put-textstring (vlax-ename->vla-object newent) newtext) );end progn ) ;end if ) ;end progn (princ "\nSource text is not 'text'") );end if ) ;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;; (defun c:txtjoin( / )(txtjoin "\n")) (defun c:txtjoint( / )(txtjoin "\t")) (defun c:txtjointsp( / )(txtjoin " ")) (defun c:txtjointnosp( / )(txtjoin "")) (defun c:txtjointdash( / )(txtjoin " - ")) (defun txtjoin( deliminator / oldvars entcodes ent1 ent2 entlist1 entlist2 text01 text02 text11 text12 entcodes1 entcodes2 acount acounter) ;;get text (setq ent1 (getent "\nSelect Retained Text : ")) (setq entlist1 (entget ent1)) (setq entcodes1 (gettextdxfcodes entlist1) ) ;list of ent codes containing text. (setq text01 (gettextasstring ent1 entcodes1) ) ;Text as string (setq entcodes1 (deletelistitem entcodes1 '1)) ;;loop till cancelled (while (setq ent2 (getent "\nSelect Text to Add (or escape): ")) (setq entlist1 (entget ent1)) (setq entcodes1 (gettextdxfcodes entlist1) ) ;list of ent codes containing text. (setq text01 (gettextasstring ent1 entcodes1) ) ;Text as string (setq entcodes1 (deletelistitem entcodes1 '1)) ;;get text 2 (setq entlist2 (entget ent2)) (setq entcodes2 (gettextdxfcodes entlist2)) ;;reset entcodes (setq text02 (gettextasstring ent2 entcodes2) ) ;; (setq text02 (removemtextformats text02)) ;; This line will strip all text formating according to Lee Macs Unformat inc. new line characters (setq entcodes2 (deletelistitem entcodes2 '1)) ;;delete text except for basic DXF code 1 ;;Needed if using entmod method, not VLA-PUT-TEXTSTRING method (setq entlist1 (deletedxfdata ent1 entlist1 entcodes1)) ;;fix for dimensions (Setq text01 (dimensionfix ent1 entlist1 entlist2 text01 "del")) ;;mtext to text formatting ;; This 'if' is not needed ig you are using the Lee Mac Unformat Line (commented out above) (if (and (= (cdr (assoc 0 entlist1)) "TEXT")(= (cdr (assoc 0 entlist2)) "MTEXT")) (setq text02 (removemtextformats text02)) (setq text02 (StripString text02)) ) ;;deliminator processing (if (and (= (cdr (assoc 0 entlist1)) "TEXT")(= deliminator "\n"))(setq deliminator " ")) (if (and (= (cdr (assoc 0 entlist1)) "TEXT")(= deliminator "\t"))(setq deliminator " ")) (setq texta (strcat text01 deliminator)) (setq texta (strcat texta text02)) ;;Delete text 2 (if (equal ent1 ent2) (princ "\n-- Text 1 and Text 2 are the same. Doubling text string. --") (if (= (cdr (assoc 0 entlist2)) "DIMENSION") ;;Retaining these texts () (entdel ent2) ) ) ;;;put in new text (addinnewtext texta entlist1 ent1) (command "redraw") (command "regen") ;;update it all );end while (princ) )

Couple of parts to my answer, first off this, SMT2 - strip Mtext without the dialogue box - just for reference for others. Credits to Strip Mtext are below the code,. (defun c:SMT2 () (c:StripMtext2)) ;_shortcut (defun c:StripMtext2 (/ ss ent1 ent2 tstr1 tstr2) ; Strips Mtext of certain formating (command "_.undo" "_end") (command "_.undo" "_group") (if (setq ss (ssget '((0 . "MTEXT")))) (while (/= (sslength ss) 0) (setq ent1 (ssname ss 0)) (setq ent2 (vlax-ename->vla-object ent1)) (setq tstr1 (vlax-get ent2 'TextString)) (setq tstr2 (StripString tstr1)) (vlax-put ent2 'TextString tstr2) (ssdel ent1 ss) ); while ); if (command "_.undo" "_end") (princ) ) (defun StripString (String / cstr1 cstr2 nString cnt1 tstr1) ; Strips out formation for color, font, height and width. (setq cnt1 1) (while (and (setq cstr1 (substr String 1 1)) (> (strlen String) 0)) (if (= cstr1 "\\") (progn (setq cstr2 (substr String 2 1)) (if (member (strcase cstr2) '("C" "F" "H" "W")) (progn (while (/= (substr String cnt1 1) ";") (setq cnt1 (1+ cnt1)) ); while (setq String (substr String (1+ cnt1) (strlen String))) (setq cnt1 1) ); progn (progn (if nString (setq nString (strcat nString (substr String 1 1))) (setq nString (substr String 1 1)) ); if (setq String (substr String 2 (strlen String))) ); progn ); if ); progn (progn (if nString (setq nString (strcat nString (substr String 1 1))) (setq nString (substr String 1 1)) ); if (setq String (substr String 2 (strlen String))) ); progn ); if ); while (setq tstr1 (vl-string->list nString)) (if (and (not (member 92 tstr1)) (member 123 tstr1)) (setq tstr1 (vl-remove-if '(lambda (x) (or (= x 123) (= x 125))) tstr1)) ); if (vl-list->string tstr1) ) Credits to: StripMtext Version 5.0b for AutoCAD 2000 and above Removes embedded Mtext formatting Copyright© Steve Doman and Joe Burke 2010 Look for new stable releases at: http://cadabyss.wordpress.com/ More information may also be found at: http://www.theswamp.org/

Probably long winded and maybe a there are more efficient ways to do this, try this, c:txtjoin - it should grab texts from most objects and join them together with a new line in between. Also on there is txtjointsp - which doesn't add a new line, separates texts with a space txtjoint - as above but uses a tab txtjoinnosp - no spaces and txtjoindash - with a dash between texts - Select the text to remain - Select the text to join to that - And loop to keep adding more to the 'remianing' text, escape to end / cancel (defun getent ( aprompt / enta entb pt ) (princ "\n") (setq enta (car (nentsel aprompt))) (setq pt (cdr (assoc 10 (entget enta))) ) ;;;;fix for nenset or entsel requirements (setq entb (last (last (nentselp pt)))) (if (and (/= entb nil) (/= (type entb) 'real) ) (progn (if (wcmatch (cdr (assoc 0 (entget entb))) "ACAD_TABLE,*DIMENSION,*LEADER")(setq enta entb)) ) ) enta ) ;;;;;;;;;;;;;;;;;;;;;; (defun gettextdxfcodes ( entlist1 / dxfcodes) ;;DXF codes containing texts (setq dxfcodes (list 3 4 1 172 304)) ;;general (if (= (cdr (assoc 0 entlist1)) "DIMENSION") ;;If Dimension (progn (if (= (cdr (assoc 1 entlist1)) nil) (setq dxfcodes (list 4 42 172 304)) ;;No 3, add 42 for dimension value (if (and (= (wcmatch "<>" (cdr (assoc 1 entlist1))) nil)(= (wcmatch "\"\"" (cdr (assoc 1 entlist1))) nil) ) (setq dxfcodes (list 4 1 172 304)) ;;No 3, no 42 for dimension value (setq dxfcodes (list 4 1 42 172 304)) ;;Somehow combine 1 and 42 here, text replace and so on. ) ;end if ) ;end if ));end progn end if Dimensions (if (= (cdr (assoc 0 entlist1)) "MULTILEADER") ;;Is MultiLeader (progn (setq dxfcodes (list 304)) ));end progn end if Dimensions dxfcodes ) ;;;;;;;;;;;;;;;;;;;;;; (defun getfroment (ent listorstring entcodes / acount acounter mytext newtext stringtext) ;;get dotted pairs list (setq entlist (entget ent)) (setq enttype (cdr (assoc 0 entlist))) (setq acount 0) (while (< acount (length entlist)) (setq acounter 0) (while (< acounter (length entcodes)) (setq entcode (nth acounter entcodes)) (if (= (car (nth acount entlist)) entcode ) (progn (setq newtext (cdr (nth acount entlist))) (if (numberp newtext)(setq newtext (rtos newtext))) ;fix for real numbers (setq mytext (append mytext (list (cons (car (nth acount entlist)) newtext) )) ) );end progn );end if (setq acounter (+ acounter 1)) );end while (setq acount (+ acount 1)) );end while ;;get string from dotted pair lists (if (= listorstring "astring") ;convert to text (progn (if (> (length mytext) 0) (progn (setq acount 0) (setq temptext "") (while (< acount (length mytext)) (setq temptext (cdr (nth acount mytext)) ) (if (= (wcmatch temptext "LEADER_LINE*") nil)()(setq temptext "")) ;;Fix for Multileader 'Leader_Line' Text (if (= stringtext nil) (setq stringtext temptext) (setq stringtext (strcat stringtext temptext )) );end if (setq acount (+ acount 1)) );end while );end progn );end if (if (= stringtext nil)(setq stringtext "")) (setq mytext stringtext) );end progn );end if mytext ) ;;;;;;;;;;;;;;;;;;;;;; (defun dimensionfix ( ent1 entlist1 entlist2 text01 deldim / ) (if (= "DIMENSION" (cdr (assoc 0 entlist1))) (progn (if (= deldim "del") (txtcleardim ent1 entlist1) ) (if (and (/= "DIMENSION" (cdr (assoc 0 entlist2)))(= text01 nil))(setq text01 (gettextasstring ent1 (list 42)))) ) ) text01 ) ;;;;;;;;;;;;;;;;;;;;;; (defun gettextasstring ( enta entcodes / texta ) (if (= (getfroment enta "astring" entcodes) "") () (setq texta (getfroment enta "astring" entcodes)) ) texta ) ;;;;;;;;;;;;;;;;;;;;;; (defun deletelistitem (mylist itemtodelete / acounter nextitem) ;;delete a list item (setq acounter 0) (while (< acounter (length mylist) ) (setq nextitem (car mylist)) (setq mylist (cdr mylist)) ;;chop off first element (if (/= nextitem itemtodelete) (progn (setq mylist (append mylist (list nextitem))) ;stick next item to the back );end progn );end if (setq acounter (+ acounter 1)) );end while (setq nextitem (car mylist)) (setq mylist (cdr mylist)) (setq mylist (append mylist (list nextitem))) mylist ) ;;;;;;;;;;;;;;;;;;;;;; (defun deletedxfdata ( delent delentlist entcodes / acount acounter ) (setq acounter 0) (setq acount 0) (while (< acount (length entcodes)) (while (< acounter (length delentlist)) (if (= (car (nth acounter delentlist) ) (nth acount entcodes) ) (progn (entmod (setq delentlist (subst (cons (nth acount entcodes) "") (nth acounter delentlist) delentlist))) (entupd delent) ) ) (setq acounter (+ acounter 1)) );end while (setq acount (+ acount 1)) );end while delentlist ) ;;;;;;;;;;;;;;;;;;;;;; (defun removemtextformats (texta / acount mtextformat mtextformatting) ;;Just for mtext to text conversions: (setq texta (LM:UnFormat texta "" )) texta ) ;;-------------------=={ 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" . "[\\\\]({)|{") ("" . "5.0000LEADER_LINE2.0000") ) (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 ) ) ) ) (defun addinnewtext (newtext newentlist newent / ) (if (/= newtext nil) (progn (if (= (cdr (assoc 0 newentlist)) "DIMENSION") (progn ;;ent mod method, stops working at 2000-ish characters (entmod (setq newentlist (subst (cons 1 newtext) (assoc 1 newentlist) newentlist))) (entupd newent) );end progn ;Fix here for attdef or attrib to be dxf code 2 (progn ;;vla-put-text string for large text blocks + 2000 characters? (vla-put-textstring (vlax-ename->vla-object newent) newtext) );end progn ) ;end if ) ;end progn (princ "\nSource text is not 'text'") );end if ) ;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;; (defun c:txtjoin( / )(txtjoin "\n")) (defun c:txtjoint( / )(txtjoin "\t")) (defun c:txtjointsp( / )(txtjoin " ")) (defun c:txtjointnosp( / )(txtjoin "")) (defun c:txtjointdash( / )(txtjoin " - ")) (defun txtjoin( deliminator / oldvars entcodes ent1 ent2 entlist1 entlist2 text01 text02 text11 text12 entcodes1 entcodes2 acount acounter) ;;get text (setq ent1 (getent "\nSelect Retained Text : ")) (setq entlist1 (entget ent1)) (setq entcodes1 (gettextdxfcodes entlist1) ) ;list of ent codes containing text. (setq text01 (gettextasstring ent1 entcodes1) ) ;Text as string (setq entcodes1 (deletelistitem entcodes1 '1)) ;;loop till cancelled (while (setq ent2 (getent "\nSelect Text to Add (or escape): ")) (setq entlist1 (entget ent1)) (setq entcodes1 (gettextdxfcodes entlist1) ) ;list of ent codes containing text. (setq text01 (gettextasstring ent1 entcodes1) ) ;Text as string (setq entcodes1 (deletelistitem entcodes1 '1)) ;;get text 2 (setq entlist2 (entget ent2)) (setq entcodes2 (gettextdxfcodes entlist2)) ;;reset entcodes (setq text02 (gettextasstring ent2 entcodes2) ) (setq entcodes2 (deletelistitem entcodes2 '1)) ;;delete text except for basic DXF code 1 ;;Needed if using entmod method, not VLA-PUT-TEXTSTRING method (setq entlist1 (deletedxfdata ent1 entlist1 entcodes1)) ;;fix for dimensions (Setq text01 (dimensionfix ent1 entlist1 entlist2 text01 "del")) ;;mtext to text formatting (if (and (= (cdr (assoc 0 entlist1)) "TEXT")(= (cdr (assoc 0 entlist2)) "MTEXT")) (setq text02 (removemtextformats text02)) ) ;;deliminator processing (if (and (= (cdr (assoc 0 entlist1)) "TEXT")(= deliminator "\n"))(setq deliminator " ")) (if (and (= (cdr (assoc 0 entlist1)) "TEXT")(= deliminator "\t"))(setq deliminator " ")) (setq texta (strcat text01 deliminator)) (setq texta (strcat texta text02)) ;;Delete text 2 (if (equal ent1 ent2) (princ "\n-- Text 1 and Text 2 are the same. Doubling text string. --") (if (= (cdr (assoc 0 entlist2)) "DIMENSION") ;;Retaining these texts () (entdel ent2) ) ) ;;;put in new text (addinnewtext texta entlist1 ent1) (command "redraw") (command "regen") ;;update it all );end while (princ) ) -EDIT- slight change to the code, it wasn't grabbing dimension texts quite right