asos2000 Posted June 30, 2009 Share Posted June 30, 2009 Is there a lisp do this job To select the text (and Mtext too) and but each string in a single line and but next to it the count of that string For example I have this text in a drawing T12-100 T10-100 T16-100 T12-150 And the same values repeated (in the same file) The lisp collects the text string and count how many time repeated each text/Mtext Text Repetition T12-100 5 T10-100 6 T16-100 16 T12-150 7 And so on Hasan Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 30, 2009 Share Posted June 30, 2009 Try this: (defun c:tsel (/ ss lst tss olst ofile) (vl-load-com) (if (setq ss (ssget '((0 . "*TEXT")))) (progn (setq lst (mapcar (function (lambda (x) (vla-get-TextString (vlax-ename->vla-object x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))) (foreach str (unique lst) (if (setq tss (ssget "_X" (list '(0 . "*TEXT") (cons 1 str)))) (setq olst (cons (cons str (sslength tss)) olst)) (setq olst (cons (cons str 0.) olst)))) (setq ofile (open (strcat (getvar "DWGPREFIX") (substr (getvar "DWGNAME") 1 (- (strlen (getvar "DWGNAME")) 4)) "-StrCnt.txt") "a")) (mapcar (function (lambda (x) (write-line (strcat (car x) "\t" (vl-princ-to-string (cdr x))) ofile))) olst) (close ofile) (princ "\n<< Strings Written to File >>")) (princ "\n<< Nothing Selected >>")) (princ)) ;; CAB (defun unique (lst / result) (reverse (while (setq itm (car lst)) (setq lst (vl-remove itm lst) result (cons itm result))))) Will write the result to file. Quote Link to comment Share on other sites More sharing options...
asos2000 Posted June 30, 2009 Author Share Posted June 30, 2009 whats great Could be the result in a table in the same file Regards Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 30, 2009 Share Posted June 30, 2009 whats great Could be the result in a table in the same file Regards Wasn't sure if '06 had tables, but yes, this could be done; Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted June 30, 2009 Share Posted June 30, 2009 Ok try this: (defun c:tsel (/ *error* doc spc ss bPt lst tss olst tblObj i) (vl-load-com) (defun *error* (msg) (and doc (vla-EndUndoMark doc)) (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")) (princ (strcat "\n<< Error: " msg " >>"))) (princ)) (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object)) spc (if (zerop (vla-get-activespace doc)) (if (= (vla-get-mspace doc) :vlax-true) (vla-get-modelspace doc) (vla-get-paperspace doc)) (vla-get-modelspace doc)) i 2) (cond ((eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar "CLAYER")))))) (princ "\n<< Current Layer Locked >>")) (t (if (and (setq ss (ssget '((0 . "*TEXT")))) (setq bPt (getpoint "\nSelect Point for Table: "))) (progn (vla-StartUndoMark doc) (setq lst (mapcar (function (lambda (x) (vla-get-TextString (vlax-ename->vla-object x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))) (foreach str (unique lst) (if (setq tss (ssget "_X" (list '(0 . "*TEXT") (cons 1 str)))) (setq olst (cons (cons str (sslength tss)) olst)) (setq olst (cons (cons str 0.) olst)))) (setq tblObj (vla-addTable spc (vlax-3D-point bPt) (+ 2 (length olst)) 2 (* 1.5 (getvar "DIMTXT")) (* (apply 'max (mapcar 'strlen (append '("String") (apply 'append (mapcar (function (lambda (x) (list (car x) (rtos (cdr x) 2 0)))) olst))))) 1.5 (getvar "DIMTXT")))) (vla-setText tblObj 0 0 "String Counter") (vla-setText tblObj 1 0 "String") (vla-setText tblObj 1 1 "Count") (foreach x (vl-sort olst (function (lambda (a b) (< (car a) (car b))))) (vla-setText tblObj i 0 (car x)) (vla-setText tblObj i 1 (rtos (cdr x) 2 0)) (setq i (1+ i))) (vla-EndUndoMark doc))))) (princ)) ;; CAB (defun unique (lst / result) (reverse (while (setq itm (car lst)) (setq lst (vl-remove itm lst) result (cons itm result))))) Quote Link to comment Share on other sites More sharing options...
asos2000 Posted July 1, 2009 Author Share Posted July 1, 2009 WOW, that what im looking for. Thanks LEE But there are 2 points - Could the lisp use the default text style (not standard)? - STRING & COUNT words in the table come in 2 lines when the text string is one or tow digits. mmmm, while typing there are 2 more things came in my mind - Could I choose the table style (there are stored table styles in the file)? - Could the lisp collect the text/attribute in the blocks? Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted July 1, 2009 Share Posted July 1, 2009 But there are 2 points - Could the lisp use the default text style (not standard)? - STRING & COUNT words in the table come in 2 lines when the text string is one or tow digits. mmmm, while typing there are 2 more things came in my mind - Could I choose the table style (there are stored table styles in the file)? - Could the lisp collect the text/attribute in the blocks? The LISP uses the default TableStyle - so just set the table style how you want it. As for the STRING and COUNT coming in as 2 lines, I thought I had accounted for this, but I can increase the column width if necessary. As for the blocks - will you still be selecting them? Quote Link to comment Share on other sites More sharing options...
asos2000 Posted July 1, 2009 Author Share Posted July 1, 2009 As for the blocks, No need for still be selecting them. I creat that macro but not working -table;;;style;EC-TABLE-100;;stringcounter; EC-TABLE-100 is a tablestyle Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted July 1, 2009 Share Posted July 1, 2009 - Could the lisp collect the text/attribute in the blocks? I can maybe collect attributes, but text is annoying to get out of blocks - are you just wanting the LISP to scour every block in the drawing? Quote Link to comment Share on other sites More sharing options...
asos2000 Posted July 1, 2009 Author Share Posted July 1, 2009 Not every block but selected blocks Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted July 1, 2009 Share Posted July 1, 2009 This will collect all matching attributes in blocks also: (defun c:tsel (/ *error* doc spc ss bPt cnt lst tss olst tblObj cAtt i) (vl-load-com) (defun *error* (msg) (and doc (vla-EndUndoMark doc)) (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")) (princ (strcat "\n<< Error: " msg " >>"))) (princ)) (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object)) spc (if (zerop (vla-get-activespace doc)) (if (= (vla-get-mspace doc) :vlax-true) (vla-get-modelspace doc) (vla-get-paperspace doc)) (vla-get-modelspace doc)) i 2) (cond ((eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar "CLAYER")))))) (princ "\n<< Current Layer Locked >>")) (t (if (and (setq ss (ssget '((0 . "*TEXT")))) (setq bPt (getpoint "\nSelect Point for Table: "))) (progn (vla-StartUndoMark doc) (setq lst (mapcar (function (lambda (x) (vla-get-TextString (vlax-ename->vla-object x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))) (foreach str (unique lst) (setq cnt 0.) (if (setq tss (ssget "_X" (list '(-4 . "<OR") '(-4 . "<AND") '(0 . "*TEXT") (cons 1 str) '(-4 . "AND>") '(-4 . "<AND") '(0 . "INSERT") '(66 . 1) '(-4 . "AND>") '(-4 . "OR>")))) (foreach Obj (mapcar 'vlax-ename->vla-object (mapcar 'cadr (ssnamex tss))) (cond ((eq "AcDbBlockReference" (vla-get-ObjectName Obj)) (foreach Att (append (vlax-safearray->list (vlax-variant-value (vla-getAttributes Obj))) (if (not (vl-catch-all-error-p (setq cAtt (vl-catch-all-apply 'vlax-safearray->list (list (vlax-variant-value (vla-getConstantAttributes Obj))))))) cAtt)) (if (eq Str (vla-get-TextString Att)) (setq cnt (1+ cnt))))) (t (setq cnt (1+ cnt)))))) (setq oLst (cons (cons str cnt) oLst))) (setq tblObj (vla-addTable spc (vlax-3D-point bPt) (+ 2 (length olst)) 2 (* 1.5 (getvar "DIMTXT")) (* (apply 'max (mapcar 'strlen (append '("String") (apply 'append (mapcar (function (lambda (x) (list (car x) (rtos (cdr x) 2 0)))) olst))))) 2.0 (getvar "DIMTXT")))) (vla-setText tblObj 0 0 "String Counter") (vla-setText tblObj 1 0 "String") (vla-setText tblObj 1 1 "Count") (foreach x (vl-sort olst (function (lambda (a b) (< (car a) (car b))))) (vla-setText tblObj i 0 (car x)) (vla-setText tblObj i 1 (rtos (cdr x) 2 0)) (setq i (1+ i))) (vla-EndUndoMark doc))))) (princ)) ;; CAB (defun unique (lst / result) (reverse (while (setq itm (car lst)) (setq lst (vl-remove itm lst) result (cons itm result))))) Quote Link to comment Share on other sites More sharing options...
asos2000 Posted July 1, 2009 Author Share Posted July 1, 2009 Thanks LEE This version not working I Dont know why is this But previous version is more than enough could u plz look at this thread http://www.cadtutor.net/forum/showthread.php?t=36452 Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted July 1, 2009 Share Posted July 1, 2009 The above version works for me - You should be able to select all your text/Mtext, and the strings will be counted for text/Mtext/Attribs Quote Link to comment Share on other sites More sharing options...
The Buzzard Posted July 1, 2009 Share Posted July 1, 2009 The above version works for me - You should be able to select all your text/Mtext, and the strings will be counted for text/Mtext/Attribs Lee, Would you have a version of this program that will display all occurences of an attribute including duplicate entries of an attribute to a file? Thanks, The Buzzard Quote Link to comment Share on other sites More sharing options...
stevesfr Posted July 1, 2009 Share Posted July 1, 2009 The above version works for me - You should be able to select all your text/Mtext, and the strings will be counted for text/Mtext/Attribs Its not grabbing the attribs for me. I'll send dwg if U like. Steve Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted July 1, 2009 Share Posted July 1, 2009 Its not grabbing the attribs for me. I'll send dwg if U like.Steve Oh right - it is case-sensitive if that makes a difference.. Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted July 1, 2009 Share Posted July 1, 2009 Lee, Would you have a version of this program that will display all occurences of an attribute including duplicate entries of an attribute to a file? Thanks, The Buzzard I don't have one currently, but I could make one Quote Link to comment Share on other sites More sharing options...
The Buzzard Posted July 1, 2009 Share Posted July 1, 2009 I don't have one currently, but I could make one Not very important Lee, But when you get time. This is a great idea to spot duplicate entries of numbers, Sort of a check blocks for any duplicate errors in a drawing. Again Great Idea! The Buzzard Quote Link to comment Share on other sites More sharing options...
asos2000 Posted March 22, 2010 Author Share Posted March 22, 2010 even I select text or not the lisp cout all text in the drawing Quote Link to comment Share on other sites More sharing options...
Lee Mac Posted March 22, 2010 Share Posted March 22, 2010 Give this a shot guys: ;; Counts all instances of selected strings, looks in ;; Text, MText and Block Attributes. (defun c:StringCount (/ *error* BPT CNT DOC ENT I LST OLST SI SPC SS STR TBLOBJ UFLAG) (vl-load-com) ;; Lee Mac ~ 22.03.10 (defun *error* (msg) (and uFlag (vla-EndUndoMark doc)) (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **"))) (princ)) (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object)) spc (if (or (eq AcModelSpace (vla-get-ActiveSpace doc)) (eq :vlax-true (vla-get-MSpace doc))) (vla-get-ModelSpace doc) (vla-get-PaperSpace doc)) i 1) (cond ( (eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar "CLAYER")))))) (princ "\n<< Current Layer Locked >>")) ( (and (setq si -1 ss (ssget '((0 . "TEXT,MTEXT")))) (setq bPt (getpoint "\nSelect Point for Table: "))) (while (setq ent (ssname ss (setq si (1+ si)))) (if (not (vl-position (setq str (cdr (assoc 1 (entget ent)))) lst)) (setq lst (cons str lst)))) (foreach str lst (setq cnt (sslength (ssget "_X" (list (cons 0 "TEXT,MTEXT") (cons 1 str))))) (if (setq si -1 ss (ssget "_X" (list (cons 0 "INSERT") (cons 66 1)))) (while (setq ent (ssname ss (setq si (1+ si)))) (while (not (eq "SEQEND" (cdr (assoc 0 (entget (setq ent (entnext ent))))))) (if (eq str (cdr (assoc 1 (entget ent)))) (setq cnt (1+ cnt)))))) (setq OLst (cons (list (strlen str) str cnt) OLst))) (setq uFlag (not (vla-StartUndoMark doc)) tblObj (vla-addTable spc (vlax-3D-point bPt) (+ 2 (length olst)) 2 (* 1.5 (getvar "DIMTXT")) (* (apply (function max) (cons 6 (mapcar (function car) OLst))) 2. (getvar "DIMTXT")))) (vla-setText tblObj 0 0 "String Counter") (vla-setText tblObj 1 0 "String") (vla-setText tblObj 1 1 "Count") (foreach x (vl-sort (mapcar (function cdr) olst) (function (lambda (a b) (< (car a) (car b))))) (vla-setText tblObj (setq i (1+ i)) 0 (car x)) (vla-setText tblObj i 1 (itoa (cadr x)))) (setq uFlag (vla-EndUndoMark doc)))) (princ)) Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.