Lisp for counting identical text part (screw calculation)

[miroslav.pristov]

hello all i have text in form like this all over the drawing. the text represent the type of screw.

2xM12-40, M12-45, M12-55, 3xM12-40, M12-60, 2xM12-55, 3xM16-40, M16-40, 2xM14-55 etc

the form of text is something like this NxMK-J

wher N is nuber of screw (N=2 to n, if there is no N that counts like 1xMK-J)

K is a diameter of screw

J is lenght of the screw

Is there any chance to make me some lisp function or something else, which will sum all text ,from selected area i choose on drawing, in form given bellow

2xM12-40+3xM12-40=                

M12-45=                                  

M12-55+2xM12-55=                   

M12-60=

3xM16-40+M16-40=

2xM14-55= 

etc...                                

and give me the new text form like the bolded one in the place i click on drawing. 

5xM12-40, M12-45, 3xM12-55, M12-60, 2xM14-55, 4xM16-40 etc...

Thank you for help

[marko_ribar]

(defun c:sumscrews ( / unique remchar ss i e ex str strl strln sl sgroups s nogroup no sn snl p )

  (defun unique ( l )
    (if l
      (cons (car l)
        (vl-remove (car l) (unique (cdr l)))
      )
    )
  )

  (defun remchar ( char str / strn ch )
    (setq strn "")
    (while (/= str "")
      (setq ch (substr str 1 1))
      (if (= ch char)
        (setq ch "")
      )
      (setq str (substr str 2))
      (setq strn (strcat strn ch))
    )
    strn
  )

  (cond
    ( (setq ss (ssget '((0 . "TEXT"))))
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (setq ex (entget e))
        (setq str (cdr (assoc 1 ex)))
        (setq strl (cons str strl))
      )
      (setq strln
        (mapcar '(lambda ( x )
          (substr x (1+ (vl-string-search "M" x)))
          ) strl
        )
      )
      (setq strln (unique strln))
      (foreach s strln
        (setq sl
          (vl-remove-if-not '(lambda ( x )
            (= (substr x (1+ (vl-string-search "M" x))) s)
            ) strl
          )
        )
        (setq sgroups (cons sl sgroups))
      )
      (foreach group sgroups
        (setq s (substr (car group) (1+ (vl-string-search "M" (car group)))))
        (setq nogroup
          (mapcar '(lambda ( x )
            (if (not (zerop (atoi (vl-string-right-trim s x))))
              (atoi (vl-string-right-trim s x))
              1
            )
            ) group
          )
        )
        (setq no (apply '+ nogroup))
        (setq sn (if (/= no 1) (strcat (itoa no) "x" s) s))
        (setq snl (cons sn snl))
      )
      (setq snl
        (vl-sort snl
          '(lambda ( a b )
            (< (atoi (remchar "-" (substr a (+ 2 (vl-string-search "M" a))))) (atoi (remchar "-" (substr b (+ 2 (vl-string-search "M" b))))))
          )
        )
      )
      (setq snl
        (mapcar '(lambda ( x )
          (strcat x ", ")
          ) snl
        )
      )
      (setq snl (vl-string-right-trim ", " (apply 'strcat snl)))
      (setq p (getpoint "\nPick or specify insertion point : "))
      (entmake
        (list
          '(0 . "TEXT")
          '(100 . "AcDbEntity")
          '(100 . "AcDbText")
          (cons 10 p)
          (assoc 40 ex)
          (cons 1 snl)
          (assoc 7 ex)
          (assoc 210 ex)
        )
      )
    )
    ( t
      (prompt "\nEmpty sel.set... Restart routine and select text entities next time...")
    )
  )
  (princ)
)

HTH, M.R.

[miroslav.pristov]

Hey marko (care) this is great.

but i need some modifications because i didnt have the original dwg file with me when i wrote my post.

the text is in mtext form, not text form, i dont have value x before M, (i posted values like 2xM12-60, but the true values on drawings are 2M12-60). i ll try to change LISP but i dont get the corect output data. I have some mistake somewhere. Can you change it for me please. 

Also i noted that if i select some other text which is not the screw i defined in post, the command said nil bad argument type. Is there a chance that the command does not consider other text within the selected area in calculations

thank you very much you are so kind,

P.S. bolded text in brackets are not in english and i hope you understand it

[marko_ribar]

Ok, I had some lacks with previous example (vl-string-right-trim) is not working as should, so replace this portion in previous code :

        (setq nogroup
          (mapcar '(lambda ( x )
            (if (/= 0 (atoi x))
              (atoi x)
              1
            )
            ) group
          )
        )

