Visual LISP, AutoLISP and General Customization
cancel
Showing results for 
Show  only  | Search instead for 
Did you mean: 

merge intersecting text with same value

25 REPLIES 25
SOLVED
Reply
Message 1 of 26
marlance
696 Views, 25 Replies

merge intersecting text with same value

Is it possible to merge intersecting text with the same value?

 

Heres my problem. text are too close to each other

text.PNG

 

 

 

 

it should be like this

 

 

text2.PNG

25 REPLIES 25
Message 2 of 26
golf32902
in reply to: marlance

It looks like you are doing a elevation mark. I don't know if this is a line and this is the points that are given from the surveyors, but if it is just import them on a layer that can be shut off. Then what i would do if it was a line, just create a customs line type and make it show your elevation.

 

 

Message 3 of 26
marlance
in reply to: golf32902

those text were generated in 12d

Message 4 of 26
marko_ribar
in reply to: marlance

Maybe, try this code...

 

(defun c:mergetxts ( / massoc unique sstxt i enttxt txtlst txtlstnew )

  (defun massoc ( search lst )
    (vl-remove nil
      (if lst
        (cons
          (assoc search lst)
          (massoc search (cdr (member (assoc search lst) lst)))
        )
      )
    )
  )
  
  (defun unique ( lst )
    (if lst (cons (car lst) (vl-remove-if '(lambda ( x ) (eq (caar lst) (car x))) (unique (cdr lst)))))
  )

  (setq sstxt (ssget "_:L" '((0 . "TEXT"))))
  (setq i -1)
  (while (setq enttxt (ssname sstxt (setq i (1+ i))))
    (setq txtlst (cons (list (cdr (assoc 1 (entget enttxt))) enttxt) txtlst))
  )
  (setq txtlstnew (apply 'append (mapcar '(lambda ( x ) (unique (massoc (car x) txtlst))) txtlst)))
  (setq txtlstnew (unique txtlstnew))
  (setq i -1)
  (while (setq enttxt (ssname sstxt (setq i (1+ i))))
    (if (not (vl-member-if '(lambda ( x ) (eq enttxt (cadr x))) txtlstnew))
      (entdel enttxt)
    )
  )
  (princ)
)

Regards,  Marko Ribar

Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 5 of 26
marlance
in reply to: marko_ribar

thanks

 

it works

Message 6 of 26
pbejse
in reply to: marlance

Really?  Not sure though, but i dont see how the solution is any different than selecting the text via selection and invoking a "R" <remove> to leave one TEXT as the designated value for the rest of the similar value?

 

I was expecting a more automated approach that actually determines the "intersecting"  TEXT entities. MAybe i'm missing something here.

 

Message 7 of 26
marko_ribar
in reply to: pbejse


@pbejse wrote:

Really?  Not sure though, but i dont see how the solution is any different than selecting the text via selection and invoking a "R" <remove> to leave one TEXT as the designated value for the rest of the similar value?

 

I was expecting a more automated approach that actually determines the "intersecting"  TEXT entities. MAybe i'm missing something here.

 


pbejse, you are missing the key of the routine... The key is that there are many different text entities with different content... If searched for the same values (massoc) can do it, then (unique) leaves just single of each different texts... Routine then removes all other texts, remaining those that are unique... Technik used in this routine is impressive, I am sad it didn't recieved kudo as it's really by my opinion very nice example of solving the problem... So you are telling me that without routine, you would select all texts and manually hit remove on each one that is different... Until you finish clicking "r" for 1000 different content texts, routine will do it in seconds leaving exactly 1000 of them and other 1000000 removed...

Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 8 of 26
pbejse
in reply to: marko_ribar


@marko_ribar wrote:
pbejse, you are missing the key of the routine... The key is that there are many different text entities with different content... If searched for the same values (massoc) can do it, then (unique) leaves just single of each different texts... Routine then removes all other texts, remaining those that are unique... 

What your routine does is select all TEXT <via selection on screen that is> with similar string value and delete all duplicates EVEN though they are NOT intersecting. 

 


@marko_ribar wrote:


 So you are telling me that without routine, you would select all texts and manually hit remove on each one that is different... Until you finish clicking "r" for 1000 different content texts, routine will do it in seconds leaving exactly 1000 of them and other 1000000 removed...


 

Now that is just being silly MR. Think about it, you opted to use ssget with a prompt to select, now why is that? you cant predict what TEXT string entity will remain, correct? say you turn the filter into "X" <all 1000000 of them if you think that even make sense> , can you tell which one will remain? NO of course not, because the routine will include ALL similar value regardless it it intersects or not. so in a way you still need to select the text entities you need to porcess. BUT still whihc one will remain? 

 

Basically with erase command you DO need to select on screen AND you can select which one will remain.

 

BTW: you only need to press "r" <remove" once.

 

Message 9 of 26
marko_ribar
in reply to: pbejse

If you don't understand the purpose of cleaning drawing of text entities that are the same and "grouped" as shown in the picture that's your problem... OP asked for the way to make those kind of drawings readable, and with 1000 or more different groups of text entities with the same values, it's not the question which entity from each group will remain, but readability of drawing, and if desired Xdir rotation aligment can be included in consideration if that was the case, but in shown picture that wasn't the case... So instead of pressing "r" and repeating clicking, with supplied "all" selection choice, routine can clean drawing and make it more readable and that was request by OP...

Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 10 of 26
pbejse
in reply to: marko_ribar


@marko_ribar wrote:

If you don't understand the purpose of cleaning drawing of text entities that are the same and "grouped" as shown in the picture that's your problem... OP asked for the way to make those kind of drawings readable, 


Problem is you are limiting yourself to what you think is the right solution, as a matter of fact , what you think is THE ONLY SOLUTION.  

 

Say there are TEXT string with value 1105 overlapping each other and there is another group of 1105 again overlapping each other asome place else and then there's one TEXT entity with 1105 not even near the other similar value text string. what would you think would happen if you run the code with "ALL" option?

 

So is that cleaning up and readable? You will be missing a lot of TEXT string value that are not intended to be deleted is what i'm saying.

 

Honestly you should have caught that problem from the get-go.

Message 11 of 26
marko_ribar
in reply to: pbejse

Here, I've taken care of what you're talking about... Test my new code...

 

(defun c:mergetxts ( / massoc _intl unique carunique touchlst sstxt sss i enttxt touchtxtgroups txtlstnew )

  (defun massoc ( search lst )
    (vl-remove nil
      (if lst
        (cons
          (assoc search lst)
          (massoc search (cdr (member (assoc search lst) lst)))
        )
      )
    )
  )

  (defun _intl ( l1 l2 / ll1 ll2 a ls1 ls2 )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll2))
      (while ll1
        (if (equal a (car ll1) 1e-8)
          (setq ls1 (append ls1 (list a))
                ll1 (cdr ll1)
          )
          (setq ll1 (cdr ll1))
        )
      )
      (setq ll2 (cdr ll2)
            ll1 (vl-remove a l1)
      )
    )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll1))
      (while ll2
        (if (equal a (car ll2) 1e-8)
          (setq ls2 (append ls2 (list a))
                ll2 (cdr ll2)
          )
          (setq ll2 (cdr ll2))
        )
      )
      (setq ll1 (cdr ll1)
            ll2 (vl-remove a l2)
      )
    )
    (if (< (length ls1) (length ls2)) ls1 ls2)
  )
  
  (defun unique ( lst )
    (if lst (cons (car lst) (vl-remove-if '(lambda ( x ) (equal (_intl x (car lst)) x)) (unique (cdr lst)))))
  )

  (defun carunique ( lst )
    (if lst (cons (car lst) (vl-remove-if '(lambda ( x ) (eq (caar lst) (car x))) (unique (cdr lst)))))
  )

  (defun touchlst ( e ss / i ent lst )
    (vl-load-com)
    (setq lst (cons e lst))
    (setq i -1)
    (while (setq ent (ssname ss (setq i (1+ i))))
      (if (not (eq e ent))
        (if (vlax-invoke (vlax-ename->vla-object e) 'intersectwith (vlax-ename->vla-object ent) acextendnone)
          (progn
            (setq lst (cons ent lst))
            (setq e ent)
          )
        )
      )
    )
    lst
  )

  (setq sstxt (ssget "_:L" '((0 . "TEXT"))))
  (setq sss (ssadd))
  (setq i -1)
  (while (setq enttxt (ssname sstxt (setq i (1+ i))))
    (ssadd enttxt sss)
  )
  (setq i -1)
  (while (setq enttxt (ssname sstxt (setq i (1+ i))))
    (setq touchtxtgroups (cons (touchlst enttxt (ssdel enttxt sstxt)) touchtxtgroups))
  )
  (setq touchtxtgroups (vl-sort touchtxtgroups '(lambda ( a b ) (> (length a) (length b)))))
  (setq touchtxtgroups (unique touchtxtgroups))
  (setq touchtxtgroups (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (list (cdr (assoc 1 (entget y))) y)) x)) touchtxtgroups))
  (setq touchtxtgroups (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (massoc (car y) x)) x)) touchtxtgroups))
  (setq touchtxtgroups (mapcar '(lambda ( x ) (carunique x)) touchtxtgroups))
  (setq touchtxtgroups (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (carunique y)) x)) touchtxtgroups))
  (setq touchtxtgroups (apply 'append touchtxtgroups))
  (setq txtlstnew (apply 'append touchtxtgroups))
  (setq i -1)
  (while (setq enttxt (ssname sss (setq i (1+ i))))
    (if (not (vl-member-if '(lambda ( x ) (eq enttxt (cadr x))) txtlstnew))
      (entdel enttxt)
    )
  )
  (princ)
)

 HTH, M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 12 of 26
marko_ribar
in reply to: marko_ribar

Something's wrong, if I apply routine more times, more and more texts are deleted...

 

Here is my lastest version...

 

(defun c:mergetxts ( / massoc _intl unique touchlst sstxt sss ss s i ent enttxt txtent txtgroups touchtxtgroup touchtxtgroups txtlstnew )

  (defun massoc ( search lst )
    (vl-remove nil
      (if lst
        (cons
          (assoc search lst)
          (massoc search (cdr (member (assoc search lst) lst)))
        )
      )
    )
  )

  (defun _intl ( l1 l2 / ll1 ll2 a ls1 ls2 )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll2))
      (while ll1
        (if (equal a (car ll1) 1e-8)
          (setq ls1 (append ls1 (list a))
                ll1 (cdr ll1)
          )
          (setq ll1 (cdr ll1))
        )
      )
      (setq ll2 (cdr ll2)
            ll1 (vl-remove a l1)
      )
    )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll1))
      (while ll2
        (if (equal a (car ll2) 1e-8)
          (setq ls2 (append ls2 (list a))
                ll2 (cdr ll2)
          )
          (setq ll2 (cdr ll2))
        )
      )
      (setq ll1 (cdr ll1)
            ll2 (vl-remove a l2)
      )
    )
    (if (< (length ls1) (length ls2)) ls1 ls2)
  )
  
  (defun unique ( lst )
    (if lst (cons (car lst) (vl-remove-if '(lambda ( x ) (equal (_intl x (car lst)) x)) (unique (cdr lst)))))
  )

  (defun touchlst ( e ss / i ent lst )
    (vl-load-com)
    (setq lst (cons e lst))
    (setq i -1)
    (while (setq ent (ssname ss (setq i (1+ i))))
      (if (not (eq e ent))
        (if (vlax-invoke (vlax-ename->vla-object e) 'intersectwith (vlax-ename->vla-object ent) acextendnone)
          (progn
            (setq lst (cons ent lst))
            (setq e ent)
          )
        )
      )
    )
    lst
  )

  (setq sstxt (ssget "_:L" '((0 . "TEXT"))))
  (setq sss (ssadd))
  (setq i -1)
  (while (setq ent (ssname sstxt (setq i (1+ i))))
    (ssadd ent sss)
    (setq txtgroups (cons (list (cdr (assoc 1 (entget ent))) ent) txtgroups))
  )
  (setq txtgroups (mapcar '(lambda ( x ) (massoc (car x) txtgroups)) txtgroups))
  (setq txtgroups (unique txtgroups))
  (foreach txtgroup txtgroups
    (setq ss (ssadd))
    (foreach txtent txtgroup
      (ssadd (cadr txtent) ss)
    )
    (setq s (acet-ss-union (list ss)))
    (setq i -1)
    (while (setq ent (ssname ss (setq i (1+ i))))
      (setq ss (acet-ss-union (list s)))
      (setq touchtxtgroup (cons (touchlst ent (ssdel ent ss)) touchtxtgroup))
    )
    (setq touchtxtgroup (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (list (cdr (assoc 1 (entget y))) y)) x)) touchtxtgroup))
    (setq touchtxtgroup (vl-sort touchtxtgroup '(lambda ( a b ) (> (length a) (length b)))))
    (setq touchtxtgroup (unique touchtxtgroup))
    (setq touchtxtgroups (cons touchtxtgroup touchtxtgroups))
    (setq touchtxtgroup nil)
  )
  (foreach touchtxtgroup touchtxtgroups
    (foreach touch touchtxtgroup
      (setq txtlstnew (cons (car touch) txtlstnew))
    )
  )
  (setq i -1)
  (while (setq enttxt (ssname sss (setq i (1+ i))))
    (if (not (vl-member-if '(lambda ( x ) (eq enttxt (cadr x))) txtlstnew))
      (entdel enttxt)
    )
  )
  (princ)
)

 M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 13 of 26
marko_ribar
in reply to: marko_ribar

Now fixed...

 

(defun c:mergetxts ( / massoc _intl unique touchlst sstxt sss ss s i ent enttxt txtent txtgroups touchtxtgroup touchtxtgroups txtlstnew )

  (defun massoc ( search lst )
    (vl-remove nil
      (if lst
        (cons
          (assoc search lst)
          (massoc search (cdr (member (assoc search lst) lst)))
        )
      )
    )
  )

  (defun _intl ( l1 l2 / ll1 ll2 a ls1 ls2 )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll2))
      (while ll1
        (if (equal a (car ll1) 1e-8)
          (setq ls1 (append ls1 (list a))
                ll1 (cdr ll1)
          )
          (setq ll1 (cdr ll1))
        )
      )
      (setq ll2 (cdr ll2)
            ll1 (vl-remove a l1)
      )
    )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll1))
      (while ll2
        (if (equal a (car ll2) 1e-8)
          (setq ls2 (append ls2 (list a))
                ll2 (cdr ll2)
          )
          (setq ll2 (cdr ll2))
        )
      )
      (setq ll1 (cdr ll1)
            ll2 (vl-remove a l2)
      )
    )
    (if (< (length ls1) (length ls2)) ls1 ls2)
  )
  
  (defun unique ( lst )
    (if lst (cons (car lst) (vl-remove-if '(lambda ( x ) (equal (_intl x (car lst)) x)) (unique (cdr lst)))))
  )

  (defun touchlst ( e ss / i ent lst )
    (vl-load-com)
    (setq lst (cons e lst))
    (setq i -1)
    (while (setq ent (ssname ss (setq i (1+ i))))
      (if (not (eq e ent))
        (if (vlax-invoke (vlax-ename->vla-object e) 'intersectwith (vlax-ename->vla-object ent) acextendnone)
          (progn
            (setq lst (cons ent lst))
            (setq e ent)
          )
        )
      )
    )
    lst
  )

  (setq sstxt (ssget "_:L" '((0 . "TEXT"))))
  (setq sss (ssadd))
  (setq i -1)
  (while (setq ent (ssname sstxt (setq i (1+ i))))
    (ssadd ent sss)
    (setq txtgroups (cons (list (cdr (assoc 1 (entget ent))) ent) txtgroups))
  )
  (setq txtgroups (mapcar '(lambda ( x ) (massoc (car x) txtgroups)) txtgroups))
  (setq txtgroups (unique txtgroups))
  (foreach txtgroup txtgroups
    (setq ss (ssadd))
    (foreach txtent txtgroup
      (ssadd (cadr txtent) ss)
    )
    (setq s (acet-ss-union (list ss)))
    (setq i -1)
    (while (setq ent (ssname ss (setq i (1+ i))))
      (setq ss (acet-ss-union (list s)))
      (if (> (length (touchlst ent (ssdel ent ss))) 1)
        (progn
          (setq ss (acet-ss-union (list s)))
          (setq touchtxtgroup (cons (touchlst ent (ssdel ent ss)) touchtxtgroup))
        )
        (setq touchtxtgroup (mapcar 'list (mapcar 'cadr txtgroup)))
      )
    )
    (setq touchtxtgroup (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (list (cdr (assoc 1 (entget y))) y)) x)) touchtxtgroup))
    (setq touchtxtgroup (vl-sort touchtxtgroup '(lambda ( a b ) (> (length a) (length b)))))
    (setq touchtxtgroup (unique touchtxtgroup))
    (setq touchtxtgroups (cons touchtxtgroup touchtxtgroups))
    (setq touchtxtgroup nil)
  )
  (foreach touchtxtgroup touchtxtgroups
    (foreach touch touchtxtgroup
      (setq txtlstnew (cons (car touch) txtlstnew))
    )
  )
  (setq i -1)
  (while (setq enttxt (ssname sss (setq i (1+ i))))
    (if (not (vl-member-if '(lambda ( x ) (eq enttxt (cadr x))) txtlstnew))
      (entdel enttxt)
    )
  )
  (princ)
)

 Regards, M.R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 14 of 26
pbejse
in reply to: marko_ribar


@marko_ribar wrote:

Now fixed...

 

 Regards, M.R.


Thats more like it M.R. Now you get a kudo 🙂

 

I will write my own version if i have time. 

Message 15 of 26
marko_ribar
in reply to: pbejse

Thanks for kudo, but only lack of the code are sel.sets... I think CAD can only hold up to 128... So I don't guarantee that it will pass if reference drawing is more complex from the first time... Haven't test it on those cases, I would be satisfied if it could do it after few repeating, but I am not sure - the number of sel. sets depends on number of different texts, so if in first pass it don't do it completely (more than 128 different texts) it will after repeating create again the same 128 sel. sets... So all in all, my fist code that is much more simple if not repeating the same texts on different groups touching each other can do the job... After all thats accepted solution...

 

Marko R.

Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 16 of 26
marko_ribar
in reply to: marko_ribar


@marko_ribar wrote:

Thanks for kudo, but only lack of the code are sel.sets... I think CAD can only hold up to 128... So I don't guarantee that it will pass if reference drawing is more complex from the first time... Haven't test it on those cases, I would be satisfied if it could do it after few repeating, but I am not sure - the number of sel. sets depends on number of different texts, so if in first pass it don't do it completely (more than 128 different texts) it will after repeating create again the same 128 sel. sets... So all in all, my fist code that is much more simple if not repeating the same texts on different groups touching each other can do the job... After all thats accepted solution...

 

Marko R.


Tested it with 300 different texts and it passed, so I was wrong in my prediction... Maybe it uses the same sel. sets once created... Slow, but it finishes correctly...

 

Set up lisp :

(defun c:mknoverlaptxts ( / k n p0 p1 p2 p3 p4 p5 p6 p7 p8 p9 )
  (setq k 0)
  (initget 7)
  (setq n (getint "\nSpecify number of text entities : "))
  (repeat n
    (setq k (1+ k))
    (setq p0 (list (float (* k 10)) 0.0 0.0))
    (setq p1 (polar p0 (/ pi 2.0) 0.25))
    (setq p2 (polar p1 (/ pi 2.0) 0.25))
    (setq p3 (polar p2 (/ pi 2.0) 0.25))
    (setq p4 (polar p3 (/ pi 2.0) 0.25))
    (setq p5 (polar p4 (/ pi 2.0) 0.25))
    (setq p6 (polar p5 (/ pi 2.0) 0.25))
    (setq p7 (polar p6 (/ pi 2.0) 0.25))
    (setq p8 (polar p7 (/ pi 2.0) 0.25))
    (setq p9 (polar p8 (/ pi 2.0) 0.25))
    (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 1 (itoa k)) (cons 10 p0) (cons 40 0.5)))
    (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 1 (itoa k)) (cons 10 p1) (cons 40 0.5)))
    (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 1 (itoa k)) (cons 10 p2) (cons 40 0.5)))
    (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 1 (itoa k)) (cons 10 p3) (cons 40 0.5)))
    (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 1 (itoa k)) (cons 10 p4) (cons 40 0.5)))
    (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 1 (itoa k)) (cons 10 p5) (cons 40 0.5)))
    (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 1 (itoa k)) (cons 10 p6) (cons 40 0.5)))
    (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 1 (itoa k)) (cons 10 p7) (cons 40 0.5)))
    (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 1 (itoa k)) (cons 10 p8) (cons 40 0.5)))
    (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText") (cons 1 (itoa k)) (cons 10 p9) (cons 40 0.5)))
  )
  (princ)
)

 Marko Ribar

Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 17 of 26
marlance
in reply to: marlance

