Switching two items in a table in AutoCAD LISP

[ryankevin15]

.....

Edited January 1, 2019 by ryankevin15

[Lee Mac]

Are you using a table object or is the table composed of text & lines?

[Grrr]

Previously I was about to ask if there was such functionality to shift table rows, but decided to code it myself rather than asking on the forums.

 

[rlx]

Previously I was about to ask if there was such functionality to shift table rows, but decided to code it myself rather than asking on the forums.

 

 

Very nice Grrr, cool!

 

gr. Rlx

[ryankevin15]

could you share?

[Roy_043]

@ryankevin15:

You should answer Lee's crucial question. If your table is not an actual table object Grrr's code won't work. Looking at your image I doubt it is a table object.

[ryankevin15]

No it's line objects in AutoCAD. Looks better/more control of style.

[sieu khung khiep]

Nice Grrr

[Tharwat]

No it's line objects in AutoCAD. Looks better/more control of style.

 

Try this:

(defun c:Test ( / one two no1 ob1 ls1 no2 ob2 ls2 sr1 sr2 nos a b en1 en2)
 ;;	Tharwat - Date:13.Jun.2017	;;
(if (and (princ "\nSelect texts in 1st row :")
     (setq one (ssget "_:L" '((0 . "*TEXT"))))
     (princ "\nSelect texts in 2nd row :")
     (setq two (ssget "_:L" '((0 . "*TEXT"))))
     )
 (progn
   (repeat (setq no1 (sslength one))
     (setq ob1 (ssname one (setq no1 (1- no1)))
           ls1 (cons (list (car (cdr (assoc 10 (entget ob1)))) ob1) ls1)
       )
     )
   (repeat (setq no2 (sslength two))
     (setq ob2 (ssname two (setq no2 (1- no2)))
           ls2 (cons (list (car (cdr (assoc 10 (entget ob2)))) ob2) ls2)
       )
     )
   (setq sr1 (vl-sort ls1 '(lambda (a b) (< (car a) (car b))))
         sr2 (vl-sort ls2 '(lambda (a b) (< (car a) (car b))))
         nos 0
     )
   (while (and (setq a (nth nos sr1))
               (setq en1 (entget (cadr a)))
               (setq b (nth nos sr2))
               (setq en2 (entget (cadr b)))
            )
     (entmod (subst (assoc 1 en1) (assoc 1 en2) en2))
     (entmod (subst (assoc 1 en2) (assoc 1 en1) en1))
     (setq nos (1+ nos))
     )
   )
 )
(princ))

[ryankevin15]

Wow! that works perfectly, could we get it where it'll work where you could have 2-3 lines trade with 2-3 lines? Maybe an error if the selections don't match in terms of the number of lines?

 

[Roy_043]

You can quite easily perform this task manually with two move operations.

[Grrr]

I'd just swap the two selection sets by their centroids.

[rlx]

Try this:

(defun c:Test ( / one two no1 ob1 ls1 no2 ob2 ls2 sr1 sr2 nos a b en1 en2)
  ;;	Tharwat 
 
 
Beautiful!

[Tharwat]

Beautiful!

 

Thank you.

[rlx]

Thank you.

 

 

 

 

I did make something simular for my VT text editor but its much bigger and not nearly as elegant as yours. But it can do multiple rows (or columns) and also attributes.

 

 

; based on VT.lsp by Rlx
(defun c:SwapTextRows ( / p1 p2 el1 el2 tl1 tl2)
 (if (and (setq el1 (sfs (setq p1 (getpoint "\nSelect 1st corner source row(s) : "))
    (setq p2 (getcorner p1 "\nOther corner : "))))
   (setq el2 (sfs (setq p1 (getpoint "\nSelect 1st corner target row(s) : "))
    (setq p2 (getcorner p1 "\nOther corner : ")))))
   (progn
     (setq el1 (SortElist el1) tl1 (mapcar '(lambda (x) (cdr (assoc 1 (entget x)))) el1)
    el2 (SortElist el2) tl2 (mapcar '(lambda (x) (cdr (assoc 1 (entget x)))) el2))
     (us el1 tl2)
     (us el2 tl1)
   )
 )
)

;remove duplicates
(defun rdup ( i / o ) (vl-remove-if '(lambda (x) (cond ((vl-position x o) t) ((setq o (cons x o)) nil))) i))


;get insertion point
(defun getip ( e / ent)
 (setq ent (vlax-ename->vla-object e))
 (if (= (vla-get-alignment ent) 0)
   (reverse (cdr (reverse (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint ent))))))
   (reverse (cdr (reverse (vlax-safearray->list (vlax-variant-value (vla-get-TextAlignmentPoint ent))))))))



;el = elist , xl = x , yl = y , ml = matrix , sl = sorted elist
(defun SortElist ( %elist / el xl yl ml sl)
 (if %elist
   (progn
     (setq el (mapcar '(lambda (x) (list (getip x) x)) %elist) ; %elist -> el ( ((ip)e1) ((ip)e2) .. )
    xl (vl-sort (rdup (mapcar 'caar el)) '<) yl (vl-sort (rdup (mapcar 'cadar el)) '>))
     (foreach y yl (foreach x xl (setq ml (append ml (list (list x y))))));sort by row
     (setq sl (vl-remove 'nil (mapcar '(lambda (x) (if (assoc x el)(cadr (assoc x el)))) ml))))))


; update string
(defun us (%el %sl)
 (mapcar '(lambda (e s / en)(setq en (entget e))(entmod (subst (cons 1 s) (assoc 1 en) en))) %el %sl))


; (point) inside window
(defun inside_w (ent p1 p2 / ip )
 (setq ip (getip ent))
 (if (and (>= (car ip)  (min (car p1)(car p2)))   (<= (car ip)  (max (car p1)(car p2)))
   (>= (cadr ip) (min (cadr p1)(cadr p2))) (<= (cadr ip) (max (cadr p1)(cadr p2)))) t nil))



;scan for string
(defun sfs ( %p1 %p2 / i ss el e et)
(if (setq i 0 ss (ssget "c" %p1 %p2))
  (while (setq e (ssname ss i))
   (setq et (cdr (assoc 0 (entget e))) i (1+ i))
   (cond ((member et '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))(setq el (cons e el)))
  ((= et "INSERT") (mapcar '(lambda (x) (if (inside_w x %p1 %p2)(setq el (cons x el))))(get-ents e)))))) el)


; get (block) entities
(defun get-ents ( b / obj e lst)
 ;attrib
 (setq obj (vlax-ename->vla-object b))
 (if (eq :vlax-true (vla-get-HasAttributes obj)) (setq lst (mapcar 'vlax-vla-object->ename (vlax-invoke obj 'GetAttributes))))
 ;text , disable if only attributes are needed
 (setq e (tblobjname "block" (vla-Get-EffectiveName obj)))
 (while (setq e (entnext e)) (if (member (cdr (assoc 0 (entget e))) (list "TEXT" "ATTDEF")) (setq lst (cons e lst)))) lst)
;-------

I try to be as elegant as a 'dragon' can be ... but sometimes ... when it works , it works :-)

 

 

gr. Rlx

Edited June 14, 2017 by rlx

[Grrr]

Tharwat, you inspired me to play with this - grread version:

 

 

; Grrr - Exploded Table Shift Rows
; Credits to: Lee Mac, Tharwat
; 1. Select text/mtext that are representing cells from a exploded table
; 2. Use grread to shift their values
(defun C:test ( / SS->SortedMatrixL ShiftL L vL grr Stop )
 
 ; Map to the nth level items - Lee Mac :
 (defun mapncar ( n f l ) (if (< 0 n) (mapcar '(lambda ( x ) (mapncar (1- n) f x)) l) (mapcar f l) ) ) 
 
 ; (mysort (lambda (a b) (apply '< (mapcar 'car (list a b)))) pL)
 (defun mysort ( f L ) (mapcar (function (lambda (x) (nth x L))) (vl-sort-i L (function f))) )
 
 ;; Unique with Fuzz  -  Lee Mac
 ;; Returns a list with all elements considered duplicate to a given tolerance removed.
 (defun LM:UniqueFuzz ( l f / x r )
   (while l (setq x (car l) l (vl-remove-if (function (lambda ( y ) (equal x y f))) (cdr l)) r (cons x r) ) ) (reverse r)
 )
 
 (setq SS->SortedMatrixL
   (lambda ( fuzz / SS i o L tmpL rtn )  
     (cond
       ( (and (princ "\nSelect Text-Cells from Exploded Table to Shift: ") (setq SS (ssget "_:L-I" '((0 . "*TEXT")))))
         (repeat (setq i (sslength SS)) 
           (setq o (vlax-ename->vla-object (ssname SS (setq i (1- i)))))
           (setq L (cons (list (vlax-get o 'InsertionPoint) o) L))
         ); repeat 
         (foreach x (LM:UniqueFuzz (mapcar 'caar L) fuzz)
           (and 
             (setq tmpL (vl-remove-if-not (function (lambda (q) (equal x (caar q) fuzz))) L))
             (setq tmpL (mysort (lambda (a b) (apply '< (mapcar 'cadr (mapcar 'car (list a b))))) tmpL))
             (setq rtn (cons tmpL rtn))
           ); and
         ); foreach 
         (and rtn
           (setq rtn (vl-sort rtn (function (lambda (a b) (> (caaar a) (caaar b)))))) 
           (setq rtn (mapncar 1 '(lambda (x) (cadr x)) rtn))
         ); and
         rtn
       ); SS
     ); cond 
   ); lambda 
 ); setq SS->SortedMatrixL
 
 (setq ShiftL (lambda ( fl L ) (if (vl-consp L) (if fl (append (cdr L) (list (car L))) (append (list (last L)) (reverse (cdr (reverse L)))))))) 
 
 (cond 
   ( (not (setq L (SS->SortedMatrixL 1e-1))) (princ "\n Nothing Selected or Invalid Selection") ) ; '((o1 o2 o3) (o4 o5 o6) (o7 o8 o9))
   ( (not (and (vl-every 'vl-consp L) (apply '= (mapcar 'length L)))) (princ "\n Invalid Selection: Select equal amount of items per row.") )
   ( (princ "\nPress [W] or [s] to shift the Rows | [A] or [D] to shift the Columns <exit>: ")
     (setq vL (mapcar 'vla-get-TextString (apply 'append L))) ; values
     (while (not Stop) (setq grr (grread T)) 
       (and (or (equal grr '(2 13)) (member (car grr) '(3 25))) (setq Stop T)) ; Exit keys = ENTER or LMB/RMB
       (cond
         ( (and (= (car grr) 2) ) ; KBD
           (and
             (cond 
               ( (member (cadr grr) '(97 65)) (setq L (ShiftL T L)) )
               ( (member (cadr grr) '(100 68)) (setq L (ShiftL nil L)) )
               ( (member (cadr grr) '(119 87)) (setq L (mapcar (function (lambda (x) (ShiftL T x))) L)) )
               ( (member (cadr grr) '(115 83)) (setq L (mapcar (function (lambda (x) (ShiftL nil x))) L)) )
             ); cond
             (mapcar (function vla-put-TextString) (apply 'append L) vL)
           ); and 
         ); KBD
       ); cond			
     ); while
   )
 ); cond 
 (princ)
); defun C:test

 

Although I think that the simpliest way to "switch" both selections would be the way I mentioned in my previous post.

 

Not sure if posting the code of my previous demo will be a good idea, since I appreciate your programming work - and I don't feel like spreading freeware programs (although that was easy to assemble from a couple of subfunctions).

[Tharwat]

Tharwat, you inspired me to play with this - grread version:

Cool.

Nicely done.

[rlx]

Tharwat, you inspired me to play with this

 

 

Not sure if this is what requester wanted but brilliant nevertheless

[Grrr]

Thank you guys for the positive feedback!

Hopefully you could benefit from that code.

[rlx]

Thank you guys for the positive feedback!

Hopefully you could benefit from that code.

 

 

I'm not sure if the smoke comming out of my brain when looking at your code is a benefit for me right now , but in time I hope to understand your code