Author Topic: Help to update a table coordinate lisp  (Read 1398 times)

0 Members and 1 Guest are viewing this topic.

mhy3sx

  • Newt
  • Posts: 106
Help to update a table coordinate lisp
« on: November 25, 2023, 11:45:25 AM »
Hi I am using ZWCAD and don't support getpropertyvalue

I get the idea from BIGAL's code from the same problem for other lisp code. The code almost works perfect export the coordinates in the table ,but not the point numbers in the first column.

Code - Auto/Visual Lisp: [Select]
  1.  
  2. (defun rh:yn (msg default / tmp) (initget 6 "Yes No") (cond ( (getkword (strcat msg " [Yes/No] < " default " > : "))) (default)))
  3.  
  4. (defun rh:pchk (vlst pt fz / tmp vl) (setq vl vlst) (if (equal pt (car vlst) fz) vlst (while (not (equal pt (car vlst) fz)) (setq tmp (car vlst) vlst (append (cdr vlst) (list tmp))))))
  5. ;------------------------------
  6. ;; From BIGAL
  7. (defun aH:getatt (blk tagn)
  8. (setq atts (vlax-invoke (vlax-ename->vla-object blk) 'getattributes))
  9. (foreach att atts
  10. (if (= (vla-get-tagstring att) tagn)
  11. )
  12. )
  13. )
  14. ;------------------------------
  15.  
  16. (defun rh:onpl (blk pl fuzz / ipt p vp d vpt cpt vpt)
  17.   (setq p (vlax-curve-getparamatpoint pl (setq ipt (vlax-get (vlax-ename->vla-object blk) 'insertionpoint))))
  18.   (cond (p
  19.           (setq vp (if (> (rem p 1.0) 0.4999) (1+ (fix p)) (fix p))
  20.                 d (distance ipt (setq vpt (vlax-curve-getpointatparam pl vp)))
  21.           );end_setq
  22.           (if (> d fuzz) (setq vpt nil))
  23.         )
  24.         (t
  25.           (setq cpt (vlax-curve-getclosestpointto pl ipt)
  26.                 p (vlax-curve-getparamatpoint pl cpt)
  27.           );end_setq
  28.           (cond ( (< (distance ipt cpt) fuzz)
  29.                   (setq vp (if (> (rem p 1.0) 0.4999) (1+ (fix p)) (fix p))
  30.                         d (distance cpt (setq vpt (vlax-curve-getpointatparam pl vp)))
  31.                   )
  32.                   (if (> d fuzz) (setq vpt nil))
  33.                 )
  34.           )
  35.         )
  36.   );end_cond
  37.   vpt
  38. );end_defun
  39.  
  40. (defun rh:pcw-p ( obj / tmp flg)
  41.   (if (= (type obj) 'ENAME) (setq obj (vlax-ename->vla-object obj)))
  42.   (cond ( (vlax-method-applicable-p obj 'offset)
  43.           (setq tmp (car (vlax-invoke obj 'offset -0.005))
  44.                 flg (if (> (vlax-get tmp 'area) (vlax-get obj 'area)) T nil)
  45.           );end_setq
  46.           (vla-delete tmp)
  47.           flg
  48.         )
  49.         (t "")
  50.   );end_cond
  51. );end_defun
  52.  
  53.  
  54. ;;Polyline Area Table
  55. (defun c:PAT2 ( / *error* sv_lst sv_vals c_doc t_spc acc cas tm iunits dut aut ccf acf fuzz dfuzz flg ent obj pt vlst cw nme tlst ss cnt bent vtx)
  56.  
  57.   (defun *error* ( msg )
  58.     (mapcar 'setvar sv_lst sv_vals)
  59.     (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nAn Error : " msg " occurred.")))
  60.     (princ)
  61.   );end_local_*error*_defun
  62.  
  63.   (setq sv_lst (list 'cmdecho 'osmode 'dynmode 'cannoscale 'tilemode)
  64.         sv_vals (mapcar 'getvar sv_lst)
  65.         acc (getvar 'luprec)
  66.   );end_setq
  67.  
  68.   (cond ( (= 0 (setq tm (getvar 'tilemode))) (setvar 'tilemode 1) (setq tm 1 cas (getvar 'cannoscale)))
  69.         (t (setq cas (getvar 'cannoscale)))
  70.   );end_cond
  71.  
  72.   (cond ( (= (setq iunits (getvar 'insunits)) 6) (setq dut "m." aut (strcat "sq." dut) ccf 1.0 acf 1.0 fuzz 0.001 dfuzz 0.01)); CHANGE so dut=distance & aut=Area
  73.         ( (= iunits 4)
  74.           (setq dut "mm" aut (strcat "sq." dut) ccf 1.0 acf 1.0 fuzz 1.0 dfuzz 10.0); CHANGE dut & aut
  75.           (if (= (rh:yn "\nInsertion Units are Millimetres. Convert Areas & Coordinates to Metres : ?" "No") "Yes")
  76.             (setq dut "m" aut (strcat "sq." dut) ccf 1000.0 acf 1.0e6); CHANGE dut & aut
  77.           );end_if
  78.         )
  79.         (t (setq iunits nil ccf 1.0 acf 1.0 fuzz 1.0 dfuzz 1.0))
  80.   );end_cond
  81.  
  82.   (mapcar 'setvar sv_lst '( 0 1 1))
  83.  
  84.  
  85.   (while (not flg)
  86.     (setq ent (car (entsel "\nSelect close LWPolyline : "))
  87.           obj (vlax-ename->vla-object ent)
  88.     );end_setq
  89.     (cond ( (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
  90.             (setq pt (reverse (cdr (reverse (getpoint "\nSelect the first point : "))))
  91.                   vlst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent)))
  92.             );end_setq
  93.  
  94.  
  95. (setq blkss (ssget "_X" '((2 . "Point,Dianomi,Ktir,DAS,KOROT,KOKAEK,APAL,NAPAL"))))
  96.  
  97.             (cond ( (equal (car vlst) (last vlst) fuzz)
  98.                     (setq vlst (reverse (cdr (reverse vlst))))
  99.                     (if (= :vlax-false (vlax-get-property obj 'closed)) (vlax-put-property obj 'closed :vlax-true))
  100.                     (setq flg T cw (rh:pcw-p ent))
  101.                   )
  102.                   ( (= :vlax-true (vlax-get-property obj 'closed)) (setq flg T cw (rh:pcw-p ent)))
  103.                   (t (alert "NOT a CLOSED LWPolyline"))
  104.             )
  105.             (if (not cw) (setq vlst (reverse vlst)))
  106.           )
  107.           (t (alert "NOT a LWPolyline"))
  108.     );end_cond
  109.   );end_while
  110.  
  111.   (setvar 'osmode 0)
  112.   (setq vlst (rh:pchk vlst pt fuzz))
  113.  
  114.   (cond (flg
  115.           (setq nme (strcase (getstring "\nGive area name : "))
  116.                 tlst (cons (list (strcat "A{\\H0.8x;" nme "} = " (rtos (/ (vlax-curve-getarea ent) acf) 2 2) " " aut)) tlst)
  117.                 ;tlst (cons (list "A=1/2 S(Xi + Xi+1)(Yi - Yi+1)") tlst)
  118.                 tlst (cons (list "A = 1/2 &#931;(X{\\H0.8x;i} + X{\\H0.8x;i+1})(Y{\\H0.8x;i} - Y{\\H0.8x;i+1})") tlst)
  119.           );end_setq
  120.           (vla-regen c_doc acActiveViewport)
  121.           (setq ss (ssget "F" vlst '((0 . "INSERT") (66 . 1))))
  122.           (vla-regen c_doc acActiveViewport)
  123.           (repeat (setq cnt (sslength ss))
  124.           (setq bent (ssname ss (setq cnt (1- cnt)))
  125.                  vtx (rh:onpl bent ent dfuzz)
  126.           );end_setq
  127.            ;(if vtx (setq tlst (cons (list (getpropertyvalue bent "POINT") (rtos (/ (car vtx) ccf) 2 acc) (rtos (/ (cadr vtx) ccf) 2 acc)) tlst)))
  128.             (if vtx (setq tlst (cons (list (ah:getatt bent "POINT") (rtos (/ (car vtx) ccf) 2 acc) (rtos (/ (cadr vtx) ccf) 2 acc)) tlst)))
  129.           );end_repeat
  130.  
  131.  
  132.  
  133. ;(setq tlst (cons (list "A/A" (strcat "X" (if iunits (strcat " (" dut ")") " (?)")) (strcat "Y" (if iunits (strcat " (" dut ")") " (?)"))) tlst)) ;
  134.  (setq tlst (cons (list "A/A" (strcat "X" (if iunits (strcat "") " (?)")) (strcat "Y" (if iunits (strcat "") " (?)"))) tlst));
  135.  
  136.  
  137. ;---------------------------------------------------------------;
  138. ;                     Channge to Paper space                    ;
  139. ;---------------------------------------------------------------;
  140.  
  141.           (initget "Modelspace Paperspace")
  142.           (setq t_spc (cond ( (getkword "\nInsert table : ? [Modelspace/Paperspace] <Modelspace>")) ("Modelspace"))
  143.           )
  144.           (if (and (= tm 1) (= t_spc "Paperspace")) (setvar 'tilemode 0))
  145.  
  146. ;------------------------------------------------------------------------------------------------------------------------
  147.  
  148.           (rh:AMT c_doc (strcat "Coordinate Table " nme) tlst)
  149.         )
  150.         (t (alert "No Polyline Selected"))
  151.   );end_cond
  152.  
  153.   (mapcar 'setvar sv_lst sv_vals)
  154.   (princ)
  155. );end_defun
  156.  
  157. (defun rh:AMT ( doc title lst / spc ipt t_obj rows cols row cell rdat)
  158.   (vl-cmdf "_LAYER" "_M"  "Table" "_C" "7" "" "")
  159.   (setq spc (vlax-get-property doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
  160.         ipt (getpoint "\nSelect Table Insertion Point: ")
  161.         t_obj (vla-addtable spc (vlax-3d-point ipt) (1+ (length lst)) (length (car lst)) 5.0 22.5) ;  22.5
  162.   );end_setq
  163.  
  164.   (vla-put-regeneratetablesuppressed t_obj :vlax-true)
  165.  
  166.   (mapcar '(lambda (x y) (vlax-put-property t_obj x y)) (list 'horzcellmargin 'vertcellmargin 'rowheight) (list 0.5 0.5 5.0))
  167.   (vla-settextstyle t_obj (+ acDataRow acHeaderRow acTitleRow) "TOPOCAD")
  168.  
  169.   ; Title row
  170.   (vlax-invoke t_obj 'setrowheight 0 10.0)
  171.   (vlax-invoke t_obj 'setcelltextheight 0 0 2.5)
  172.   (vlax-invoke t_obj 'settext 0 0 title)
  173.  
  174.   (setq rows (- (vlax-get t_obj 'rows) 2)
  175.         cols (1- (vlax-get t_obj 'columns))
  176.         row 1
  177.         cell 0
  178.   );end_setq
  179.  
  180.   ; loop through data cells
  181.   (while (< row rows)
  182.     (setq rdat (nth (- row 1) lst))
  183.     (while (<= cell cols)
  184.       (vlax-invoke t_obj 'setcelltextheight row cell 2.5)
  185.       (vlax-invoke t_obj 'settext row cell (nth cell rdat))
  186.       (vlax-invoke t_obj 'setcellalignment row cell acMiddleCenter)
  187.       (setq cell (1+ cell))
  188.     );end_while
  189.     (setq row (1+ row) cell 0)
  190.   );end_while
  191.   (repeat 2
  192.     (vlax-invoke t_obj 'setrowheight row 6.0)  ;
  193.     (vlax-invoke t_obj 'mergecells row row 0 cols)
  194.     (setq rdat (nth (1- row) lst))
  195.     (vla-put-width t_obj 75);
  196.     (vla-setcolumnwidth t_obj 0 15);
  197.     (vla-setcolumnwidth t_obj 1 30);
  198.     (vla-setcolumnwidth t_obj 2 30);
  199.     (vlax-invoke t_obj 'setcelltextheight row 0 2.5)
  200.     (vlax-invoke t_obj 'settext row 0 (car rdat))
  201.     (setq row (1+ row))
  202.   );end_repeat
  203.   (vla-put-regeneratetablesuppressed t_obj :vlax-false)
  204. );end_defun
  205.  
  206.  
  207.  

Can any one help?

Thanks
« Last Edit: November 25, 2023, 11:52:20 AM by mhy3sx »

ribarm

  • Gator
  • Posts: 3180
  • Marko Ribar, architect
Re: Help to update a table coordinate lisp
« Reply #1 on: November 25, 2023, 01:12:22 PM »
Just stab in the dark...

Have you tried to change last (princ) here :

Code: [Select]
;; From BIGAL
(defun aH:getatt (blk tagn)
(setq atts (vlax-invoke (vlax-ename->vla-object blk) 'getattributes))
(foreach att atts
(if (= (vla-get-tagstring att) tagn)
(setq str (vla-get-textstring att))
)
)
(princ)
)

into this :

Code: [Select]
;; From BIGAL
(defun aH:getatt (blk tagn / atts str)
(setq atts (vlax-invoke (vlax-ename->vla-object blk) 'getattributes))
(foreach att atts
(if (= (vla-get-tagstring att) tagn)
(setq str (vla-get-textstring att))
)
)
str
)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

mhy3sx

  • Newt
  • Posts: 106
Re: Help to update a table coordinate lisp
« Reply #2 on: November 25, 2023, 01:51:14 PM »
Thanks ribarm. Now works fine !!

BIGAL

  • Swamp Rat
  • Posts: 1383
  • 40 + years of using Autocad
Re: Help to update a table coordinate lisp
« Reply #3 on: November 26, 2023, 06:03:30 PM »
In a lot of cases using defuns its just add the setq.

 (setq str (aH:getatt blk "POINT"))
A man who never made a mistake never made anything