Jump to content

Lisp to deal with text/Mtext


asos2000

Recommended Posts

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

Link to comment
Share on other sites

  • Replies 31
  • Created
  • Last Reply

Top Posters In This Topic

  • Lee Mac

    15

  • asos2000

    10

  • The Buzzard

    2

  • stevesfr

    2

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.

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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?

Link to comment
Share on other sites

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?

Link to comment
Share on other sites

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

Link to comment
Share on other sites

- 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? :huh:

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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 :huh:

Link to comment
Share on other sites

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 :huh:

 

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

Link to comment
Share on other sites

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 :huh:

 

Its not grabbing the attribs for me. I'll send dwg if U like.

Steve

Link to comment
Share on other sites

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 :D

Link to comment
Share on other sites

I don't have one currently, but I could make one :D

 

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

Link to comment
Share on other sites

  • 8 months later...

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

Link to comment
Share on other sites

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.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.


×
×
  • Create New...