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

mhy3sx · « **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]

 
(defun rh:yn (msg default / tmp) (initget 6 "Yes No") (cond ( (getkword (strcat msg " [Yes/No] < " default " > : "))) (default)))
 
(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))))))
;------------------------------
;; 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)
)
;------------------------------
 
(defun rh:onpl (blk pl fuzz / ipt p vp d vpt cpt vpt)
  (setq p (vlax-curve-getparamatpoint pl (setq ipt (vlax-get (vlax-ename->vla-object blk) 'insertionpoint))))
  (cond (p
          (setq vp (if (> (rem p 1.0) 0.4999) (1+ (fix p)) (fix p))
                d (distance ipt (setq vpt (vlax-curve-getpointatparam pl vp)))
          );end_setq
          (if (> d fuzz) (setq vpt nil))
        )
        (t
          (setq cpt (vlax-curve-getclosestpointto pl ipt)
                p (vlax-curve-getparamatpoint pl cpt)
          );end_setq
          (cond ( (< (distance ipt cpt) fuzz)
                  (setq vp (if (> (rem p 1.0) 0.4999) (1+ (fix p)) (fix p))
                        d (distance cpt (setq vpt (vlax-curve-getpointatparam pl vp)))
                  )
                  (if (> d fuzz) (setq vpt nil))
                )
          )
        )
  );end_cond
  vpt
);end_defun
 
(defun rh:pcw-p ( obj / tmp flg)
  (if (= (type obj) 'ENAME) (setq obj (vlax-ename->vla-object obj)))
  (cond ( (vlax-method-applicable-p obj 'offset)
          (setq tmp (car (vlax-invoke obj 'offset -0.005))
                flg (if (> (vlax-get tmp 'area) (vlax-get obj 'area)) T nil)
          );end_setq
          (vla-delete tmp)
          flg
        )
        (t "")
  );end_cond
);end_defun
 
(vl-load-com)
 
;;Polyline Area Table
(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)
 
  (defun *error* ( msg )
    (mapcar 'setvar sv_lst sv_vals)
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nAn Error : " msg " occurred.")))
    (princ)
  );end_local_*error*_defun
 
  (setq sv_lst (list 'cmdecho 'osmode 'dynmode 'cannoscale 'tilemode)
        sv_vals (mapcar 'getvar sv_lst)
        c_doc (vla-get-activedocument (vlax-get-acad-object))
        acc (getvar 'luprec)
  );end_setq
 
  (cond ( (= 0 (setq tm (getvar 'tilemode))) (setvar 'tilemode 1) (setq tm 1 cas (getvar 'cannoscale)))
        (t (setq cas (getvar 'cannoscale)))
  );end_cond
 
  (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
        ( (= iunits 4)
          (setq dut "mm" aut (strcat "sq." dut) ccf 1.0 acf 1.0 fuzz 1.0 dfuzz 10.0); CHANGE dut & aut
          (if (= (rh:yn "\nInsertion Units are Millimetres. Convert Areas & Coordinates to Metres : ?" "No") "Yes")
            (setq dut "m" aut (strcat "sq." dut) ccf 1000.0 acf 1.0e6); CHANGE dut & aut
          );end_if
        )
        (t (setq iunits nil ccf 1.0 acf 1.0 fuzz 1.0 dfuzz 1.0))
  );end_cond
 
  (mapcar 'setvar sv_lst '( 0 1 1))
 
 
  (while (not flg)
    (setq ent (car (entsel "\nSelect close LWPolyline : "))
          obj (vlax-ename->vla-object ent)
    );end_setq
    (cond ( (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
            (setq pt (reverse (cdr (reverse (getpoint "\nSelect the first point : "))))
                  vlst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent)))
            );end_setq
 
 
(setq blkss (ssget "_X" '((2 . "Point,Dianomi,Ktir,DAS,KOROT,KOKAEK,APAL,NAPAL"))))
 
            (cond ( (equal (car vlst) (last vlst) fuzz)
                    (setq vlst (reverse (cdr (reverse vlst))))
                    (if (= :vlax-false (vlax-get-property obj 'closed)) (vlax-put-property obj 'closed :vlax-true))
                    (setq flg T cw (rh:pcw-p ent))
                  )
                  ( (= :vlax-true (vlax-get-property obj 'closed)) (setq flg T cw (rh:pcw-p ent)))
                  (t (alert "NOT a CLOSED LWPolyline"))
            )
            (if (not cw) (setq vlst (reverse vlst)))
          )
          (t (alert "NOT a LWPolyline"))
    );end_cond
  );end_while
 
  (setvar 'osmode 0)
  (setq vlst (rh:pchk vlst pt fuzz))
 
  (cond (flg
          (setq nme (strcase (getstring "\nGive area name : "))
                tlst (cons (list (strcat "A{\\H0.8x;" nme "} = " (rtos (/ (vlax-curve-getarea ent) acf) 2 2) " " aut)) tlst)
                ;tlst (cons (list "A=1/2 S(Xi + Xi+1)(Yi - Yi+1)") tlst)
                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)
          );end_setq
          (vla-regen c_doc acActiveViewport)
          (setq ss (ssget "F" vlst '((0 . "INSERT") (66 . 1))))
          (vla-regen c_doc acActiveViewport)
          (repeat (setq cnt (sslength ss))
          (setq bent (ssname ss (setq cnt (1- cnt)))
                 vtx (rh:onpl bent ent dfuzz)
          );end_setq
           ;(if vtx (setq tlst (cons (list (getpropertyvalue bent "POINT") (rtos (/ (car vtx) ccf) 2 acc) (rtos (/ (cadr vtx) ccf) 2 acc)) tlst)))
            (if vtx (setq tlst (cons (list (ah:getatt bent "POINT") (rtos (/ (car vtx) ccf) 2 acc) (rtos (/ (cadr vtx) ccf) 2 acc)) tlst)))
          );end_repeat
 
 
 
;(setq tlst (cons (list "A/A" (strcat "X" (if iunits (strcat " (" dut ")") " (?)")) (strcat "Y" (if iunits (strcat " (" dut ")") " (?)"))) tlst)) ; 
 (setq tlst (cons (list "A/A" (strcat "X" (if iunits (strcat "") " (?)")) (strcat "Y" (if iunits (strcat "") " (?)"))) tlst)); 
 
 
;---------------------------------------------------------------;
;                     Channge to Paper space                    ;
;---------------------------------------------------------------;
 
          (initget "Modelspace Paperspace")
          (setq t_spc (cond ( (getkword "\nInsert table : ? [Modelspace/Paperspace] <Modelspace>")) ("Modelspace"))
          )
          (if (and (= tm 1) (= t_spc "Paperspace")) (setvar 'tilemode 0))
 
;------------------------------------------------------------------------------------------------------------------------
 
          (rh:AMT c_doc (strcat "Coordinate Table " nme) tlst)
        )
        (t (alert "No Polyline Selected"))
  );end_cond
 
  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun
 
(defun rh:AMT ( doc title lst / spc ipt t_obj rows cols row cell rdat)
  (vl-cmdf "_LAYER" "_M"  "Table" "_C" "7" "" "")
  (setq spc (vlax-get-property doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
        ipt (getpoint "\nSelect Table Insertion Point: ")
        t_obj (vla-addtable spc (vlax-3d-point ipt) (1+ (length lst)) (length (car lst)) 5.0 22.5) ;  22.5 
  );end_setq
 
  (vla-put-regeneratetablesuppressed t_obj :vlax-true)
 
  (mapcar '(lambda (x y) (vlax-put-property t_obj x y)) (list 'horzcellmargin 'vertcellmargin 'rowheight) (list 0.5 0.5 5.0))
  (vla-settextstyle t_obj (+ acDataRow acHeaderRow acTitleRow) "TOPOCAD")
 
  ; Title row
  (vlax-invoke t_obj 'setrowheight 0 10.0)
  (vlax-invoke t_obj 'setcelltextheight 0 0 2.5)
  (vlax-invoke t_obj 'settext 0 0 title)
 
  (setq rows (- (vlax-get t_obj 'rows) 2)
        cols (1- (vlax-get t_obj 'columns))
        row 1
        cell 0
  );end_setq
 
  ; loop through data cells
  (while (< row rows)
    (setq rdat (nth (- row 1) lst))
    (while (<= cell cols)
      (vlax-invoke t_obj 'setcelltextheight row cell 2.5)
      (vlax-invoke t_obj 'settext row cell (nth cell rdat))
      (vlax-invoke t_obj 'setcellalignment row cell acMiddleCenter)
      (setq cell (1+ cell))
    );end_while
    (setq row (1+ row) cell 0)
  );end_while
  (repeat 2
    (vlax-invoke t_obj 'setrowheight row 6.0)  ; 
    (vlax-invoke t_obj 'mergecells row row 0 cols)
    (setq rdat (nth (1- row) lst))
    (vla-put-width t_obj 75); 
    (vla-setcolumnwidth t_obj 0 15); 
    (vla-setcolumnwidth t_obj 1 30); 
    (vla-setcolumnwidth t_obj 2 30); 
    (vlax-invoke t_obj 'setcelltextheight row 0 2.5)
    (vlax-invoke t_obj 'settext row 0 (car rdat))
    (setq row (1+ row))
  );end_repeat
  (vla-put-regeneratetablesuppressed t_obj :vlax-false)
);end_defun
 
 
 

Can any one help?

Thanks

ribarm · « **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
)

mhy3sx · « **Reply #2 on:** November 25, 2023, 01:51:14 PM »

Thanks ribarm. Now works fine !!

BIGAL · « **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"))

News:

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

mhy3sx

Help to update a table coordinate lisp

ribarm

Re: Help to update a table coordinate lisp

mhy3sx

Re: Help to update a table coordinate lisp

BIGAL

Re: Help to update a table coordinate lisp