Jump to content

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

leo321

By leo321
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

leo321 Contributor

leo321

Posted
Posted

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

 

 

DWG AREA.jpg

MODEL DWG LISP.rar

marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

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 by marko_ribar
marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

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 by marko_ribar
  • Thanks 1
leo321 Contributor

leo321

Posted
  • Author
Posted

marko_ribar

 

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

just send the link for me do it.

 

 

 

 

 

leo321 Contributor

leo321

Posted
  • Author
Posted

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 Veteran

marko_ribar

Posted
Posted (edited)

@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 by marko_ribar
leo321 Contributor

leo321

Posted
  • Author
Posted

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

thanks a lot

leo321 Contributor

leo321

Posted
  • Author
Posted

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

TEST3.jpg

Drawing TEST3.dwg

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.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...