hi MR

thanks for the time you took in improving your code.

hi pbe

i will wait for your version for this code
thank you very much
Message 18 of 26
marko_ribar
in reply to: marlance

Here is my final version, and I think I couldn't do it better... On my test of 1000 groups by 10 texts, it took ab 15 min, which is 3 times faster than my last code valued with kudo... I've make code more concise, opted it for performance, removed creation of unnecessary sel. sets and now I am very satisfied with it... pbejse, you would have less than 1 sec to click on different text entity and do it 1000 times without making mistake, meanwhile I could just select all 1000 groups and drink coffe for ab 15 min... And it will be finished all correctly... So what approach is better, your or mine...

 

Here is my final version...

 

(defun c:mergetxts ( / massoc _intl unique touchlst sstxt i ent enttxt txtent txtgroups touchtxtgroup touchtxtgroups txtlstnew )

  (defun massoc ( search lst )
    (vl-remove nil
      (if lst
        (cons
          (assoc search lst)
          (massoc search (cdr (member (assoc search lst) lst)))
        )
      )
    )
  )

  (defun _intl ( l1 l2 / ll1 ll2 a ls1 ls2 )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll2))
      (while ll1
        (if (equal a (car ll1) 1e-8)
          (setq ls1 (append ls1 (list a))
                ll1 (cdr ll1)
          )
          (setq ll1 (cdr ll1))
        )
      )
      (setq ll2 (cdr ll2)
            ll1 (vl-remove a l1)
      )
    )
    (setq ll1 l1
          ll2 l2
    )
    (while
      (setq a (car ll1))
      (while ll2
        (if (equal a (car ll2) 1e-8)
          (setq ls2 (append ls2 (list a))
                ll2 (cdr ll2)
          )
          (setq ll2 (cdr ll2))
        )
      )
      (setq ll1 (cdr ll1)
            ll2 (vl-remove a l2)
      )
    )
    (if (< (length ls1) (length ls2)) ls1 ls2)
  )
  
  (defun unique ( lst )
    (if lst (cons (car lst) (vl-remove-if '(lambda ( x ) (equal (_intl x (car lst)) x)) (unique (cdr lst)))))
  )

  (defun touchlst ( txte txtgroup / txtent lst )
    (vl-load-com)
    (setq lst (cons txte lst))
    (foreach txtent txtgroup
      (if (not (eq (cadr txte) (cadr txtent)))
        (if (vlax-invoke (vlax-ename->vla-object (cadr txte)) 'intersectwith (vlax-ename->vla-object (cadr txtent)) acextendnone)
          (progn
            (setq lst (cons txtent lst))
            (setq txte txtent)
          )
        )
      )
    )
    lst
  )

  (setq sstxt (ssget "_:L" '((0 . "TEXT"))))
  (setq i -1)
  (while (setq ent (ssname sstxt (setq i (1+ i))))
    (setq txtgroups (cons (list (cdr (assoc 1 (entget ent))) ent) txtgroups))
  )
  (setq txtgroups (mapcar '(lambda ( x ) (massoc (car x) txtgroups)) txtgroups))
  (setq txtgroups (unique txtgroups))
  (foreach txtgroup txtgroups
    (foreach txtent txtgroup
      (if (> (length (touchlst txtent (vl-remove txtent txtgroup))) 1)
        (setq touchtxtgroup (cons (touchlst txtent (vl-remove txtent txtgroup)) touchtxtgroup))
        (setq touchtxtgroup (mapcar 'list txtgroup))
      )
    )
    (setq touchtxtgroup (vl-sort touchtxtgroup '(lambda ( a b ) (> (length a) (length b)))))
    (setq touchtxtgroup (unique touchtxtgroup))
    (setq touchtxtgroups (cons touchtxtgroup touchtxtgroups))
    (setq touchtxtgroup nil)
  )
  (foreach touchtxtgroup touchtxtgroups
    (foreach touch touchtxtgroup
      (setq txtlstnew (cons (car touch) txtlstnew))
    )
  )
  (setq i -1)
  (while (setq enttxt (ssname sstxt (setq i (1+ i))))
    (if (not (vl-member-if '(lambda ( x ) (eq enttxt (cadr x))) txtlstnew))
      (entdel enttxt)
    )
  )
  (princ)
)

 Hope you'll like it, Marko Ribar, d.i.a.

Marko Ribar, d.i.a. (graduated engineer of architecture)
Message 19 of 26
pbejse
in reply to: marko_ribar


@marko_ribar wrote:

Here is my final version, and I think I couldn't do it better... On my test of 1000 groups by 10 texts, it took ab 15 min, which is 3 times faster than my last code valued with kudo... I've make code more concise, opted it for performance, removed creation of unnecessary sel. sets and now I am very satisfied with it... pbejse, you would have less than 1 sec to click on different text entity and do it 1000 times without making mistake, meanwhile I could just select all 1000 groups and drink coffe for ab 15 min... And it will be finished all correctly... So what approach is better, your or mine...


First of all, to tell you the truth  i gave you a kudo because i know you are on the right track by  using intersectwith function and did not really spend much time testing your code.

 

Now that is totally uncalled for, i was referencing the first code you posted and not the latest one, but still your last code does'nt cut it at all, try it on the attached file. <think of it as a real world drawing file>

 

Meanwhile, since you re egging me to write a code to compare with yours.

 

 

(defun c:mergeoverlap (/ data overlap sstxt a str atex)
;;;	pBe MErgeoverlap	;;;
  (if (setq data    nil
	    overlap nil
	    sstxt   (ssget "_:L" '((0 . "TEXT")))
      )
    (progn
      (repeat (setq i (sslength sstxt))
	(setq e (ssname sstxt (setq i (1- i))))
	(setq
	  data (cons
		 (list
		   (cdr (assoc 1 (entget e)))
		   (vlax-ename->vla-object e)
		 )
		 data
	       )
	)
      )

      (while data
	(setq a (Car data))
	(setq str   (car a)
	      datex (vl-remove-if-not
		      '(lambda (x)
			 (eq str (car x))
		       )
		      (vl-remove a data)
		    )
	)
	(Foreach b datex
	  (if (and (vlax-invoke
		     (cadr a)
		     'Intersectwith
		     (cadr b)
		     acExtendNone
		   )
		   (not (vl-position (cadr b) overlap))
	      )
	    (setq overlap (cons (cadr b) overlap))
	  )
	)
	(setq data (vl-remove a data))
      )
      (foreach itm overlap (vla-delete itm))
    )
  )
  (princ)
)

 

 I not claiming this code as faster or what not. but it deals with the issue i brought out earlier.

 

EDIT: And yes you will notice i missed an overlap <on the attached dwg> , but if you take a look closely, the string value is not the same.

Message 20 of 26
hmsilva
in reply to: pbejse

Nicely coded, pBe.

Henrique

EESignature

Can't find what you're looking for? Ask the community or share your knowledge.

Post to forums  

Autodesk Design & Make Report

”Boost