Leaderboard

The best way is to use a template drawing a DWT. You have a blank dwg with all your text styles, dimension styles, blocks, layers and more all preset then save as a dwt. You can set every time you start cad your dwt is the default, same if you type NEW. Just type Option

This matches above. yes is for the backwards being checked. change to "" if not needed to be backwards (vl-cmdf "_.Style" "Kateb NaskhD" "naskhd" "" "" "" "Yes" "" "") Add to a lisp that is in your startup suite at is loaded on load.

Maybe something like this? (defun f ( l / n r y ) (foreach x l (setq n (if (= "true" (strcase (cadr x) t)) 1 0) x (car x) ) (if (setq y (vl-some '(lambda ( y ) (if (wcmatch x (strcat (car y) "*")) y)) r)) (setq r (subst (list (car y) (+ n (cadr y)) (1+ (caddr y))) y r)) (setq r (cons (list (substr x 1 (vl-string-position 95 x)) n 1.0) r)) ) ) (mapcar '(lambda ( x ) (list (car x) (apply '/ (cdr x)))) r) ) _$ (f lst) (("H603" 0.727273) ("H602" 1.0) ("H601" 1.0))

I just checked it out ,ran some samples and it works like a charm so far . thank you sooo much !!!!

Yeah sorry, I just typed a list but forgot they are both string elements @mhupp like your update, more efficient I have one other issue. There is no result if all ID's of 1 location are FALSE Then the percentage should be 0 I solved this with below code....is there a better way to do this? (foreach x base (setq a (car x)) (setq b (atof (rtos (cdr x) 2 1))) ;better way? (setq result (if (setq item (assoc a match)) (progn (cons (cons a (fix (* (/ (cdr item) b) 100))) result) ) ;added a progn! (cons (cons a 0) result) ;added this line! ) ) ) (reverse result)

As many of the drawings I work on are from others I don't always add my preferred Text Styles and added a drop-down to a ribbon panel to pick Text Styles to add to the current drawing if they're not already in the drawing for when they're needed. Code attached with a few macro examples at the bottom. ; Add New Text Style by Tom Beauford (defun NewStyle (TxtStyle Font / acadApp acadDoc styles objStyle FType) (setq acadApp (vlax-get-Acad-object) acadDoc (vla-get-ActiveDocument acadApp) styles (vla-get-textstyles acadDoc) objStyle (vla-add styles TxtStyle) FType (vl-filename-extension Font) ) (if(= ".ttf" FType)(setq Font (strcat "C:\\Windows\\Fonts\\" Font))) (setq Font (findfile Font)) (princ "\nFont = ")(princ Font)(princ) (vla-put-fontfile objStyle Font) (setvar 'textstyle TxtStyle) (princ) ) ;^C^C^P(or NewStyle (load "NewStyle.lsp"))(or(tblsearch "style" "Romans")(NewStyle "Romans" "romans.shx")) ;^C^C^P(or NewStyle (load "NewStyle.lsp"))(or(tblsearch "style" "Simplex")(NewStyle "Simplex" "simplex.shx")) ;^C^C^P(or NewStyle (load "NewStyle.lsp"))(or(tblsearch "style" "Arial")(NewStyle "Arial" "arial.ttf")) ;^C^C^P(or NewStyle (load "NewStyle.lsp"))(or(tblsearch "style" "Arial Bold")(NewStyle "Arial Bold" "arialbd.ttf")) ;^C^C^P(or NewStyle (load "NewStyle.lsp"))(or(tblsearch "style" "Arial Narrow")(NewStyle "Arial Narrow" "arialn.ttf")) ;^C^C^P(or NewStyle (load "NewStyle.lsp"))(tblsearch "style" "Swiss Lt BT")(NewStyle "Swiss Lt BT" "swissl.ttf"))

Have you tried @LeeMac Copy2Drawings lisp? http://www.lee-mac.com/copytodrawing.html just insert the text you want in one file and use the lisp then select the files the you need it will copy in the exact location.

thank you very much you are my hero

Nice Mhupp was looking for (vl-symbol-name (car x)) not sure why list is not (("H601_000001" "TRUE")("H601_000002" "TRUE") I am looking at different method sorting all in list and count duplicates, used this in up to 5 items in each sub list. Like lots of testing not behaving but in full code works perfect. Gsc nice to know about "_" will include if get working.

Thanx man, this works! I have changed the code a bit because I got an error on "vl-symbol-name" and (substr (vl-symbol-name (car x)) 1 4) is not always 4, but there is always an underscore in the string (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) ) ) (defun classify (lst find / x int a b lst-match lst-base item base match result) (vl-load-com) (foreach x lst (setq lst-base (cons (car (SplitStr (car x) "_")) lst-base)) ) (foreach x lst (if (eq (cadr x) find) (setq lst-match (cons (car (SplitStr (car x) "_")) lst-match)) ) ) (foreach x lst-base (setq base (if (setq item (assoc x base)) (subst (cons x (1+ (cdr item))) item base) (cons (cons x 1) base) ) ) ) (foreach x lst-match (setq match (if (setq item (assoc x match)) (subst (cons x (1+ (cdr item))) item match) (cons (cons x 1) match) ) ) ) (foreach x base (setq a (car x)) (setq b (atof (rtos (cdr x) 2 1))) ;better way? (setq result (if (setq item (assoc a match)) (cons (cons a (fix (* (/ (cdr item) b) 100))) result) ) ) ) (reverse result) )

Type appload this should pop up load style.lsp into the startup suit. contains above code. style.lsp

Test this out see if the commented entmod works. comment out the command line below to test. This first lists all xref layers. then checks them for AH or ME in their name. (defun C:color-xref (/ lay name match c) (vl-load-com) (vlax-for lay (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) (if (wcmatch (setq name (vla-get-name lay)) "*|*") (setq match (cons name match)) ) ) (setvar 'cmdecho 0) (foreach lay match (cond ((wcmatch lay "*AH*|*") (setq ent (entget (tblobjname "layer" lay))) (entmod (subst (cons 62 10) (assoc 62 ent) ent)) ) ((wcmatch lay "*ME*|*") (setq ent (entget (tblobjname "layer" lay))) (entmod (subst (cons 62 15) (assoc 62 ent) ent)) ) ) ) (setvar 'cmdecho 1) (princ) )

Since the string to be found is already being passed an argument to your function, you can 'hardcode' it by simply defining another function which evaluates your function with a hardcoded string, e.g.: (defun c:test ( ) (chkmtxtstr "MyTextString") ) Though, if you're happy with a case-sensitive match and assuming the MText content has no formatting and does not straddle multiple DXF group 3 entries, the code can become much simpler - consider the following: (defun find ( str ) (ssget "_X" (list '(0 . "MTEXT") (cons 1 (strcat "*" str "*")))) ) Since the above will return a selection set, you can call it in the following way: (defun c:test ( / sel ) (if (setq sel (find "YourString")) (command "_.change" sel "" "_p" "_la" "0" "_c" "ByLayer" "") ) (princ) )

And this version put the text in the middle of the polyline and makes the width the same as the counter. (defun c:numberpolylines ( / txthght sspolylines acount ssent txtpt ) (vl-load-com) ;;https://autocadtips1.com/2011/10/21/autolisp-mid-point-of-entire-polyline/ (defun MidPoly ( ename / entl en oname param hLen MidPt ) (setq entl (entget ename) en (cdr (assoc 0 entl)) ) ;end setq (setq oname (vlax-ename->vla-object ename) param (vlax-curve-getEndParam oname) hlen (* (vlax-curve-getDistAtParam oname param) 0.5) MidPt (vlax-curve-getPointAtDist oname hLen) ) ;end setq (vlax-release-object oname) MidPt ) ;end defun (defun createtext ( MyText TextPoint textheight / ) ;; a sub routine to create text. (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(8 . "0") '(100 . "AcDbText") (cons 10 TextPoint) (cons 40 textheight) (cons 1 MyText) '(50 . 0.0) '(41 . 1.0) '(51 . 0.0) ;; (cons 7 font) '(71 . 0) '(72 . 0) '(11 0.0 0.0 0.0) '(210 0.0 0.0 1.0) '(100 . "AcDbText") '(73 . 0) ));end list, entmake ) ;;end sub routine (setq txthght 2.5) ;; text height - can calculate this later if needed to make it relative to polyline lengths and so on (setq sspolylines (ssget '((0 . "LWPOLYLINE")) )) ;get selection set, filter it to only LWPolyline types (setq acount 0) ;;just a counter (while (< acount (sslength sspolylines)) ;; do a loop for the length of the selection set (sslength) (setq ssent (ssname sspolylines acount )) ;;get the nth entity details in the selection set (setq TxtPt (MidPoly ssent)) ;;calls MidPoly routine and gets the point result as TxtPt (setq txtpt (mapcar '+ (list 0 (/ (+ acount txthght) 2) 0) txtpt )) ;; offset txtpt for text position by x:0, y: half text height + line width, z:0 (setq acount (+ acount 1)) ;;increase count by 1. Increased here to make the displayed text start at 1 (command "pedit" ssent "w" acount "") ;;adjusts line width to the count (createtext (rtos acount) txtpt txthght) ;; run subroutine to create text ) (princ) ;; exit silently ) So over to you now, how you want to use this or amend to suit what you want

Upper Left = tag text 1 + each number text has 1 number Upper Right = tag text 1 + 1 number text has 2 numbers, get first number and print to prompt Lower Left = tag text 2 case, combine with comma Lower Right = countext2, countext with expression (vl-load-com) (defun c:countext ( / tot tagtxt ans texpression ss el en val val2 val2len resulttxt txt pt ) (setq tot 0.0) (setq tagtxt "") (setq ans "") (setq texpression "=") (while (= ans "") (setq ss (ssget ":L" '((0 . "TEXT")))) (setq el (entget (ssname ss 0))) (repeat (setq x (sslength ss)) (setq en (ssname ss (setq x (1- x)))) (setq val (cdr (assoc 1 (entget en)))) (setq val2 (LM:parsenumbers val)) (setq val2len (length val2)) (cond ((= val2len 0) (if (= (strlen tagtxt) 0) (setq tagtxt (strcat tagtxt (vl-princ-to-string val))) (setq tagtxt (strcat tagtxt ", " (vl-princ-to-string val))) ) (vla-delete (vlax-ename->vla-object en)) ) ((= val2len 1) (setq tot (+ tot (car val2))) (if (= (strlen texpression) 1) (setq texpression (strcat texpression (vl-princ-to-string (car val2)))) (setq texpression (strcat texpression "+" (vl-princ-to-string (car val2)))) ) (vla-delete (vlax-ename->vla-object en)) ) ((> val2len 1) (princ "\n it has 2 numbers, or more. i will select only the first number, please check this list - ") (princ val2) (setq tot (+ tot (car val2))) (if (= (strlen texpression) 1) (setq texpression (strcat texpression (vl-princ-to-string (car val2)))) (setq texpression (strcat texpression "+" (vl-princ-to-string (car val2)))) ) (vla-delete (vlax-ename->vla-object en)) ) ) ) (setq ans (getstring "\nSelection Finished [Y - Yes / SpaceBar - No] <SpaceBar>")) ) (princ "\n finished, result is = ") (princ tot) (princ "\n in expression = ") (princ texpression) (setq pt (getpoint "\nSelect Total Insertion Point : ")) (setq txt (if (zerop (rem tot 1.0)) (rtos tot 2 0) (rtos tot 2 3))) (setq resulttxt (strcat tagtxt " - " txt)) (rh:em_txt pt resulttxt (cdr (assoc 8 el)) (cdr (assoc 7 el)) (cdr (assoc 40 el)) (cdr (assoc 41 el)) ) (princ) ) (defun c:countext2 ( / tot tagtxt ans texpression ss el en val val2 val2len resulttxt txt pt ) (setq tot 0.0) (setq tagtxt "") (setq ans "") (setq texpression "=") (while (= ans "") (setq ss (ssget ":L" '((0 . "TEXT")))) (setq el (entget (ssname ss 0))) (repeat (setq x (sslength ss)) (setq en (ssname ss (setq x (1- x)))) (setq val (cdr (assoc 1 (entget en)))) (setq val2 (LM:parsenumbers val)) (setq val2len (length val2)) (cond ((= val2len 0) (if (= (strlen tagtxt) 0) (setq tagtxt (strcat tagtxt (vl-princ-to-string val))) (setq tagtxt (strcat tagtxt ", " (vl-princ-to-string val))) ) (vla-delete (vlax-ename->vla-object en)) ) ((= val2len 1) (setq tot (+ tot (car val2))) (if (= (strlen texpression) 1) (setq texpression (strcat texpression (vl-princ-to-string (car val2)))) (setq texpression (strcat texpression "+" (vl-princ-to-string (car val2)))) ) (vla-delete (vlax-ename->vla-object en)) ) ((> val2len 1) (princ "\n it has 2 numbers, or more. i will select only the first number, please check this list - ") (princ val2) (setq tot (+ tot (car val2))) (if (= (strlen texpression) 1) (setq texpression (strcat texpression (vl-princ-to-string (car val2)))) (setq texpression (strcat texpression "+" (vl-princ-to-string (car val2)))) ) (vla-delete (vlax-ename->vla-object en)) ) ) ) (setq ans (getstring "\nSelection Finished [Y - Yes / SpaceBar - No] <SpaceBar>")) ) (princ "\n finished, result is = ") (princ tot) (princ "\n in expression ") (princ texpression) (setq pt (getpoint "\nSelect Total Insertion Point : ")) (setq txt (if (zerop (rem tot 1.0)) (rtos tot 2 0) (rtos tot 2 3))) (setq resulttxt (strcat tagtxt " - " txt)) (rh:em_txt pt resulttxt (cdr (assoc 8 el)) (cdr (assoc 7 el)) (cdr (assoc 40 el)) (cdr (assoc 41 el)) ) (rh:em_txt (list (car pt) (- (cadr pt) (* 2 (cdr (assoc 40 el)))) (caddr pt)) texpression (cdr (assoc 8 el)) (cdr (assoc 7 el)) (cdr (assoc 40 el)) (cdr (assoc 41 el)) ) (princ) ) (defun rh:em_txt ( pt txt lyr sty tht xsf) (entmakex (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 10 pt) (cons 1 txt) (if lyr (cons 8 lyr)) (if sty (cons 7 sty)) (if tht (cons 40 tht)) (if xsf (cons 41 xsf)) );end_list );end_entmakex );end_defun ;; Parse Numbers - Lee Mac ;; Parses a list of numerical values from a supplied string. (defun LM:parsenumbers ( str ) ( (lambda ( l ) (read (strcat "(" (vl-list->string (mapcar '(lambda ( a b c ) (if (or (< 47 b 58) (and (= 45 b) (< 47 c 58) (not (< 47 a 58))) (and (= 46 b) (< 47 a 58) (< 47 c 58)) ) b 32 ) ) (cons nil l) l (append (cdr l) '(())) ) ) ")" ) ) ) (vl-string->list str) ) ) how about this countext - only result countext2 - with expression

V1.5 is the latest version of this application - the image of the dialog interface shown in that earlier post was created by that user and is not a real program.