And here is revision for MTEXT entities... (should allow only screw MTEXT contents)

(defun c:sumscrews ( / unique remchar ss i e ex str strl strln sl sgroups s nogroup no sn snl rtn p )

  (defun unique ( l )
    (if l
      (cons (car l)
        (vl-remove (car l) (unique (cdr l)))
      )
    )
  )

  (defun remchar ( char str / strn ch )
    (setq strn "")
    (while (/= str "")
      (setq ch (substr str 1 1))
      (if (= ch char)
        (setq ch "")
      )
      (setq str (substr str 2))
      (setq strn (strcat strn ch))
    )
    strn
  )

  (cond
    ( (setq ss (ssget (list '(0 . "MTEXT") (cons 1 "*M##-##"))))
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (setq ex (entget e))
        (setq str (cdr (assoc 1 ex)))
        (setq strl (cons str strl))
      )
      (setq strln
        (mapcar '(lambda ( x )
          (substr x (1+ (vl-string-search "M" x)))
          ) strl
        )
      )
      (setq strln (unique strln))
      (foreach s strln
        (setq sl
          (vl-remove-if-not '(lambda ( x )
            (= (substr x (1+ (vl-string-search "M" x))) s)
            ) strl
          )
        )
        (setq sgroups (cons sl sgroups))
      )
      (foreach group sgroups
        (setq s (substr (car group) (1+ (vl-string-search "M" (car group)))))
        (setq nogroup
          (mapcar '(lambda ( x )
            (if (/= 0 (atoi x))
              (atoi x)
              1
            )
            ) group
          )
        )
        (setq no (apply '+ nogroup))
        (setq sn (if (/= no 1) (strcat (itoa no) s) s))
        (setq snl (cons sn snl))
      )
      (setq snl
        (vl-sort snl
          '(lambda ( a b )
            (< (atoi (remchar "-" (substr a (+ 2 (vl-string-search "M" a))))) (atoi (remchar "-" (substr b (+ 2 (vl-string-search "M" b))))))
          )
        )
      )
      (setq snl
        (mapcar '(lambda ( x )
          (strcat x ", ")
          ) snl
        )
      )
      (setq rtn (vl-string-right-trim ", " (apply 'strcat snl)))
      (setq p (getpoint "\nPick or specify insertion point : "))
      (entmake
        (list
          '(0 . "MTEXT")
          '(100 . "AcDbEntity")
          '(100 . "AcDbMText")
          (cons 10 p)
          (assoc 40 ex)
          (cons 1 rtn)
          (assoc 7 ex)
          (assoc 210 ex)
        )
      )
    )
    ( t
      (prompt "\nEmpty sel.set... Restart routine and select MTEXT entities next time...")
    )
  )
  (princ)
)

HTH, M.R.

[miroslav.pristov]

hm its really strange.

i attached here my example file.

if i try to select mtext for bolts nothing is selected. if i type new mtext and start lisp again it select only the new mtext. whats the problem i dont know. 

[miroslav.pristov]

ok i found whats the problem. the color of text, every single mtext with color of text not defined by layer wont work. the lisp command wont select it. is there a chance to fix this in lisp i have to much mtexts like in example i must change manualy

[marko_ribar · Accepted solution]

---

@miroslav.pristov wrote:

ok i found whats the problem. the color of text, every single mtext with color of text not defined by layer wont work. the lisp command wont select it. is there a chance to fix this in lisp i have to much mtexts like in example i must change manualy

---

No that's not the problem... The real issue was in content of MTEXTs... Here is revision that should work and with your old MTEXT screws and with newly created...

(defun c:sumscrews ( / unique remchar ss i e ex str strl strln sl sgroups s nogroup no sn snl rtn p )

  (defun unique ( l )
    (if l
      (cons (car l)
        (vl-remove (car l) (unique (cdr l)))
      )
    )
  )

  (defun remchar ( char str / strn ch )
    (setq strn "")
    (while (/= str "")
      (setq ch (substr str 1 1))
      (if (= ch char)
        (setq ch "")
      )
      (setq str (substr str 2))
      (setq strn (strcat strn ch))
    )
    strn
  )

  (cond
    ( (setq ss (ssget (list '(0 . "MTEXT") (cons 1 "*M##-##*"))))
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (setq ex (entget e))
        (setq str (cdr (assoc 1 ex)))
        (setq strl (cons str strl))
      )
      (setq strln
        (mapcar '(lambda ( x )
          (substr x (1+ (vl-string-search "M" x)) 6)
          ) strl
        )
      )
      (setq strln (unique strln))
      (foreach s strln
        (setq sl
          (vl-remove-if-not '(lambda ( x )
            (= (substr x (1+ (vl-string-search "M" x)) 6) s)
            ) strl
          )
        )
        (setq sgroups (cons sl sgroups))
      )
      (foreach group sgroups
        (setq s (substr (car group) (1+ (vl-string-search "M" (car group))) 6))
        (setq nogroup
          (mapcar '(lambda ( x )
            (if (/= 0 (atoi (substr x (if (vl-string-search ";" x) (+ 2 (vl-string-search ";" (vl-string-right-trim (if (= (substr x (strlen x) 1) "}") (strcat s "}") s) x))) 1))))
              (atoi (substr x (if (vl-string-search ";" x) (+ 2 (vl-string-search ";" (vl-string-right-trim (if (= (substr x (strlen x) 1) "}") (strcat s "}") s) x))) 1)))
              1
            )
            ) group
          )
        )
        (setq no (apply '+ nogroup))
        (setq sn (if (/= no 1) (strcat (itoa no) s) s))
        (setq snl (cons sn snl))
      )
      (setq snl
        (vl-sort snl
          '(lambda ( a b )
            (< (atoi (remchar "-" (substr a (+ 2 (vl-string-search "M" a))))) (atoi (remchar "-" (substr b (+ 2 (vl-string-search "M" b))))))
          )
        )
      )
      (setq snl
        (mapcar '(lambda ( x )
          (strcat x ", ")
          ) snl
        )
      )
      (setq rtn (vl-string-right-trim ", " (apply 'strcat snl)))
      (setq p (getpoint "\nPick or specify insertion point : "))
      (entmake
        (list
          '(0 . "MTEXT")
          '(100 . "AcDbEntity")
          '(100 . "AcDbMText")
          (cons 10 p)
          (assoc 40 ex)
          (cons 1 rtn)
          (assoc 7 ex)
          (assoc 210 ex)
        )
      )
    )
    ( t
      (prompt "\nEmpty sel.set... Restart routine and select MTEXT entities next time...")
    )
  )
  (princ)
)

M.R.

[miroslav.pristov]

thanks it works perfect

[miroslav.pristov]

Marko can you please check this example file. I have some mtext i cant select. Everything was fine with lisp until i came to this file. In example file i ll expain everything. Also if you have time, i need some modification in lisp again, and thats is explained in example file too

I am sending you example file and MTEXT and DTEXT LISP if you have time to change it

[marko_ribar]

Here it is - with help of Lee Mac's sub for unformatting MTEXTs... I hope you don't mind Lee, thanks in OP's name...

(defun c:sumscrews ( / unique LM:UnFormat remchar ss i e ex str strl strln sl sgroups s nogroup no sn snl p k )

  (defun unique ( l )
    (if l
      (cons (car l)
        (vl-remove (car l) (unique (cdr l)))
      )
    )
  )

  ;;-------------------=={ 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 ) (vl-load-com)

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

  (defun remchar ( char str / strn ch )
    (setq strn "")
    (while (/= str "")
      (setq ch (substr str 1 1))
      (if (= ch char)
        (setq ch "")
      )
      (setq str (substr str 2))
      (setq strn (strcat strn ch))
    )
    strn
  )

  (cond
    ( (setq ss (ssget (list '(0 . "MTEXT") (cons 1 "*M##-*"))))
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (setq ex (entget e))
        (setq str (cdr (assoc 1 ex)))
        (setq strl (cons str strl))
      )
      (setq strln
        (mapcar '(lambda ( x )
          (substr (LM:UnFormat x t) (1+ (vl-string-search "M" (LM:UnFormat x t))))
          ) strl
        )
      )
      (setq strln (unique strln))
      (foreach s strln
        (setq sl
          (vl-remove-if-not '(lambda ( x )
            (= (substr (LM:UnFormat x t) (1+ (vl-string-search "M" (LM:UnFormat x t)))) s)
            ) strl
          )
        )
        (setq sgroups (cons sl sgroups))
      )
      (foreach group sgroups
        (setq s (substr (LM:UnFormat (car group) t) (1+ (vl-string-search "M" (LM:UnFormat (car group) t)))))
        (setq nogroup
          (mapcar '(lambda ( x )
            (if (/= 0 (atoi x))
              (atoi x)
              1
            )
            ) group
          )
        )
        (setq no (apply '+ nogroup))
        (setq sn (if (/= no 1) (strcat (itoa no) s) s))
        (setq snl (cons sn snl))
      )
      (setq snl
        (vl-sort snl
          '(lambda ( a b )
            (< (atoi (remchar "-" (substr (LM:UnFormat a t) (+ 2 (vl-string-search "M" (LM:UnFormat a t)))))) (atoi (remchar "-" (substr (LM:UnFormat b t) (+ 2 (vl-string-search "M" (LM:UnFormat b t)))))))
          )
        )
      )
      (setq p (getpoint "\nPick or specify insertion point : "))
      (setq k -1)
      (foreach s snl
        (entmake
          (list
            '(0 . "MTEXT")
            '(100 . "AcDbEntity")
            '(100 . "AcDbMText")
            (cons 10 (polar p (* pi -0.5) (* (setq k (1+ k)) (* 1.5 (cdr (assoc 40 ex))))))
            (assoc 40 ex)
            (cons 1 s)
            (assoc 7 ex)
            (assoc 210 ex)
          )
        )
      )
    )
    ( t
      (prompt "\nEmpty sel.set... Restart routine and select MTEXT entities next time...")
    )
  )
  (princ)
)

Regards, M.R.

[miroslav.pristov]

ok everything is good ( i can choose everything and format of the output data is what i want) but one thing isnt - the sum of screws at the end is not good now. if you compare the output data from old lisp, from example file i send you, and with new lisp there is a difference. the result must be 8M12-40, 20M12-45, 4M12-55, 20M16-45, 16M16-50, 12M16-55, 24M30-65. in new results there is a difference in last 4 texts

i bolded 12M16-55 because in my example 4 of screws i cant select (in example file this text is 8M16-55) 

Do you know why is a difference now?

[marko_ribar]

---

@miroslav.pristov wrote:

ok everything is good ( i can choose everything and format of the output data is what i want) but one thing isnt - the sum of screws at the end is not good now. if you compare the output data from old lisp, from example file i send you, and with new lisp there is a difference. the result must be 8M12-40, 20M12-45, 4M12-55, 20M16-45, 16M16-50, 12M16-55, 24M30-65. in new results there is a difference in last 4 texts

i bolded 12M16-55 because in my example 4 of screws i cant select (in example file this text is 8M16-55) 

Do you know why is a difference now?

---

Ok I've found where is bug... Test it now...

(defun c:sumscrews ( / unique LM:UnFormat remchar ss i e ex str strl strln sl sgroups s nogroup no sn snl p k )

  (defun unique ( l )
    (if l
      (cons (car l)
        (vl-remove (car l) (unique (cdr l)))
      )
    )
  )

  ;;-------------------=={ 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 ) (vl-load-com)

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

  (defun remchar ( char str / strn ch )
    (setq strn "")
    (while (/= str "")
      (setq ch (substr str 1 1))
      (if (= ch char)
        (setq ch "")
      )
      (setq str (substr str 2))
      (setq strn (strcat strn ch))
    )
    strn
  )

  (cond
    ( (setq ss (ssget (list '(0 . "MTEXT") (cons 1 "*M##-*"))))
      (repeat (setq i (sslength ss))
        (setq e (ssname ss (setq i (1- i))))
        (setq ex (entget e))
        (setq str (cdr (assoc 1 ex)))
        (setq strl (cons str strl))
      )
      (setq strln
        (mapcar '(lambda ( x )
          (substr (LM:UnFormat x t) (1+ (vl-string-search "M" (LM:UnFormat x t))))
          ) strl
        )
      )
      (setq strln (unique strln))
      (foreach s strln
        (setq sl
          (vl-remove-if-not '(lambda ( x )
            (= (substr (LM:UnFormat x t) (1+ (vl-string-search "M" (LM:UnFormat x t)))) s)
            ) strl
          )
        )
        (setq sgroups (cons sl sgroups))
      )
      (foreach group sgroups
        (setq s (substr (LM:UnFormat (car group) t) (1+ (vl-string-search "M" (LM:UnFormat (car group) t)))))
        (setq nogroup
          (mapcar '(lambda ( x )
            (if (/= 0 (atoi (LM:UnFormat x t)))
              (atoi (LM:UnFormat x t))
              1
            )
            ) group
          )
        )
        (setq no (apply '+ nogroup))
        (setq sn (if (/= no 1) (strcat (itoa no) s) s))
        (setq snl (cons sn snl))
      )
      (setq snl
        (vl-sort snl
          '(lambda ( a b )
            (< (atoi (remchar "-" (substr (LM:UnFormat a t) (+ 2 (vl-string-search "M" (LM:UnFormat a t)))))) (atoi (remchar "-" (substr (LM:UnFormat b t) (+ 2 (vl-string-search "M" (LM:UnFormat b t)))))))
          )
        )
      )
      (setq p (getpoint "\nPick or specify insertion point : "))
      (setq k -1)
      (foreach s snl
        (entmake
          (list
            '(0 . "MTEXT")
            '(100 . "AcDbEntity")
            '(100 . "AcDbMText")
            (cons 10 (polar p (* pi -0.5) (* (setq k (1+ k)) (* 1.5 (cdr (assoc 40 ex))))))
            (assoc 40 ex)
            (cons 1 s)
            (assoc 7 ex)
            (assoc 210 ex)
          )
        )
      )
    )
    ( t
      (prompt "\nEmpty sel.set... Restart routine and select MTEXT entities next time...")
    )
  )
  (princ)
)

Sorry, I was in a hurry... M.R.

[miroslav.pristov]

now its perfect. 

can you change output data for dtext version i sent you too. 

Thank you, you are very kind

[marko_ribar]

---

@miroslav.pristov wrote:

now its perfect. 

can you change output data for dtext version i sent you too. 

Thank you, you are very kind

---

I don't understand... Perhaps...

      (foreach s snl
        (entmake
          (list
            '(0 . "TEXT")
            '(100 . "AcDbEntity")
            '(100 . "AcDbMText")
            (cons 10 (polar p (* pi -0.5) (* (setq k (1+ k)) (* 1.5 (cdr (assoc 40 ex))))))
            (assoc 40 ex)
            (cons 1 s)
            (assoc 7 ex)
            (assoc 210 ex)
          )
        )
      )

[miroslav.pristov]

i changed the part of the routine, but the program wont upload the lisp it says error

In case you dont understand what i want, I will explain again

you make me lisp for counting dtext for screws, the output data is in mtext format and looks like 2M16-30, 3M12-40,... etc, can you change it that the every part which is separate by commas to be single dtext and the output data looks like 

2M16-30

3M12-40

etc

in attachment is a lisp and example file