Jump to content

Help To work LISP To filling table cells


Recommended Posts

Posted (edited)

Sorry English is not good

Hello all

I have 2 LWPOLYLINES

RED LWPOLYLINE

GREEN LWPOLYLINE

When working, the table does not work as shown on the panel

The message appears 

 error: ActiveX Server returned an error: Parameter not optional
I ask you for help

 

 

  1. (defun c:POP ( / A acDataRow acHeaderRow acMiddleCenter acTitleRow B pts C COLWIDTH CURSPACE D2 DIS DOC E EL I II LEV LEVI LW N NN NUMCOLUMNS NUMROWS OBJTABLE OUT OUT_P P PL PLL PT1 PTCNTR PTLST PTS ROWHEIGHT S SLIST SSN X1 XY Y Y1 YI Z DIST HH INC LW OUT1 P XY1)
  2. (setq el (CAR(entsel "Select a RED LWPOLYLINE : ")))
  3. (setq lw (CAR(entsel "Select a GREEN LWPOLYLINE : ")))
  4. (setq lev (* 10 27))
  5. (setq inc (getdist "\nSet the increment distance here : "))
  6. (SETQ ht (GETREAL "\n-> Enter text height : "))
  7. (INITGET 7)
  8. (COMMAND "PDMODE" 35)
  9. (COMMAND "PDSIZE" HT)
  10. ;;;(SETQ pt1 (VLAX-3D-POINT (GETPOINT "\n-> Pick point for top left hand of table: ")))
  11.   (setq i 0)
  12.             (repeat (- (fix (vlax-curve-getendparam el)) 1);RED
  13. ;;;                (setq d1 (vlax-curve-getdistatparam el i))
  14.                 (setq d2 (vlax-curve-getdistatparam el (1+ i)))
  15.                 (setq pl (cons(vlax-curve-getpointatdist lw d2) pl));RED             
  16.                 (setq i (1+ i))
  17.             );REPEAT
  18. ;;;  (PRINC pl)
  19. (setq pll (mapcar '(lambda ( p ) (trans (list (car p) (cadr p) (cdr (assoc 38 (entget lw)))) lw 0)) (mapcar 'cdr (vl-remove-if  '(lambda ( x ) (/= (car x) 10)) (entget lw)))))
  20. (setq pll (append pl pll))
  21. (setq ptLst(vl-sort
  22.               pll
  23.                 '(lambda(a b)(<(car a)(car b)))))
  24. (setq x1(car(car ptLst)))
  25. (setq y1(cadr(car ptLst)))
  26.   (setq ii 0)
  27. (repeat (length ptLst)
  28.                 (setq dis (- (car(nth ii ptLst)) x1))
  29.                 (setq yi (- (cadr(nth ii ptLst)) y1))
  30.                 (setq levi(/ (+ lev yi) 10))
  31.                 (setq xy(vlax-curve-getpointatdist el dis))
  32.                 (setq out(LIST (CAR xy) (CADR xy) levi))
  33.                 (setq out_p(cons out out_p))
  34.                 (setq ii (1+ ii))
  35.             )
  36.             (setq out_pp(reverse out_p))
  37. ;;;  (PRINC xy)
  38. (entmake
  39.     (list
  40.       '(0 . "POLYLINE")
  41.       '(100 . "AcDbEntity")
  42.       '(100 . "AcDb3dPolyline")
  43.       '(66 . 1)
  44.       '(62 . 1)
  45.       '(10 0.0 0.0 0.0)
  46.       '(70 . 8)
  47.       '(210 0.0 0.0 1.0)
  48.     )
  49.   )
  50. (foreach pt out_pp
  51.     (entmake
  52.       (list
  53.         '(0 . "VERTEX")
  54.         '(100 . "AcDbEntity")
  55.         '(100 . "AcDbVertex")
  56.         '(100 . "AcDb3dPolylineVertex")
  57.         (cons 10 pt)
  58.         '(70 . 32)
  59.       )
  60.     )
  61.   )
  62.   (entmake
  63.     (list
  64.       '(0 . "SEQEND")
  65.       '(100 . "AcDbEntity")
  66.     )
  67.   )
  68.   (command "._Change" (entlast) "" "p" "color" "120" "")
  69.   ;;;;;;;;;;;;;;;;;;;;;;;;;
  70.   (SETQ n 0)
  71.   (setq dist 0)
  72.   (while (setq xy1 (vlax-Curve-GetPointAtDist el dist))
  73.          (setq HH(vlax-curve-getpointatdist lw dist))
  74.          (setq yi (- (cadr HH) y1))
  75.          (setq levi(/ (+ lev yi) 10))
  76.          (setq out1(LIST (CAR xy1) (CADR xy1) levi))
  77.          
  78.          ;;add the point to a list
  79.          (SETQ pts (CONS (list  (ITOA(SETQ n (1+ n))) (car out1)(cadr out1)(cadDr out1)) pts))
  80. ;;;         (setq pts(cons out1 pts))
  81.                ;;increment the distance for the next point
  82.               (setq dist (+ dist inc))
  83.               (COMMAND "_.TEXT" out1 ht "0" (ITOA n))
  84.               (COMMAND "_.POINT" out1 "")
  85.     
  86.   );while
  87.   (if (/= dist dis)
  88.       (progn
  89.     (SETQ pts (CONS (list  (ITOA(SETQ n (1+ n))) (car out)(cadr out)(cadDr out)) pts))
  90.         (COMMAND "_.TEXT" out ht "0" (ITOA n))
  91.         (COMMAND "_.POINT" out "")
  92. ;;;      (setq pts(cons out pts))
  93.     ))
  94.  (setq ptss(reverse pts))
  95. ;;; (setvar 'osmode 0)
  96.  (setq pAt (getpoint"\nPick table insertion point:"))
  97.  (lstToTable pAt "COORDINATES" ptss)
  98.  (princ)
  99. (vl-load-com)
  100.   
  101.   )
  102. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  103. (defun lstToTable (insPt ; List Insertion point of Table
  104. title ; String Table Title
  105. cmLst ; List of sublists of Values in Rows
  106. /
  107. accol ;AutoCAD.AcCmColor object
  108. col ; Integer Column Item
  109. rows ; Integer Number of Rows
  110. cols ; Integer Number of Columns
  111. row ; Integer Row Item
  112. sbLst ; List of Values in a Row
  113. atable ; Table Object 
  114. strg ; String Item in List
  115. )
  116. (if (not insPt)
  117. (setq insPt (getpoint "\nSelect Insertion Point: ")))
  118. (setq rows (1+ (length cmLst))
  119. cols (apply 'max (mapcar 'length cmLst))
  120. atable (vla_addTable insPt rows cols)
  121. )
  122. ; to prevent display table changes at runtime:
  123. (vla-put-regeneratetablesuppressed atable :vlax-true);supres opening and closing table-block object at each writting to table
  124.  (setq accol (vla-get-truecolor atable))
  125.  (vla-setrgb accol 16 37 66)
  126.  (vla-put-truecolor atable accol)
  127.  
  128. ;************************************************************************************
  129. ; Populate Title and set title
  130. (vla-settext atable 0 0 title)
  131.  (vla-setrgb accol 255 161 66)
  132.  (vla-setcellcontentcolor atable 0 0 accol)
  133.  ;(vla-setrgb accol 0 64 255)
  134.   (vla-setrgb accol 20 27 105)
  135. (vla-SetCellBackgroundColor atable 0 0 accol)
  136.  (vla-setrgb accol 82 0 0)
  137. ;************************************************************************************
  138. ; Populate Column Headers and Data Rows
  139. (setq row 1 
  140. col 0
  141. )
  142. (foreach sbLst cmLst
  143. (foreach strg sbLst 
  144. (vla-settext atable row col strg)
  145.   (vla-setcellalignment atable row col acMiddleCenter)
  146.   (vla-setrgb accol 82 0 0)
  147.   (vla-setcellcontentcolor atable row col accol)
  148.   
  149.   (if (> col 0)(progn
  150.  (vla-setcelldatatype atable row col acdouble acUnitDistance)
  151.  (vla-setcellformat atable row col "%lu2%pr2")))
  152.    (vla-setrgb accol  255 245 235)
  153.   (vla-SetCellBackgroundColor atable row col accol)
  154.   (setq col (1+ col))
  155. )
  156. (setq col 0 
  157. row (1+ row)))
  158.  (vla-insertrows atable 1 (* txtsize 1.5) 1)
  159.  (setq col 0 row 1)
  160.  (foreach strg (list "PT." "X" "Y" "Z")
  161.     (vla-settext atable row col strg)
  162.   (vla-setcellalignment atable row col acMiddleCenter)
  163.   (vla-setrgb accol 82 0 0)
  164.   (vla-setcellcontentcolor atable row col accol)
  165. (vla-setrgb accol 249 198 182)
  166.    (vla-SetCellBackgroundColor atable row col accol)
  167.    (setq col (1+ col)))
  168.  (vla-setcolumnwidth atable 0 (* (getvar 'textsize) )
  169.  (vla-setrowheight atable 1 (* (getvar 'textsize) 1.5))
  170. ;(vla-recomputetableblock atable :vlax-true) ;on the end display table object changes: Every instance of vla-settext
  171. ; opens table-block object, writes and closes them.Works pretty slow!
  172. (vla-put-regeneratetablesuppressed atable :vlax-false)
  173. (vlax-release-object atable) ;release memory used to create this object
  174.  (vlax-release-object accol)
  175. ))
  176. ; The Create Table Function Accepts 3 Arguments including the 
  177. ; Insertion point of the table, the Number of Rows and Number of Columns.
  178. (defun vla_addTable (insPt ; Insertion Point of Table 
  179.                         rows        ; Integer Number of Rows in Table
  180.                         cols     ; Integer Number of Columns in Table
  181.                         / 
  182.                         atable          ; Table Object
  183.                        )
  184. (setq txtsize (getvar 'textsize);|(variant-value (vla-getvariable 
  185.                                   (vla-get-activedocument 
  186.                                    (vlax-get-acad-object)) 
  187.                                   "textsize"))|;;commented
  188.       atable     (vla-addtable (vla-get-block 
  189.                                   (vla-get-activelayout
  190.                                    (vla-get-activedocument 
  191.                                     (vlax-get-acad-object))))
  192.                                       (vlax-3d-point insPt)
  193.                                  rows
  194.                                  cols
  195.                                  (* txtsize 1.25)
  196.                                  (* txtsize 2)))
  197. atable
  198. )
     

 

 

 

TEST -2.dwg

test final-FORUM.LSP

Edited by hosneyalaa
Posted

you may also learn to use the debug function in the lisp editor

 

1 don't localize acDataRow   acHeaderRow  acMiddleCenter  acTitleRow  (autocad constants)

2 vla_addTable -> vla-addTable (line 154)

3 add  table must include document space (Mspace in this case)

4 setcolumn width in line 209 was wrong

5 because of that you released you table object to early

 


(defun c:POP  (/      A      B     pts    C   COLWIDTH CURSPACE
        D2     DIS    DOC    E    EL   I  II LEV
        LEVI   LW     N     NN    NUMCOLUMNS  NUMROWS
        OBJTABLE      OUT    OUT_P  P   PL  PLL PT1
        PTCNTR PTLST  PTS    ROWHEIGHT   S  SLIST SSN
        X1     XY     Y     Y1    YI   Z  DIST HH
        INC    LW     OUT1   P    XY1)
  (setq el (CAR (entsel "Select a RED LWPOLYLINE : ")))
  (setq lw (CAR (entsel "Select a GREEN LWPOLYLINE : ")))
  (setq lev (* 10 27))
  (setq inc (getdist "\nSet the increment distance here : "))
  (SETQ ht (GETREAL "\n-> Enter text height : "))
  (INITGET 7)
  (COMMAND "PDMODE" 35)
  (COMMAND "PDSIZE" HT)
;;;(SETQ pt1 (VLAX-3D-POINT (GETPOINT "\n-> Pick point for top left hand of table: ")))
  (setq i 0)
  (repeat (- (fix (vlax-curve-getendparam el)) 1) ;RED
;;;                (setq d1 (vlax-curve-getdistatparam el i))
    (setq d2 (vlax-curve-getdistatparam el (1+ i)))
    (setq pl (cons (vlax-curve-getpointatdist lw d2) pl))
     ;RED            
    (setq i (1+ i))
    )     ;REPEAT
;;;  (PRINC pl)
  (setq pll
  (mapcar
    '(lambda (p)
       (trans
  (list (car p) (cadr p) (cdr (assoc 38 (entget lw))))
  lw
  0))
    (mapcar
      'cdr
      (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget lw)))))
  (setq pll (append pl pll))
  (setq ptLst (vl-sort
  pll
  '(lambda (a b) (< (car a) (car b)))))
  (setq x1 (car (car ptLst)))
  (setq y1 (cadr (car ptLst)))

  (setq ii 0)
  (repeat (length ptLst)
    (setq dis (- (car (nth ii ptLst)) x1))
    (setq yi (- (cadr (nth ii ptLst)) y1))
    (setq levi (/ (+ lev yi) 10))
    (setq xy (vlax-curve-getpointatdist el dis))
    (setq out (LIST (CAR xy) (CADR xy) levi))
    (setq out_p (cons out out_p))
    (setq ii (1+ ii))
    )
  (setq out_pp (reverse out_p))
;;;  (PRINC xy)
  (entmake
    (list
      '(0 . "POLYLINE")    '(100 . "AcDbEntity")
      '(100
 .
 "AcDb3dPolyline")  '(66 . 1)  '(62 . 1)
      '(10 0.0 0.0 0.0)    '(70 . 8)  '(210 0.0 0.0 1.0))
    )

  (foreach pt  out_pp
    (entmake
      (list
 '(0 . "VERTEX")
 '(100 . "AcDbEntity")
 '(100 . "AcDbVertex")
 '(100 . "AcDb3dPolylineVertex")
 (cons 10 pt)
 '(70 . 32)
 )
      )
    )

  (entmake
    (list
      '(0 . "SEQEND")
      '(100 . "AcDbEntity")
      )
    )

  (command "._Change" (entlast) "" "p" "color" "120" "")

;;;;;;;;;;;;;;;;;;;;;;;;;
  (SETQ n 0)
  (setq dist 0)
  (while (setq xy1 (vlax-Curve-GetPointAtDist el dist))
    (setq HH (vlax-curve-getpointatdist lw dist))
    (setq yi (- (cadr HH) y1))
    (setq levi (/ (+ lev yi) 10))
    (setq out1 (LIST (CAR xy1) (CADR xy1) levi))

    ;;add the point to a list
    (SETQ pts (CONS (list (ITOA (SETQ n (1+ n)))
     (car out1)
     (cadr out1)
     (cadDr out1))
      pts))
;;;         (setq pts(cons out1 pts))
    ;;increment the distance for the next point
    (setq dist (+ dist inc))
    (COMMAND "_.TEXT" out1 ht "0" (ITOA n))
    (COMMAND "_.POINT" out1 "")

    )     ;while
  (if (/= dist dis)
    (progn
      (SETQ pts (CONS (list (ITOA (SETQ n (1+ n)))
       (car out)
       (cadr out)
       (cadDr out))
        pts))
      (COMMAND "_.TEXT" out ht "0" (ITOA n))
      (COMMAND "_.POINT" out "")
;;;      (setq pts(cons out pts))
      ))
  (setq ptss (reverse pts))
;;; (setvar 'osmode 0)
  (setq pAt (getpoint "\nPick table insertion point:"))
  (lstToTable pAt "COORDINATES" ptss)
  (princ)
  (vl-load-com)

  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun lstToTable  (insPt  ; List Insertion point of Table
      title  ; String Table Title
      cmLst  ; List of sublists of Values in Rows
      /     accol ;AutoCAD.AcCmColor object
      col   ; Integer Column Item
      rows  ; Integer Number of Rows
      cols  ; Integer Number of Columns
      row   ; Integer Row Item
      sbLst  ; List of Values in a Row
      atable  ; Table Object
      strg  ; String Item in List

      ActiveDocument
      mSpace
      )
 
  (if (not insPt) (setq insPt (getpoint "\nSelect Insertion Point: ")))

   (setq ActiveDocument (vla-get-activedocument (vlax-get-acad-object)))
   (setq mSpace(vla-get-modelspace ActiveDocument))

 
  (setq rows   (1+ (length cmLst))
 cols   (apply 'max (mapcar 'length cmLst))
 ;;; * * * edit  vla_addTable : underscore is wrong , added mspace, point format wrong , row height / width missing
 atable (vla-addTable mSpace (vlax-3D-point insPt) rows cols 5 10)
 )
     ; to prevent display table changes at runtime:
  (vla-put-regeneratetablesuppressed atable :vlax-true)
     ;supres opening and closing table-block object at each writting to table
  (setq accol (vla-get-truecolor atable))
  (vla-setrgb accol 16 37 66)
  (vla-put-truecolor atable accol)


     ;************************************************************************************
     ; Populate Title and set title
  (vla-settext atable 0 0 title)
  (vla-setrgb accol 255 161 66)
  (vla-setcellcontentcolor atable 0 0 accol)
     ;(vla-setrgb accol 0 64 255)
  (vla-setrgb accol 20 27 105)
  (vla-SetCellBackgroundColor atable 0 0 accol)

  (vla-setrgb accol 82 0 0)
     ;************************************************************************************
     ; Populate Column Headers and Data Rows
  (setq row 1
 col 0
 )
  (foreach sbLst  cmLst
    (foreach strg  sbLst
      (vla-settext atable row col strg)
      (vla-setcellalignment atable row col acMiddleCenter)
      (vla-setrgb accol 82 0 0)
      (vla-setcellcontentcolor atable row col accol)

      (if (> col 0)
 (progn
   (vla-setcelldatatype
     atable row col acdouble acUnitDistance)
   (vla-setcellformat atable row col "%lu2%pr2")))
      (vla-setrgb accol 255 245 235)
      (vla-SetCellBackgroundColor atable row col accol)
      (setq col (1+ col))
      )
    (setq col 0
   row (1+ row)))
  (vla-insertrows atable 1 (* txtsize 1.5) 1)
  (setq col 0 row 1)
  (foreach strg  (list "PT." "X" "Y" "Z")
    (vla-settext atable row col strg)
    (vla-setcellalignment atable row col acMiddleCenter)
    (vla-setrgb accol 82 0 0)
    (vla-setcellcontentcolor atable row col accol)
    (vla-setrgb accol 249 198 182)
    (vla-SetCellBackgroundColor atable row col accol)
    (setq col (1+ col)))

  ;;;; * * * edit added 1.5 and )
  (vla-setcolumnwidth atable  0 (* (getvar 'textsize) 1.5))

  (vla-setrowheight atable 1 (* (getvar 'textsize) 1.5))
 
     ;(vla-recomputetableblock atable :vlax-true) ;on the end display table object changes: Every instance of vla-settext
     ; opens table-block object, writes and closes them.Works pretty slow!
    (vla-put-regeneratetablesuppressed atable :vlax-false)
    (vlax-release-object atable) ;release memory used to create this object
    (vlax-release-object accol)
    ) ;;; * * * removed 1 )
     ; The Create Table Function Accepts 3 Arguments including the
     ; Insertion point of the table, the Number of Rows and Number of Columns.

(defun vla_addTable  (insPt  ; Insertion Point of Table
        rows  ; Integer Number of Rows in Table
        cols  ; Integer Number of Columns in Table
        / atable  ; Table Object
)
  (setq txtsize (getvar 'textsize)
  ;|(variant-value (vla-getvariable
                                  (vla-get-activedocument
                                   (vlax-get-acad-object))
                                  "textsize"))|; ;commented
 atable (vla-addtable
    (vla-get-block
      (vla-get-activelayout
        (vla-get-activedocument
   (vlax-get-acad-object))))
    (vlax-3d-point insPt)
    rows
    cols
    (* txtsize 1.25)
    (* txtsize 2)))
  atable
  )

 

 

Posted
18 hours ago, rlx said:

you may also learn to use the debug function in the lisp editor

 

1 don't localize acDataRow   acHeaderRow  acMiddleCenter  acTitleRow  (autocad constants)

2 vla_addTable -> vla-addTable (line 154)

3 add  table must include document space (Mspace in this case)

4 setcolumn width in line 209 was wrong

5 because of that you released you table object to early

 

 


(defun c:POP  (/      A      B     pts    C   COLWIDTH CURSPACE
        D2     DIS    DOC    E    EL   I  II LEV
        LEVI   LW     N     NN    NUMCOLUMNS  NUMROWS
        OBJTABLE      OUT    OUT_P  P   PL  PLL PT1
        PTCNTR PTLST  PTS    ROWHEIGHT   S  SLIST SSN
        X1     XY     Y     Y1    YI   Z  DIST HH
        INC    LW     OUT1   P    XY1)
  (setq el (CAR (entsel "Select a RED LWPOLYLINE : ")))
  (setq lw (CAR (entsel "Select a GREEN LWPOLYLINE : ")))
  (setq lev (* 10 27))
  (setq inc (getdist "\nSet the increment distance here : "))
  (SETQ ht (GETREAL "\n-> Enter text height : "))
  (INITGET 7)
  (COMMAND "PDMODE" 35)
  (COMMAND "PDSIZE" HT)
;;;(SETQ pt1 (VLAX-3D-POINT (GETPOINT "\n-> Pick point for top left hand of table: ")))
  (setq i 0)
  (repeat (- (fix (vlax-curve-getendparam el)) 1) ;RED
;;;                (setq d1 (vlax-curve-getdistatparam el i))
    (setq d2 (vlax-curve-getdistatparam el (1+ i)))
    (setq pl (cons (vlax-curve-getpointatdist lw d2) pl))
     ;RED            
    (setq i (1+ i))
    )     ;REPEAT
;;;  (PRINC pl)
  (setq pll
  (mapcar
    '(lambda (p)
       (trans
  (list (car p) (cadr p) (cdr (assoc 38 (entget lw))))
  lw
  0))
    (mapcar
      'cdr
      (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget lw)))))
  (setq pll (append pl pll))
  (setq ptLst (vl-sort
  pll
  '(lambda (a b) (< (car a) (car b)))))
  (setq x1 (car (car ptLst)))
  (setq y1 (cadr (car ptLst)))

  (setq ii 0)
  (repeat (length ptLst)
    (setq dis (- (car (nth ii ptLst)) x1))
    (setq yi (- (cadr (nth ii ptLst)) y1))
    (setq levi (/ (+ lev yi) 10))
    (setq xy (vlax-curve-getpointatdist el dis))
    (setq out (LIST (CAR xy) (CADR xy) levi))
    (setq out_p (cons out out_p))
    (setq ii (1+ ii))
    )
  (setq out_pp (reverse out_p))
;;;  (PRINC xy)
  (entmake
    (list
      '(0 . "POLYLINE")    '(100 . "AcDbEntity")
      '(100
 .
 "AcDb3dPolyline")  '(66 . 1)  '(62 . 1)
      '(10 0.0 0.0 0.0)    '(70 . 8)  '(210 0.0 0.0 1.0))
    )

  (foreach pt  out_pp
    (entmake
      (list
 '(0 . "VERTEX")
 '(100 . "AcDbEntity")
 '(100 . "AcDbVertex")
 '(100 . "AcDb3dPolylineVertex")
 (cons 10 pt)
 '(70 . 32)
 )
      )
    )

  (entmake
    (list
      '(0 . "SEQEND")
      '(100 . "AcDbEntity")
      )
    )

  (command "._Change" (entlast) "" "p" "color" "120" "")

;;;;;;;;;;;;;;;;;;;;;;;;;
  (SETQ n 0)
  (setq dist 0)
  (while (setq xy1 (vlax-Curve-GetPointAtDist el dist))
    (setq HH (vlax-curve-getpointatdist lw dist))
    (setq yi (- (cadr HH) y1))
    (setq levi (/ (+ lev yi) 10))
    (setq out1 (LIST (CAR xy1) (CADR xy1) levi))

    ;;add the point to a list
    (SETQ pts (CONS (list (ITOA (SETQ n (1+ n)))
     (car out1)
     (cadr out1)
     (cadDr out1))
      pts))
;;;         (setq pts(cons out1 pts))
    ;;increment the distance for the next point
    (setq dist (+ dist inc))
    (COMMAND "_.TEXT" out1 ht "0" (ITOA n))
    (COMMAND "_.POINT" out1 "")

    )     ;while
  (if (/= dist dis)
    (progn
      (SETQ pts (CONS (list (ITOA (SETQ n (1+ n)))
       (car out)
       (cadr out)
       (cadDr out))
        pts))
      (COMMAND "_.TEXT" out ht "0" (ITOA n))
      (COMMAND "_.POINT" out "")
;;;      (setq pts(cons out pts))
      ))
  (setq ptss (reverse pts))
;;; (setvar 'osmode 0)
  (setq pAt (getpoint "\nPick table insertion point:"))
  (lstToTable pAt "COORDINATES" ptss)
  (princ)
  (vl-load-com)

  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun lstToTable  (insPt  ; List Insertion point of Table
      title  ; String Table Title
      cmLst  ; List of sublists of Values in Rows
      /     accol ;AutoCAD.AcCmColor object
      col   ; Integer Column Item
      rows  ; Integer Number of Rows
      cols  ; Integer Number of Columns
      row   ; Integer Row Item
      sbLst  ; List of Values in a Row
      atable  ; Table Object
      strg  ; String Item in List

      ActiveDocument
      mSpace
      )
 
  (if (not insPt) (setq insPt (getpoint "\nSelect Insertion Point: ")))

   (setq ActiveDocument (vla-get-activedocument (vlax-get-acad-object)))
   (setq mSpace(vla-get-modelspace ActiveDocument))

 
  (setq rows   (1+ (length cmLst))
 cols   (apply 'max (mapcar 'length cmLst))
 ;;; * * * edit  vla_addTable : underscore is wrong , added mspace, point format wrong , row height / width missing
 atable (vla-addTable mSpace (vlax-3D-point insPt) rows cols 5 10)
 )
     ; to prevent display table changes at runtime:
  (vla-put-regeneratetablesuppressed atable :vlax-true)
     ;supres opening and closing table-block object at each writting to table
  (setq accol (vla-get-truecolor atable))
  (vla-setrgb accol 16 37 66)
  (vla-put-truecolor atable accol)


     ;************************************************************************************
     ; Populate Title and set title
  (vla-settext atable 0 0 title)
  (vla-setrgb accol 255 161 66)
  (vla-setcellcontentcolor atable 0 0 accol)
     ;(vla-setrgb accol 0 64 255)
  (vla-setrgb accol 20 27 105)
  (vla-SetCellBackgroundColor atable 0 0 accol)

  (vla-setrgb accol 82 0 0)
     ;************************************************************************************
     ; Populate Column Headers and Data Rows
  (setq row 1
 col 0
 )
  (foreach sbLst  cmLst
    (foreach strg  sbLst
      (vla-settext atable row col strg)
      (vla-setcellalignment atable row col acMiddleCenter)
      (vla-setrgb accol 82 0 0)
      (vla-setcellcontentcolor atable row col accol)

      (if (> col 0)
 (progn
   (vla-setcelldatatype
     atable row col acdouble acUnitDistance)
   (vla-setcellformat atable row col "%lu2%pr2")))
      (vla-setrgb accol 255 245 235)
      (vla-SetCellBackgroundColor atable row col accol)
      (setq col (1+ col))
      )
    (setq col 0
   row (1+ row)))
  (vla-insertrows atable 1 (* txtsize 1.5) 1)
  (setq col 0 row 1)
  (foreach strg  (list "PT." "X" "Y" "Z")
    (vla-settext atable row col strg)
    (vla-setcellalignment atable row col acMiddleCenter)
    (vla-setrgb accol 82 0 0)
    (vla-setcellcontentcolor atable row col accol)
    (vla-setrgb accol 249 198 182)
    (vla-SetCellBackgroundColor atable row col accol)
    (setq col (1+ col)))

  ;;;; * * * edit added 1.5 and )
  (vla-setcolumnwidth atable  0 (* (getvar 'textsize) 1.5))

  (vla-setrowheight atable 1 (* (getvar 'textsize) 1.5))
 
     ;(vla-recomputetableblock atable :vlax-true) ;on the end display table object changes: Every instance of vla-settext
     ; opens table-block object, writes and closes them.Works pretty slow!
    (vla-put-regeneratetablesuppressed atable :vlax-false)
    (vlax-release-object atable) ;release memory used to create this object
    (vlax-release-object accol)
    ) ;;; * * * removed 1 )
     ; The Create Table Function Accepts 3 Arguments including the
     ; Insertion point of the table, the Number of Rows and Number of Columns.

(defun vla_addTable  (insPt  ; Insertion Point of Table
        rows  ; Integer Number of Rows in Table
        cols  ; Integer Number of Columns in Table
        / atable  ; Table Object
)
  (setq txtsize (getvar 'textsize)
  ;|(variant-value (vla-getvariable
                                  (vla-get-activedocument
                                   (vlax-get-acad-object))
                                  "textsize"))|; ;commented
 atable (vla-addtable
    (vla-get-block
      (vla-get-activelayout
        (vla-get-activedocument
   (vlax-get-acad-object))))
    (vlax-3d-point insPt)
    rows
    cols
    (* txtsize 1.25)
    (* txtsize 2)))
  atable
  )


 

 

 

 

Posted

Many thanks
The answer to my question
Thanks

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.

×
×
  • Create New...