RepCad Posted February 24, 2019 Posted February 24, 2019 (edited) Hi guys, I have a lot of duplicate text with different layer in autocad, and I want to export to excel or notepad with count of text in each layer , example : is it possible to do it with autolisp? Thanks in advanced. Edited February 24, 2019 by amir0914 Quote
BIGAL Posted February 24, 2019 Posted February 24, 2019 I am working on a block extract that does soething similar it could be changed possibly to work on layers. Post a dwg. Quote
Adju Posted February 25, 2019 Posted February 25, 2019 Hi Amir0914, A quick one would be to do a "DATAEXTRACTION". With that you can extract a lot of things. Follow the instructions and you will be able to find what you're looking for. When you're in the command (Dataextraction) just chek the "index box" and you'll be able to see the content of the text at the extraction. Quote
Adju Posted February 25, 2019 Posted February 25, 2019 Sorry, i forgot to mention that you just have to type "DATAEXTRACTION" in the command line. The snapshot i joined is in french. So, on the right side you select "General" and "text" and on the left side, you select "layer" and "index". With that i was able to export in excel what you were looking for. This is a alternative if you don't find a lisp routine that can do the job. Quote
BIGAL Posted February 25, 2019 Posted February 25, 2019 The only problem with dataextraction is it gives count as 1 for every item so you have to do a macro to re-total thats what I am working on is doing the count part and could go further levels, like layer and style being counted seperately. Hence request for a dwg. 1 Quote
RepCad Posted February 25, 2019 Author Posted February 25, 2019 Hi bigal, thanks for reply, this is a part of my dwg file : Test01.dwg Quote
rlx Posted February 25, 2019 Posted February 25, 2019 not tested ; select layers (defun _slay ( / d r ) (while (setq d (tblnext "LAYER" (null d)))(setq r (cons (cdr (assoc 2 d)) r)))(acad_strlsort r)) ; select texts (defun _stxt ( / s) (mapcar '(lambda (x) (cons (cdr (assoc 1 (setq e (entget x))))(cdr (assoc 8 e)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "x" '((0 . "text")))))))) ;;;remove duplicates (defun rdup (l / o) (vl-remove-if '(lambda (x) (cond ((vl-position x o) t) ((setq o (cons x o)) nil))) l)) (defun lst->csv (%l $s) (apply 'strcat (cdr (apply 'append (mapcar (function (lambda (x) (list $s x))) %l))))) (defun shell_open ( f / s r ) (if (and (setq f (findfile f)) (setq s (vla-getInterfaceObject (vlax-get-acad-object) "Shell.Application"))) (progn (setq r (vl-catch-all-apply 'vlax-invoke (list s 'open f)))(vlax-release-object s)(not (vl-catch-all-error-p r))))) (defun c:t1 ( / lay-lst txt-sel txt-sort array fn fp) (setq lay-lst (_slay) txt-sort (acad_strlsort (rdup (mapcar 'car (setq txt-sel (_stxt)))))) (setq array (vlax-make-safearray vlax-vbInteger (cons 0 (1- (length txt-sort))) (cons 0 (1- (length lay-lst))))) (foreach txt txt-sel (vlax-safearray-put-element array (setq r (vl-position (car txt) txt-sort)) (setq c (vl-position (cdr txt) lay-lst)) (1+ (vlax-safearray-get-element array r c)))) (if (and (setq fn (vl-filename-mktemp nil nil ".csv")) (setq fp (open fn "w")) (progn (write-line (lst->csv (mapcar 'vl-princ-to-string (append (list "text") lay-lst)) ",") fp) (mapcar '(lambda (x y) (write-line (lst->csv (cons x (mapcar 'vl-princ-to-string y)) ",") fp)) txt-sort (vlax-safearray->list array)) (if fp (close fp))(gc) T)) (progn (princ "\nPress space to open csv report , any other key to exit") (if (equal (grread) '(2 32)) (or (shell_open (findfile fn))(command "notepad" (findfile fn))))) ) (princ) ) 1 Quote
RepCad Posted February 25, 2019 Author Posted February 25, 2019 (edited) hey, thanks a lot rlx, it works fine, but the layer name and the text name is not sorted correctly, that should be like this : TT1 TT2 .... .... ... ... TT10 TT11 ... ... Edited February 25, 2019 by amir0914 Quote
rlx Posted February 25, 2019 Posted February 25, 2019 1 hour ago, amir0914 said: hey, thanks a lot rlx, it works fine, but the layer name and the text name is not sorted correctly, you make it sound like a bad thing... ; rlx 25 feb 2019 - https://www.cadtutor.net/forum/topic/66894-export-text/ (defun c:t1 ( / lay-lst txt-sel txt-sort array fn fp r c) (setq lay-lst (_slay) txt-sort (snort (rdup (mapcar 'car (setq txt-sel (_stxt)))))) (setq array (vlax-make-safearray vlax-vbInteger (cons 0 (1- (length txt-sort))) (cons 0 (1- (length lay-lst))))) (foreach txt txt-sel (vlax-safearray-put-element array (setq r (vl-position (car txt) txt-sort)) (setq c (vl-position (cdr txt) lay-lst)) (1+ (vlax-safearray-get-element array r c)))) (if (and (setq fn (vl-filename-mktemp nil nil ".csv")) (setq fp (open fn "w")) (progn (write-line (lst->csv (mapcar 'vl-princ-to-string (append (list "text") lay-lst)) ",") fp) (mapcar '(lambda (x y) (write-line (lst->csv (cons x (mapcar 'vl-princ-to-string y)) ",") fp)) txt-sort (vlax-safearray->list array)) (if fp (close fp))(gc) T)) (progn (princ "\nPress space to open csv report , any other key to exit") (if (equal (grread) '(2 32)) (or (shell_open (findfile fn))(command "notepad" (findfile fn)))))) (princ) ) ; select layers (defun _slay ( / d r )(while (setq d (tblnext "LAYER" (null d)))(setq r (cons (cdr (assoc 2 d)) r)))(snort r)) ; select texts (defun _stxt ( / e)(mapcar '(lambda (x) (cons (cdr (assoc 1 (setq e (entget x))))(cdr (assoc 8 e)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "x" '((0 . "text")))))))) ;;;remove duplicates (defun rdup (l / o)(vl-remove-if '(lambda (x) (cond ((vl-position x o) t) ((setq o (cons x o)) nil))) l)) (defun lst->csv (%l $s)(apply 'strcat (cdr (apply 'append (mapcar (function (lambda (x) (list $s x))) %l))))) (defun shell_open ( f / s r ) (if (and (setq f (findfile f)) (setq s (vla-getInterfaceObject (vlax-get-acad-object) "Shell.Application"))) (progn (setq r (vl-catch-all-apply 'vlax-invoke (list s 'open f)))(vlax-release-object s)(not (vl-catch-all-error-p r))))) ; Lee Mac / Gile (defun snort (l) (mapcar '(lambda (x) (nth x l)) (vl-sort-i (mapcar '(lambda (x) (vl-remove-if-not 'numberp (_SplitStr x))) l) (function (lambda (a b)(while (and a b (= (car a)(car b)))(setq a (cdr a) b (cdr b)))(if (or a b)(< (car a)(car b)) t)))))) (defun _SplitStr ( s / l p r n q ) (setq l (vl-string->list s) p (chr (car l)))(if (< 47 (car l) 58)(setq n T)) (while (setq l (cdr l))(if n (cond ((= 46 (car l))(if (and (cadr l)(setq q (strcat "0." (chr (cadr l))))(numberp (read q))) (setq r (cons (read p) r) p q l (cdr l))(setq r (cons (read p) r) p "." n nil))) ((< 47 (car l) 58)(setq p (strcat p (chr (car l)))))(t (setq r (cons (read p) r) p (chr (car l)) n nil))) (if (< 47 (car l) 58)(setq r (cons p r) p (chr (car l)) n T)(setq p (strcat p (chr (car l))))))) (if n (setq r (cons (read p) r))(setq r (cons p r)))(reverse r)) 1 Quote
RepCad Posted February 25, 2019 Author Posted February 25, 2019 Thank you again rlx, can you add two things to program ? (sorry, this is my last request) - remove zero from cells - write sum of layer in last record. Thank you for your patient. Quote
rlx Posted February 25, 2019 Posted February 25, 2019 (defun c:t1 ( / lay-lst txt-sel txt-sort array fn fp r c al) (setq lay-lst (_slay) txt-sort (snort (rdup (mapcar 'car (setq txt-sel (_stxt)))))) (setq array (vlax-make-safearray vlax-vbInteger (cons 0 (1- (length txt-sort))) (cons 0 (1- (length lay-lst))))) (foreach txt txt-sel (vlax-safearray-put-element array (setq r (vl-position (car txt) txt-sort)) (setq c (vl-position (cdr txt) lay-lst)) (1+ (vlax-safearray-get-element array r c)))) (setq al (mapcar '(lambda (x)(subst "" 0 x)) (vlax-safearray->list array))) (if (and (setq fn (vl-filename-mktemp nil nil ".csv")) (setq fp (open fn "w"))) (progn (write-line (lst->csv (mapcar 'vl-princ-to-string (cons "text" lay-lst)) ",") fp) (mapcar '(lambda (x y) (write-line (lst->csv (cons x (mapcar 'vl-princ-to-string y)) ",") fp)) txt-sort al) (write-line (lst->csv (cons "totals" (mapcar '(lambda (x / s) (if (setq s (ssget "x" (list '(0 . "text") (cons 8 x))))(itoa (sslength s)) "0")) lay-lst)) ",") fp) (if fp (close fp))(gc)(princ "\nPress space to open csv report , any other key to exit") (if (equal (grread) '(2 32)) (or (shell_open (findfile fn))(command "notepad" (findfile fn)))))) (princ) ) 1 Quote
Grrr Posted February 25, 2019 Posted February 25, 2019 Nice job @rlx ! This task didn't appeared that easy as I've imagined, and on top of that a bit more requirements from the OP... I'm impressed that you prefered to use an array instead of a list structure, BTW heres mine version with some large subs that I use often - ; https://www.cadtutor.net/forum/topic/66894-export-text/ ; Schledule TEXT by Layers (defun C:test ( / SortByNth SortStringWithNumberAsNumber _substNth aL sL lyrs tmp rL n ) ; (SortByNth 0 (lambda (L) (SortStringWithNumberAsNumber L)) L) ; This one combines (SortByNth_vl-sort) and (SortByNth_SortingFoo) ; Sort Matrix Assoc List By Nth - by applying list-sorting function as a foo (defun SortByNth ( n foo L / nL snL ) (setq nL (mapcar '(lambda (x) (nth n x)) L)) (setq snL (apply (function foo) (list nL))) (vl-sort L '(lambda (a b) (< (vl-position (nth n a) snL) (vl-position (nth n b) snL)))) ) ; http://www.theswamp.org/index.php?topic=16564.msg207439#msg207439 ;; Usage (SortStringWithNumberAsNumber '("A9" "A1" "A10" "B11" "B2" "B05")) ;; Return ("A1" "A9" "A10" "B2" "B05" "B11") (defun SortStringWithNumberAsNumber (ListOfString) (defun NormalizeNumberInString (str / ch i pat ret count buf) (setq i 0 pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9") ret "" count 4 ) (while (/= (setq ch (substr str (setq i (1+ i)) 1)) "") (if (vl-position ch pat) (progn (setq buf ch) (while (vl-position (setq ch (substr str (setq i (1+ i)) 1)) pat) (setq buf (strcat buf ch)) ) (while (< (strlen buf) count) (setq buf (strcat "0" buf))) (setq ret (strcat ret buf)) ) ) (setq ret (strcat ret ch)) ) ret ) (mapcar '(lambda (x) (nth x ListOfString)) (vl-sort-i (mapcar 'NormalizeNumberInString ListOfString) '<)) ) (defun _substNth ( n itm L / i ) (setq i -1) (mapcar (function (lambda (x) (if (= n (setq i (1+ i))) itm x))) L) ) (setq aL (mapcar (function (lambda (lyr / SS i s itm aL ) (if (setq SS (ssget "X" (list '(0 . "TEXT")(cons 8 lyr)))) (repeat (setq i (sslength SS)) (setq s (cdr (assoc 1 (entget (ssname SS (setq i (1- i))))))) (or (member s sL) (setq sL (cons s sL))) (cond ( (setq itm (assoc s aL)) (setq aL (subst (cons s (1+ (cdr itm))) itm aL)) ) ( (setq aL (cons (cons s 1) aL)) ) ) ) ) (list lyr aL) ) ) ( (lambda ( / d L ) (while (setq d (tblnext "LAYER" (not d))) (setq L (cons (cdr (assoc 2 d)) L)) ) (acad_strlsort L) ) ) ) ) (setq lyrs (cons "Text/Layers" (mapcar 'car aL))) (setq tmp (cdr (mapcar '(lambda (x) "") lyrs))) (foreach s sL (setq rL (cons (cons s tmp) rL)) ) (setq rL (reverse rL)) (foreach itm aL (cond ( (not (setq tmp (cadr itm))) ) ( (setq n (vl-position (car itm) lyrs)) (foreach subitm tmp (setq rL (mapcar (function (lambda ( x / ) (cond ( (/= (car x) (car subitm)) x) ( (_substNth n (itoa (cdr subitm)) x) ) ) ) ) rL ) ) ) ) ) ) (setq rL (SortByNth 0 (lambda (L) (SortStringWithNumberAsNumber L)) rL)) (setq rL (append (list lyrs) rL (list (setq tmp (mapcar '(lambda (x) "") lyrs))) (list (cons "TOTAL:" (mapcar '(lambda (x / tmp) (if (apply 'OR (setq tmp (mapcar 'read x))) (itoa (apply '+ (vl-remove nil tmp))) "" ) ) (cdr (apply 'mapcar (cons 'list rL))) ) ) ) ) ) (WriteToExcelFile rL) (princ) ); defun C:test (defun WriteToExcelFile ( aL / xlapp xlwbs xlwbk xlshts xlsht xlrng xlcls xlrow xlcol acwbk r ) (vl-catch-all-apply (progn '(65 115 115 101 109 98 108 101 100 32 98 121 32 71 114 114 114) 'eval) '( (and aL (vl-every (function vl-consp) aL) (vl-every (function (lambda (x) (or (not x) (eq 'STR (type x))))) (apply 'append aL)) (setq xlapp (vlax-get-or-create-object "Excel.Application")) (progn (vlax-put-property xlapp 'Visible :vlax-false) t) (setq xlwbs (vlax-get-property xlapp 'WorkBooks)) (setq xlwbk (vlax-invoke-method xlwbs 'Add)) (setq xlshts (vlax-get-property xlapp 'Worksheets)) (setq xlsht (vlax-invoke-method xlshts 'Add)) (progn (vlax-put-property xlsht 'Name "NewSheet") t) (setq xlrng (vlax-get-property xlsht 'UsedRange)) (setq xlcls (vlax-get-property xlrng 'Cells)) ( (lambda ( / row col tmp lst ) (setq row 1) (mapcar (function (lambda (L) (setq col 1) (mapcar (function (lambda (x) (setq tmp (cons (list row col (vl-princ-to-string x)) tmp)) (vlax-put-property xlcls "item" row col (cond ((not x) "") ( (vl-princ-to-string x) ) ) ) (setq col (1+ col)) ) ) L ) (setq row (1+ row)) (setq lst (cons (reverse tmp) lst)) (setq tmp nil) ) ) aL ) ) ) (progn (setq xlrng (vlax-get-property xlsht 'UsedRange)) (setq xlrow (vlax-get-property xlrng 'Rows)) (setq xlcol (vlax-get-property xlrng 'Columns)) (mapcar '(lambda (prp) (vl-catch-all-apply 'vlax-put-property (list xlrng prp -4108))) '(VerticalAlignment HorizontalAlignment)) (vl-catch-all-apply 'vlax-invoke-method (list xlcol 'AutoFit)) (vlax-invoke-method xlwbk 'SaveAs (strcat (getenv "userprofile") "\\Desktop\\" (vl-filename-base (getvar 'dwgname)) ".xls") -4143 nil nil :vlax-false :vlax-false 1 2 ) t ) (progn (setq acwbk (vlax-get-property xlapp 'ActiveWorkbook)) ; duh! (setq r (vlax-get-property acwbk 'FullName)) ; duh :/ ) ) ) ) (and (eq 'VLA-OBJECT (type xlwbk)) (vl-catch-all-apply 'vlax-invoke-method (list xlwbk 'Close :vlax-true)) ) (vl-catch-all-apply 'vlax-invoke-method (list xlapp 'Quit)) (foreach o (reverse (list xlapp xlwbs xlwbk xlshts xlsht xlrng xlcls xlrow xlcol acwbk r)) (and (eq 'VLA-OBJECT (type o)) (vl-catch-all-apply 'vlax-release-object (list o))) ) (gc) (gc) r ); defun WriteToExcelFile I didn't wrote any codes in a while, so keeping a bit with the practice. 1 Quote
RepCad Posted February 26, 2019 Author Posted February 26, 2019 (edited) Thank you to rlx and grrr, my has been resolved with your program. Edited February 26, 2019 by amir0914 Quote
rlx Posted February 26, 2019 Posted February 26, 2019 6 hours ago, Grrr said: Nice job @rlx ! This task didn't appeared that easy as I've imagined, and on top of that a bit more requirements from the OP... I'm impressed that you prefered to use an array instead of a list structure, BTW heres mine version with some large subs that I use often - I didn't wrote any codes in a while, so keeping a bit with the practice. Hi Grrr, interesting sorting technique! All the code was still hanging in my last functioning brain cell so modifying it to the needs of OP wasn't to difficult although I 'cheated' a little with the totals by using ssget again instead of doing the math on the array itself. I did at first and had summarized the rows but after re-reading the request and seeing the picture below it I realized I had the wrong totals. But I had a visit from an old colleague of mine so was in a hurry. I agree it was a little (tiny) bit more complicated then I first anticipated but after realizing what I needed was some sort of double assoc function using a array looked like the natural / logical / easier thing to do. Suppressing the zero's and making totals really is something one would and should do with excel because that's what it is suppost to do but because it wasn't that big of a deal ... Quote
rlx Posted February 26, 2019 Posted February 26, 2019 28 minutes ago, amir0914 said: Thank you to rlx and grrr, my has been resolved with your program. nos problemos Quote
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.