Generate table with some data from excel

[jvillarreal]

It's been a slow post lunch...Please consider increasing fixo's donation suggestion if possible..

 

Note: The code does not adjust text size. If the text size is too large, the routine will fail.

 

;;;Following FELIXJM's contribution. Included vlax-release-object section from fixo's code
(defun c:prof (/ #arq cells excel-app wb-collection arq sheets sheet1 NL PX PY ROW ROWS COL COLS STY TS POINTS ALTS DISTS CDS BP UL tline tw maxnum num mids headers)
(vl-load-com)
(defun maxw (los /)
    (APPLY 'MAX
     (MAPCAR
     '(LAMBDA (X)(- (CAADR X)(CAAR X)))
        (MAPCAR
        '(LAMBDA (Y)(TEXTBOX (LIST (CONS 1 Y)(ASSOC 41 STY)))) los)
    ))
)
(setq ActDoc (vla-get-activedocument (vlax-get-acad-object))
     *Space* (vlax-get-property ActDoc (nth (vla-get-ActiveSpace ActDoc)'("PaperSpace" "ModelSpace")))
     sty (tblsearch "Style" (getvar 'textstyle))
     #arq (getfiled "Select File:" "" "xls" 2)
     excel-app (vlax-create-object "excel.application")
     wb-collection (vlax-get excel-app "workbooks")
     arq    (vlax-invoke-method wb-collection  "Open"  #arq)
     sheets (vlax-get arq    "sheets")
     sheet1 (vlax-get-property sheets "item" 1)
     ur     (vlax-get-property sheet1 "UsedRange")
     rows   (vlax-get-property (vlax-get-property ur "Rows") "Count")
     cols   (vlax-get-property (vlax-get-property ur "Columns") "Count")
     cells  (vlax-get sheet1 "cells"))
(if (eq (setq ts (cdr (assoc 40 sty))) 0.0) (setq ts (getvar 'textsize)))
(COMMAND "._PLINE")
(SETQ NL (vlax-get-property ur "Row"))
(repeat rows
(setq col (- (vlax-get-property ur "Column") 1))
(repeat cols
 (setq row
  (append row
   (list
    (vlax-variant-value
     (vlax-variant-change-type
      (vlax-get-property cells "item"  NL  (setq col(1+ col)))
      vlax-vbstring))))))
(if (> NL (vlax-get-property ur "Row"))
 (progn 
  (setq points (append points (list (VL-STRING-SUBST "." "," (nth 0 row))))
        alts (append alts (list (atof (nth 1 row))))
        dists (append dists (list (atof (nth 2 row))))
        cds (append cds (list (atof (nth 3 row))))
        PX (atof (nth 3 row)) PY (atof (nth 1 row)))
  (IF (OR (> PX 0)(> PY 0))(COMMAND (LIST PX PY)))
 )
(setq headers row)
)
(SETQ ROW NIL NL (+ NL 1))
)
(COMMAND "")
(COMMAND "_ZOOM" "_E")
(vlax-invoke-method wb-collection 'Close)
(vl-catch-all-apply 'vlax-invoke-method (list excel-app 'Quit))
(mapcar
(function
 (lambda (x)
  (vlax-release-object x)(setq x nil)(gc)))
(list cells ur sheet1 sheets arq wb-collection excel-app))
(gc)(gc)
(setq BP (list (* -7.5 ts) (1- (- (apply 'min alts) (rem (apply 'min alts) 10))) 0.0))
(setq tline
(vla-addline
 *Space*
 (vlax-3d-point
  (setq UL
  (LIST
   (- (car bp)(+ (maxw headers) ts))  (cadr bp) 0.0)))
 (vlax-3d-point (list (+ (apply 'max cds)(* 2.5 ts)) (cadr bp) 0.0))))
(vla-ArrayRectangular tline 5.0 1.0 1.0 (* -2.5 ts) 0.0 0.0)
(setq minnum (1+ (cadr bp)))
(setq maxnum (+ (- 10 (rem (apply 'max alts) 10))(apply 'max alts)))
(setq tline
(vla-addline
 *Space*
 (vlax-3d-point UL)
 (vlax-3d-point (car UL) (+ (cadr bp)(* -2.5 ts 4)) 0.0)
))
(vla-ArrayRectangular tline 1.0 2.0 1.0 0.0 (+ (abs (car UL))  (+ (apply 'max cds)(* 2.5 ts))) 0.0)
(vla-addline *Space*
(vlax-3d-point (list (car bp) (+ (cadr bp)(* -2.5 ts 4)) 0.0))
(vlax-3d-point (list (car bp) maxnum 0.0))
)

(setq tw (maxw (mapcar '(lambda (x) (rtos x 2 2)) alts)))
(setq tline (vla-addline *Space* (vlax-3d-point (list (- (car bp) ts) minnum 0.0))(vlax-3d-point (list (+ (car bp) ts) minnum 0.0))))
(vla-ArrayRectangular tline (1+ (- maxnum minnum)) 1.0 1.0 1.0 0.0 0.0)
(setq num (1- minnum))
(repeat (1+ (fix (- maxnum minnum)))
(vla-addtext *Space* (rtos (setq num (1+ num)) 2 2) (vlax-3d-point (polar (list (- (car bp)(+ tw (* 2 ts))) 0.0 0.0) (* pi 0.5) num)) ts)
)
(setq num 0)
(mapcar
'(lambda (x )
  (vla-addtext *space* x
   (vlax-3d-point
    (polar
     (list (+ (car ul) (* 0.5 ts))(+ (* 0.5 ts) (cadr bp)) 0.0)
     (* pi 1.5)
     (* 2.5 ts (setq num (1+ num))))) ts))
     headers
)
(setq mids (mapcar '(lambda (x y) (/ (+ x y) 2)) cds (cdr cds)))
(setq num 0)
(mapcar '(lambda (data)
(setq num (1+ num))
 (mapcar '(lambda (x y)
    (vla-addtext *space* x
     (vlax-3d-point
      (polar
       (list (- y (* 0.5 (maxw (list x)))) (cadr bp) 0.0)
       (* 1.5 pi)
       (- (* 2.5 ts num)(* 0.5 ts))))
      ts))
    data cds
 ))
 (list points)
)
(mapcar '(lambda (data)
(setq num (1+ num))
 (mapcar '(lambda (x y)
    (if (= num 3)
     (progn
      (vla-addline *Space*
       (vlax-3d-point (polar (list y (cadr bp) 0.0)(* 1.5 pi) (* 5 ts)))
       (vlax-3d-point (polar (list y (cadr bp) 0.0)(* 1.5 pi) (* 7.5 ts))))
    )
    (vla-addtext *space* (rtos x 2 2)
     (vlax-3d-point
      (polar
       (list (- y (* 0.5 (maxw (list (rtos x 2 2))))) (cadr bp) 0.0)
       (* 1.5 pi)
       (- (* 2.5 ts num)(* 0.5 ts))))
      ts))) 
    data cds
 ))
 (list alts dists cds)
)
(setq num 3)
       (mapcar 
        '(lambda (dbp m)
          (vla-addtext *Space* (rtos dbp 2 2)
           (vlax-3d-point
            (polar
             (list m (cadr bp) 0.0)
             (* 1.5 pi)
             (- (* 2.5 ts num)(* 0.5 ts)))) 
            ts))
         dists mids)
(mapcar '(lambda (x y)(vla-addline *Space* (vlax-3d-point (list x y 0.0))(vlax-3d-point (list x (cadr bp) 0.0)))) cds alts)
(PRINC)
)

Edited November 29, 2011 by jvillarreal

[FELIXJM]

Jvillarreal Very good! but to stay professional before adding the following line:

 

(if (eq (setq ts (cdr (assoc 40 sty))) 0.0) (setq ts (getvar 'textsize)))

 

the following code:

 

(SETQ ESCNIL 250)(SETQ ESC (GETINT (STRCAT "\nSCALE OF PLOT: 1000=<" (ITOA ESCNIL) ">: ")))(IF (NOT ESC) (SETQ ESC ESCNIL))(SETVAR "TEXTSIZE" (* 2.0 (/ ESC 1000.0)))

 

Also agree to a higher value for donation (2x)

 

OK.

[jvillarreal]

Just updated the code in my previous post...removed useless mapcar calls..

[jhonnying]

thanks a lot for your work, how can i donate 5$? keep up the good work!

[fixo]

Ya da man

Go there:

http://www.cadtutor.net/download/vector/autocad-plan-trees.php

see button at the very bottom left of this page

 

Thanks

[jhonnying]

i need an international credit card or a simple card (which can be use only in my country)? because i don't have an international card!anyway, i'll figure out something!