TABLE(UPDATE) BLOCK POINT REFERENCE VERTEX AND SIDES COLUMN (DONATION)

[leo321]

Hi Guys 

I come to ask for an adaptation in a table, I will post the images and attachment to better understand,

I'm grateful for some help. 

As this is important to me, I will make a donation of 20 U$ for those who can, as thanks for the help.

Seeyha

 

 

MODEL DWG LISP.rar

[marko_ribar]

Here you are...

I tested it only on AREA polylines and it worked...

 

(defun c:areatbl ( / LM:PolyCentroid vertn lst2table mid s lw pl c ml pll header lww cc arean v1 v2 plln k data pt )

  (vl-load-com)

  ;; Polygon Centroid  -  Lee Mac
  ;; Returns the WCS Centroid of an LWPolyline Polygon Entity

  (defun LM:PolyCentroid ( e / l )
    (foreach x (setq e (entget e))
      (if (= 10 (car x)) (setq l (cons (cdr x) l)))
    )
    (
      (lambda ( a )
        (if (not (equal 0.0 a 1e-8))
          (trans
            (mapcar '/
              (apply 'mapcar
                (cons '+
                  (mapcar
                    (function
                      (lambda ( a b )
                        (
                          (lambda ( m )
                            (mapcar
                              (function
                                (lambda ( c d ) (* (+ c d) m))
                              )
                              a b
                            )
                          )
                          (- (* (car a) (cadr b)) (* (car b) (cadr a)))
                        )
                      )
                    )
                    l (cons (last l) l)
                  )
                )
              )
              (list a a)
            )
            (cdr (assoc 210 e)) 0
          )
        )
      )
      (* 3.0
        (apply '+
          (mapcar
            (function
              (lambda ( a b )
                (- (* (car a) (cadr b)) (* (car b) (cadr a)))
              )
            )
            l (cons (last l) l)
          )
        )
      )
    )
  )

  (defun vertn ( blk / atts name )
    (if (eq (type blk) 'ename)
      (setq blk (vlax-ename->vla-object blk))
    )
    (setq atts (vlax-invoke blk 'getattributes))
    (foreach att atts
      (if (= (vla-get-tagstring att) "PONTO")
        (setq name (vla-get-textstring att))
      )
    )
    name
  )

  (defun lst2table ( lst pt / as cols rh cw ttl data rows sty tbl r k )
    (vl-load-com)
    (setq rh
      (vla-gettextheight
        (setq sty
          (vla-item
            (vla-item (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))) "acad_tablestyle")
            (getvar 'ctablestyle)
          )
        )
        acdatarow
      )
    )
    (setq pt (vlax-3d-point (trans pt 1 0))
          as (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
          cols (if (listp (caadr lst)) (length (caadr lst)) (length (car lst)))
          ttl (if (not (listp (car lst))) (car lst))
          data (if (not (listp (car lst))) (cadr lst) lst)
          data (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (if (null y) "" y)) x)) data)
          rows (if (not (listp (car lst))) (1+ (length data)) (length data))
    )
    (if ttl
      (vla-enablemergeall sty "Title" :vlax-true)
      (vla-enablemergeall sty "Title" :vlax-false)
    )
    (setq cw (apply 'max (mapcar '(lambda ( x ) (apply 'max (mapcar 'strlen x))) (apply 'mapcar (cons 'list data)))))
    (setq tbl (vla-addtable as pt rows cols (* 2.5 rh) (* 0.8 cw)))
    (if (vlax-property-available-p tbl 'regeneratetablesuppressed t)
      (vla-put-regeneratetablesuppressed tbl :vlax-true)
    )
    (vla-put-stylename tbl (getvar 'ctablestyle))
    (if ttl
      (progn
        (vla-settext tbl 0 0 ttl)
        (setq r 1)
      )
      (setq r 0)
    )
    (foreach i data
      (setq k -1)
      (foreach ii i
        (vla-settext tbl r (setq k (1+ k)) ii)
        (cond
          ( (and ttl (> r 1))
            (vla-setcellalignment tbl r k acmiddlecenter)
          )
          ( (and (not ttl) (= r 0))
            nil
          )
          ( t
            (vla-setcellalignment tbl r k acmiddlecenter)
          )
        )
      )
      (setq r (1+ r))
    )
    (setq cw (mapcar '(lambda ( x ) (apply 'max (mapcar 'strlen x))) (apply 'mapcar (cons 'list data))))
    (setq k -1)
    (foreach c cw
      (vla-setcolumnwidth tbl (setq k (1+ k)) (* c rh 1.25))
    )
    (if (vlax-property-available-p tbl 'regeneratetablesuppressed t)
      (vla-put-regeneratetablesuppressed tbl :vlax-false)
    )
    (vla-update tbl)
    (princ)
  )

  (defun mid ( p1 p2 )
    (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
  )

  (prompt "\nPick closed LWPOLYLINE without arced segments...")
  (if (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1) (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))))
    (progn
      (setq lw (ssname s 0))
      (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lw))))
      (setq c (LM:PolyCentroid lw))
      (setq ml (mapcar '(lambda ( a b ) (mid a b)) pl (append (cdr pl) (list (car pl)))))
      (setq pll (mapcar '(lambda ( a b c ) (list a b c)) pl ml (append (cdr pl) (list (car pl)))))
      (setq header (cdr (assoc 1 (entget (ssname (ssget "_C" (mapcar '+ (trans c 0 1) '(-10.0 -10.0)) (mapcar '+ (trans c 0 1) '(10.0 10.0)) '((0 . "TEXT"))) 0)))))
      (foreach x pll
        (setq lww (ssname (ssdel lw (ssget "_C" (mapcar '+ (trans (cadr x) lw 1) '(-0.01 -0.01)) (mapcar '+ (trans (cadr x) lw 1) '(0.01 0.01)) '((0 . "LWPOLYLINE")))) 0))
        (setq cc (LM:PolyCentroid lww))
        (setq arean (cdr (assoc 1 (entget (ssname (ssget "_C" (mapcar '+ (trans cc 0 1) '(-10.0 -10.0)) (mapcar '+ (trans cc 0 1) '(10.0 10.0)) '((0 . "TEXT"))) 0)))))
        (setq v1 (vertn (ssname (ssget "_C" (mapcar '+ (trans (car x) lw 1) '(-0.01 -0.01)) (mapcar '+ (trans (car x) lw 1) '(0.01 0.01)) '((0 . "INSERT") (66 . 1))) 0)))
        (setq v2 (vertn (ssname (ssget "_C" (mapcar '+ (trans (caddr x) lw 1) '(-0.01 -0.01)) (mapcar '+ (trans (caddr x) lw 1) '(0.01 0.01)) '((0 . "INSERT") (66 . 1))) 0)))
        (setq plln (cons (list v1 arean v2) plln))
      )
      (setq plln (reverse plln))
      (setq k -1)
      (setq data (mapcar '(lambda ( x ) (setq k (1+ k)) (list (car x) (rtos (caar (nth k pll)) 2 3) (rtos (cadar (nth k pll)) 2 3) "" (cadr x))) plln))
      (setq data (cons (list "Da" "Coord. E" "Coord. N" "Dist\U+00E2ncia" "SIDES") data))
      (setq data (list header data))
      (initget 1)
      (setq pt (getpoint "\nSpecify insertion Upper Left point for table..."))
      (lst2table data pt)
    )
    (prompt "\nMissed... Try next time...")
  )
  (princ)
)

 

HTH. M.R.

Edited June 14, 2021 by marko_ribar

[marko_ribar]

However, if I was to be asked how should table look like, I'd suggest something like this (double vertices in table represent segments of polyline)... BTW. It works and for S areas...

 

(defun c:areatbl ( / LM:PolyCentroid vertn lst2table mid s lw pl c ml pll header lww cc arean v1 v2 plln plll k data pt )

  (vl-load-com)

  ;; Polygon Centroid  -  Lee Mac
  ;; Returns the WCS Centroid of an LWPolyline Polygon Entity

  (defun LM:PolyCentroid ( e / l )
    (foreach x (setq e (entget e))
      (if (= 10 (car x)) (setq l (cons (cdr x) l)))
    )
    (
      (lambda ( a )
        (if (not (equal 0.0 a 1e-8))
          (trans
            (mapcar '/
              (apply 'mapcar
                (cons '+
                  (mapcar
                    (function
                      (lambda ( a b )
                        (
                          (lambda ( m )
                            (mapcar
                              (function
                                (lambda ( c d ) (* (+ c d) m))
                              )
                              a b
                            )
                          )
                          (- (* (car a) (cadr b)) (* (car b) (cadr a)))
                        )
                      )
                    )
                    l (cons (last l) l)
                  )
                )
              )
              (list a a)
            )
            (cdr (assoc 210 e)) 0
          )
        )
      )
      (* 3.0
        (apply '+
          (mapcar
            (function
              (lambda ( a b )
                (- (* (car a) (cadr b)) (* (car b) (cadr a)))
              )
            )
            l (cons (last l) l)
          )
        )
      )
    )
  )

  (defun vertn ( blk / atts name )
    (if (eq (type blk) 'ename)
      (setq blk (vlax-ename->vla-object blk))
    )
    (setq atts (vlax-invoke blk 'getattributes))
    (foreach att atts
      (if (= (vla-get-tagstring att) "PONTO")
        (setq name (vla-get-textstring att))
      )
    )
    name
  )

  (defun lst2table ( lst pt / as cols rh cw ttl data rows sty tbl r k )
    (vl-load-com)
    (setq rh
      (vla-gettextheight
        (setq sty
          (vla-item
            (vla-item (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))) "acad_tablestyle")
            (getvar 'ctablestyle)
          )
        )
        acdatarow
      )
    )
    (setq pt (vlax-3d-point (trans pt 1 0))
          as (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
          cols (if (listp (caadr lst)) (length (caadr lst)) (length (car lst)))
          ttl (if (not (listp (car lst))) (car lst))
          data (if (not (listp (car lst))) (cadr lst) lst)
          data (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (if (null y) "" y)) x)) data)
          rows (if (not (listp (car lst))) (1+ (length data)) (length data))
    )
    (if ttl
      (vla-enablemergeall sty "Title" :vlax-true)
      (vla-enablemergeall sty "Title" :vlax-false)
    )
    (setq cw (apply 'max (mapcar '(lambda ( x ) (apply 'max (mapcar 'strlen x))) (apply 'mapcar (cons 'list data)))))
    (setq tbl (vla-addtable as pt rows cols (* 2.5 rh) (* 0.8 cw)))
    (if (vlax-property-available-p tbl 'regeneratetablesuppressed t)
      (vla-put-regeneratetablesuppressed tbl :vlax-true)
    )
    (vla-put-stylename tbl (getvar 'ctablestyle))
    (if ttl
      (progn
        (vla-settext tbl 0 0 ttl)
        (setq r 1)
      )
      (setq r 0)
    )
    (foreach i data
      (setq k -1)
      (foreach ii i
        (vla-settext tbl r (setq k (1+ k)) ii)
        (cond
          ( (and ttl (> r 1))
            (vla-setcellalignment tbl r k acmiddlecenter)
          )
          ( (and (not ttl) (= r 0))
            nil
          )
          ( t
            (vla-setcellalignment tbl r k acmiddlecenter)
          )
        )
      )
      (setq r (1+ r))
    )
    (setq cw (mapcar '(lambda ( x ) (apply 'max (mapcar 'strlen x))) (apply 'mapcar (cons 'list data))))
    (setq k -1)
    (foreach c cw
      (vla-setcolumnwidth tbl (setq k (1+ k)) (* c rh 1.25))
    )
    (if (vlax-property-available-p tbl 'regeneratetablesuppressed t)
      (vla-put-regeneratetablesuppressed tbl :vlax-false)
    )
    (vla-update tbl)
    (princ)
  )

  (defun mid ( p1 p2 )
    (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
  )

  (vl-cmdf "_.zoom" "_e")
  (prompt "\nPick closed LWPOLYLINE without arced segments...")
  (if (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1) (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))))
    (progn
      (setq lw (ssname s 0))
      (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lw))))
      (setq c (LM:PolyCentroid lw))
      (setq ml (mapcar '(lambda ( a b ) (mid a b)) pl (append (cdr pl) (list (car pl)))))
      (setq pll (mapcar '(lambda ( a b c ) (list a b c)) pl ml (append (cdr pl) (list (car pl)))))
      (setq header (cdr (assoc 1 (entget (ssname (ssget "_C" (mapcar '+ (trans c 0 1) '(-10.0 -10.0)) (mapcar '+ (trans c 0 1) '(10.0 10.0)) '((0 . "TEXT"))) 0)))))
      (foreach x pll
        (setq lww (ssname (ssdel lw (ssget "_C" (mapcar '+ (trans (cadr x) lw 1) '(-0.01 -0.01)) (mapcar '+ (trans (cadr x) lw 1) '(0.01 0.01)) '((0 . "LWPOLYLINE")))) 0))
        (if lww
          (progn
            (setq cc (LM:PolyCentroid lww))
            (setq arean (cdr (assoc 1 (entget (ssname (ssget "_C" (mapcar '+ (trans cc 0 1) '(-10.0 -10.0)) (mapcar '+ (trans cc 0 1) '(10.0 10.0)) '((0 . "TEXT"))) 0)))))
            (setq v1 (vertn (ssname (ssget "_C" (mapcar '+ (trans (car x) lw 1) '(-0.01 -0.01)) (mapcar '+ (trans (car x) lw 1) '(0.01 0.01)) '((0 . "INSERT") (66 . 1))) 0)))
            (setq v2 (vertn (ssname (ssget "_C" (mapcar '+ (trans (caddr x) lw 1) '(-0.01 -0.01)) (mapcar '+ (trans (caddr x) lw 1) '(0.01 0.01)) '((0 . "INSERT") (66 . 1))) 0)))
            (setq plln (cons (list v1 arean v2) plln))
            (setq plll (cons x plll))
          )
        )
      )
      (setq plln (reverse plln))
      (setq k -1)
      (setq data (apply 'append (mapcar '(lambda ( x ) (setq k (1+ k)) (list (list (car x) (rtos (caar (nth k plll)) 2 3) (rtos (cadar (nth k plll)) 2 3) (rtos (distance (car (nth k plll)) (caddr (nth k plll))) 2 3) (cadr x)) (list (caddr x) (rtos (caaddr (nth k plll)) 2 3) (rtos (cadr (caddr (nth k plll))) 2 3) (rtos (distance (car (nth k plll)) (caddr (nth k plll))) 2 3) (cadr x)))) plln)))
      (setq data (cons (list "Da" "Coord. E" "Coord. N" "Dist\U+00E2ncia" "SIDES") data))
      (setq data (list header data))
      (initget 1)
      (setq pt (getpoint "\nSpecify insertion Upper Left point for table..."))
      (lst2table data pt)
    )
    (prompt "\nMissed... Try next time...")
  )
  (vl-cmdf "_.zoom" "_p")
  (princ)
)

 

Regards, M.R.

Edited June 14, 2021 by marko_ribar

[leo321]

marko_ribar

 

thanks for the help, It was fast thanks a lot.

just send the link for me do it.

 

 

 

 

 

[leo321]

One review,

check this dwg i dodnt know why brake it.  if not find a side can return a null (or any word).

model test2.dwg

[marko_ribar]

@leo321

You must modify position of TEXT entities prior running "atratbl.lsp" to be at exact position of polygons centroids... Some errors arise due to placement of CAD entities far from origin point 0,0,0... I had to revise my code and I am posting new one which you must run before main routine...

It should be working as desired after applying fix...

 

MAIN ROUTINE : areatbl.lsp

 

(defun c:areatbl ( / *error* LM:PolyCentroid vertn lst2table mid vsz s lw pl p c ml pll header lww cc arean v1 v2 plln plll k data pt tbl rn )

  (vl-load-com)

  (defun *error* ( m )
    (if vsz
      (while (not (equal vsz (getvar 'viewsize) 1e-6))
        (command-s "_.zoom" "_p")
      )
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  ;; Polygon Centroid  -  Lee Mac
  ;; Returns the WCS Centroid of an LWPolyline Polygon Entity

  (defun LM:PolyCentroid ( e / l )
    (foreach x (setq e (entget e))
      (if (= 10 (car x)) (setq l (cons (cdr x) l)))
    )
    (
      (lambda ( a )
        (if (not (equal 0.0 a 1e-8))
          (trans
            (mapcar '/
              (apply 'mapcar
                (cons '+
                  (mapcar
                    (function
                      (lambda ( a b )
                        (
                          (lambda ( m )
                            (mapcar
                              (function
                                (lambda ( c d ) (* (+ c d) m))
                              )
                              a b
                            )
                          )
                          (- (* (car a) (cadr b)) (* (car b) (cadr a)))
                        )
                      )
                    )
                    l (cons (last l) l)
                  )
                )
              )
              (list a a)
            )
            (cdr (assoc 210 e)) 0
          )
        )
      )
      (* 3.0
        (apply '+
          (mapcar
            (function
              (lambda ( a b )
                (- (* (car a) (cadr b)) (* (car b) (cadr a)))
              )
            )
            l (cons (last l) l)
          )
        )
      )
    )
  )

  (defun vertn ( blk / atts name )
    (if (eq (type blk) 'ename)
      (setq blk (vlax-ename->vla-object blk))
    )
    (setq atts (vlax-invoke blk 'getattributes))
    (foreach att atts
      (if (= (vla-get-tagstring att) "PONTO")
        (setq name (vla-get-textstring att))
      )
    )
    name
  )

  (defun lst2table ( lst pt / as cols rh cw ttl data rows sty tbl r k )
    (vl-load-com)
    (setq rh
      (vla-gettextheight
        (setq sty
          (vla-item
            (vla-item (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))) "acad_tablestyle")
            (getvar 'ctablestyle)
          )
        )
        acdatarow
      )
    )
    (setq pt (vlax-3d-point (trans pt 1 0))
          as (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
          cols (if (listp (caadr lst)) (length (caadr lst)) (length (car lst)))
          ttl (if (not (listp (car lst))) (car lst))
          data (if (not (listp (car lst))) (cadr lst) lst)
          data (mapcar '(lambda ( x ) (mapcar '(lambda ( y ) (if (null y) "" y)) x)) data)
          rows (if (not (listp (car lst))) (1+ (length data)) (length data))
    )
    (if ttl
      (vla-enablemergeall sty "Title" :vlax-true)
      (vla-enablemergeall sty "Title" :vlax-false)
    )
    (setq cw (apply 'max (mapcar '(lambda ( x ) (apply 'max (mapcar 'strlen x))) (apply 'mapcar (cons 'list data)))))
    (setq tbl (vla-addtable as pt rows cols (* 2.5 rh) (* 0.8 cw)))
    (if (vlax-property-available-p tbl 'regeneratetablesuppressed t)
      (vla-put-regeneratetablesuppressed tbl :vlax-true)
    )
    (vla-put-stylename tbl (getvar 'ctablestyle))
    (if ttl
      (progn
        (vla-settext tbl 0 0 ttl)
        (setq r 1)
      )
      (setq r 0)
    )
    (foreach i data
      (setq k -1)
      (foreach ii i
        (vla-settext tbl r (setq k (1+ k)) ii)
        (cond
          ( (and ttl (> r 1))
            (vla-setcellalignment tbl r k acmiddlecenter)
          )
          ( (and (not ttl) (= r 0))
            nil
          )
          ( t
            (vla-setcellalignment tbl r k acmiddlecenter)
          )
        )
      )
      (setq r (1+ r))
    )
    (setq cw (mapcar '(lambda ( x ) (apply 'max (mapcar 'strlen x))) (apply 'mapcar (cons 'list data))))
    (setq k -1)
    (foreach c cw
      (vla-setcolumnwidth tbl (setq k (1+ k)) (* c rh 1.25))
    )
    (if (vlax-property-available-p tbl 'regeneratetablesuppressed t)
      (vla-put-regeneratetablesuppressed tbl :vlax-false)
    )
    (vla-update tbl)
    tbl
  )

  (defun mid ( p1 p2 )
    (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
  )

  (setq vsz (getvar 'viewsize))
  (prompt "\nPick closed LWPOLYLINE without arced segments...")
  (if (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1) (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))))
    (progn
      (vl-cmdf "_.zoom" "_e")
      (setq lw (ssname s 0))
      (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lw))))
      (vla-move (vlax-ename->vla-object lw) (vlax-3d-point (setq p (vlax-curve-getstartpoint lw))) (vlax-3d-point '(0 0 0)))
      (setq c (LM:PolyCentroid lw))
      (setq c (mapcar '+ p c))
      (vla-move (vlax-ename->vla-object lw) (vlax-3d-point '(0 0 0)) (vlax-3d-point p))
      (setq ml (mapcar '(lambda ( a b ) (mid a b)) pl (append (cdr pl) (list (car pl)))))
      (setq pll (mapcar '(lambda ( a b c ) (list a b c)) pl ml (append (cdr pl) (list (car pl)))))
      (setq header (cdr (assoc 1 (entget (ssname (ssget "_C" (mapcar '+ (trans c 0 1) '(-0.5 -0.5)) (mapcar '+ (trans c 0 1) '(0.5 0.5)) '((0 . "TEXT"))) 0)))))
      (foreach x pll
        (setq lww (ssname (ssdel lw (ssget "_C" (mapcar '+ (trans (cadr x) lw 1) '(-0.01 -0.01)) (mapcar '+ (trans (cadr x) lw 1) '(0.01 0.01)) '((0 . "LWPOLYLINE")))) 0))
        (if lww
          (progn
            (vla-move (vlax-ename->vla-object lww) (vlax-3d-point (setq p (vlax-curve-getstartpoint lww))) (vlax-3d-point '(0 0 0)))
            (setq cc (LM:PolyCentroid lww))
            (setq cc (mapcar '+ cc p))
            (vla-move (vlax-ename->vla-object lww) (vlax-3d-point '(0 0 0)) (vlax-3d-point p))
            (setq arean (cdr (assoc 1 (entget (ssname (ssget "_C" (mapcar '+ (trans cc 0 1) '(-0.5 -0.5)) (mapcar '+ (trans cc 0 1) '(0.5 0.5)) '((0 . "TEXT"))) 0)))))
            (setq v1 (vertn (ssname (ssget "_C" (mapcar '+ (trans (car x) lw 1) '(-0.01 -0.01)) (mapcar '+ (trans (car x) lw 1) '(0.01 0.01)) '((0 . "INSERT") (66 . 1))) 0)))
            (setq v2 (vertn (ssname (ssget "_C" (mapcar '+ (trans (caddr x) lw 1) '(-0.01 -0.01)) (mapcar '+ (trans (caddr x) lw 1) '(0.01 0.01)) '((0 . "INSERT") (66 . 1))) 0)))
            (setq plln (cons (list v1 arean v2) plln))
            (setq plll (cons x plll))
          )
        )
      )
      (setq plln (reverse plln))
      (setq k -1)
      (setq data (apply 'append (mapcar '(lambda ( x ) (setq k (1+ k)) (list (list (car x) (rtos (caar (nth k plll)) 2 3) (rtos (cadar (nth k plll)) 2 3) (rtos (distance (car (nth k plll)) (caddr (nth k plll))) 2 3) (cadr x)) (list (caddr x) (rtos (caaddr (nth k plll)) 2 3) (rtos (cadr (caddr (nth k plll))) 2 3) (rtos (distance (car (nth k plll)) (caddr (nth k plll))) 2 3) (cadr x)))) plln)))
      (setq data (cons (list "De" "Coord. E" "Coord. N" "Dist\U+00E2ncia" "SIDES") data))
      (setq data (list header data))
      (vl-cmdf "_.zoom" "_p")
      (initget 1)
      (setq pt (getpoint "\nSpecify insertion Upper Left point for table..."))
      (setq tbl (lst2table data pt))
      (setq rn (length (cadr data)))
      (setq k 0)
      (repeat (/ rn 2)
        (setq k (+ k 2))
        (vla-mergecells tbl k (1+ k) 3 3)
      )
    )
    (prompt "\nMissed... Try next time...")
  )
  (*error* nil)
)

 

Additional routine which you must run prior main routine to apply TEXT positions fix :

 

(defun c:fixtextpts2centroids ( / LM:PolyCentroid car-sort ss ss1 ss2 i1 i2 lwl txl c cl p txx )

  (vl-load-com)

  ;; Polygon Centroid  -  Lee Mac
  ;; Returns the WCS Centroid of an LWPolyline Polygon Entity

  (defun LM:PolyCentroid ( e / l )
    (foreach x (setq e (entget e))
      (if (= 10 (car x)) (setq l (cons (cdr x) l)))
    )
    (
      (lambda ( a )
        (if (not (equal 0.0 a 1e-8))
          (trans
            (mapcar '/
              (apply 'mapcar
                (cons '+
                  (mapcar
                    (function
                      (lambda ( a b )
                        (
                          (lambda ( m )
                            (mapcar
                              (function
                                (lambda ( c d ) (* (+ c d) m))
                              )
                              a b
                            )
                          )
                          (- (* (car a) (cadr b)) (* (car b) (cadr a)))
                        )
                      )
                    )
                    l (cons (last l) l)
                  )
                )
              )
              (list a a)
            )
            (cdr (assoc 210 e)) 0
          )
        )
      )
      (* 3.0
        (apply '+
          (mapcar
            (function
              (lambda ( a b )
                (- (* (car a) (cadr b)) (* (car b) (cadr a)))
              )
            )
            l (cons (last l) l)
          )
        )
      )
    )
  )

  (defun car-sort ( lst cmp / rtn )
    (setq rtn (car lst))
    (foreach itm (cdr lst)
      (if (apply cmp (list itm rtn))
        (setq rtn itm)
      )
    )
    rtn
  )

  (vl-cmdf "_.zoom" "_e")
  (prompt "\nSelect closed LWPOLYLINES without arced segments and TEXT entities describing polygons...")
  (if (setq ss (ssget "_:L" '((-4 . "<or") (0 . "TEXT") (-4 . "<and") (0 . "LWPOLYLINE") (-4 . "&=") (70 . 1) (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>") (-4 . "and>") (-4 . "or>"))))
    (progn
      (setq ss1 (ssget "_P" '((0 . "LWPOLYLINE"))))
      (vl-cmdf "_.select" ss "")
      (setq ss2 (ssget "_P" '((0 . "TEXT"))))
      (repeat (setq i1 (sslength ss1))
        (setq lwl (cons (ssname ss1 (setq i1 (1- i1))) lwl))
      )
      (repeat (setq i2 (sslength ss2))
        (setq txl (cons (ssname ss2 (setq i2 (1- i2))) txl))
      )
      (foreach lw lwl
        (vla-move (vlax-ename->vla-object lw) (vlax-3d-point (setq p (vlax-curve-getstartpoint lw))) (vlax-3d-point '(0 0 0)))
        (setq c (LM:PolyCentroid lw))
        (setq cl (cons (mapcar '+ p c) cl))
        (vla-move (vlax-ename->vla-object lw) (vlax-3d-point '(0 0 0)) (vlax-3d-point p))
      )
      (foreach tx txl
        (setq p (cdr (assoc 10 (setq txx (entget tx)))))
        (setq txx (subst (cons 10 (car-sort cl '(lambda ( a b ) (< (distance p a) (distance p b))))) (assoc 10 txx) txx))
        (setq txx (subst (cons 11 (car-sort cl '(lambda ( a b ) (< (distance p a) (distance p b))))) (assoc 11 txx) txx))
        (entupd (cdr (assoc -1 (entmod txx))))
      )
    )
  )
  (vl-cmdf "_.zoom" "_p")
  (princ)
)

 

That's all...

You owe me a lunch...

 

HTH., M.R.

Edited June 16, 2021 by marko_ribar

[leo321]

Right! I will gladly send your lunch(kkkk)
of course it's symbolic, because I value this talent a lot.

thanks a lot

[leo321]

Sorry to bother, when you have time

 

I did some test, the table returned a bit messy.
I don't know if it happened to you

Drawing TEST3.dwg