Browse for an existing excel file?

[fathihvac]

HELLO,

I have posted this in theswamp.org

 

I am looking for a code that allow me to browse for an existing excel file and create a new worksheet and give it a predetermined name to put some data generated by a calculating autolisp program.

[Lee Mac]

Use getfiled with the 'flags' argument set to 1 to allow the user to browse for a new file to be created.

[fixo]

Give that a try

For the test select some blocks on screen

 
(vl-load-com)
(defun C:XLDEMO  (/ *error* colm defName ExcelApp exc_data fcol fdata filepath ftype ins_point
                   ins_record Lngcount newName pfset row Sheets Sht ShtNames Wbk x xlCell xlCells XlLastsheet xlNewSheet)
 
(defun *error*  (msg)
   (if (vl-position
msg
'("console break"
  "Function cancelled"
  "quit / exit abort"
  )
)
     (princ msg)
      (princ "Error!")
      
      )
(vl-catch-all-apply
  'vlax-invoke-method
  (list ExcelApp "Quit")
)
 (mapcar
   (function (lambda (x)(vl-catch-all-apply(function (lambda()
 (if (not (vlax-object-released-p x))
   (progn
   (vlax-release-object x)
   (setq x nil))
 )
      )
   )
     )
 )
      )
   (list xlCells Sht Sheets Wbk ExcelApp)
 )  
 (gc)
 (gc) 
   (princ)
   )
 
 
(setq pfset(vla-get-pickfirstselectionset
            (vla-get-activedocument
              (vlax-get-acad-object))))
 
(vla-clear pfset)
 (setq ftype (list 0  410)
fdata (list "insert"  (getvar 'ctab)))

 (setq ftype (vlax-safearray-fill
               (vlax-make-safearray vlax-vbinteger
                 (cons 0 (1- (length ftype)))) ftype)
       fdata (vlax-safearray-fill
               (vlax-make-safearray vlax-vbvariant
                 (cons 0 (1- (length fdata)))) fdata)
 )
;;select all:
;;(vla-select pfset acselectionsetall nil nil ftype fdata)
;;or select on screen
(prompt "\nSelect blocks that you want to write in Excel")
(vla-selectonscreen pfset ftype fdata)
(if (> (vla-get-count pfset) 0)
 (progn (vlax-for block_obj pfset
          (setq ins_point  (vlax-get block_obj 'insertionpoint)
                ins_record (list (cons "BlockName" (vla-get-effectivename block_obj))
                                 (cons "Position X" (car ins_point))
                                 (cons "Position Y" (cadr ins_point))
                                 (cons "Position Z" (caddr ins_point))
                           )
          )
          (setq exc_data (cons ins_record exc_data))
        )
        ;;  Eof acad part  ;;
        (setq newName "PutYourNameHere") ;<-- change a sheet name here
        (setq filepath (getfiled "Data File" (getvar "dwgprefix") "xls;xlsx" 2))
        (setq ExcelApp (vl-catch-all-apply (function (lambda () (vlax-get-or-create-object "Excel.Application")))))
        (vlax-put-property ExcelApp 'visible :vlax-true)
        (vlax-put-property ExcelApp 'ScreenUpdating :vlax-true)
        (vlax-put-property ExcelApp 'DisplayAlerts :vlax-true)
        (setq Wbk (vl-catch-all-apply 'vla-open (list (vlax-get-property ExcelApp 'workbooks) filepath)))
        (setq Sheets (vl-catch-all-apply 'vlax-get-property (list Wbk 'sheets)))
        (vlax-for itemSheet Sheets (setq shtNames (cons (vlax-get itemSheet 'name) shtNames)))
        ;; check if sheet already exist
        (if (vl-position newName shtNames)
          (progn (alert (strcat "Sheet named " (vl-prin1-to-string newName) " already exist.\nExiting program"))
                 (exit)
          )
        )
        (setq lngCount (vl-catch-all-apply 'vlax-get-property (list Sheets 'count)))
        (setq xlLastSheet (vl-catch-all-apply 'vlax-get-property (list Sheets 'item lngCount)))
        ;;add new sheet
        (vl-catch-all-apply 'vlax-invoke-method (list Sheets 'Add nil nil nil))
        (setq defName (vlax-get (vlax-get ExcelApp 'activesheet) 'name))
        (setq xlNewSheet (vl-catch-all-apply 'vlax-get-property (list Sheets 'Item defName)))
        (vl-cmdf "delay" 300)          ;optional delay 0.3 sec
        (vlax-invoke xlNewSheet 'move nil xlLastSheet)
        (vlax-put-property xlNewSheet 'name newName)
        (vlax-invoke xlNewSheet 'activate)
        ;; refresh XL screen
        (setq Wbk (vl-catch-all-apply (function (lambda () (vlax-get-property ExcelApp 'ActiveWorkBook)))))
        (setq Sht (vl-catch-all-apply (function (lambda () (vlax-get-property ExcelApp 'ActiveSheet)))))
        (setq xlCells (vl-catch-all-apply (function (lambda () (vlax-get-property Sht 'cells)))))
        ;;write the headers
        (setq row 1
              colm 1
        )
        (foreach header (list "Block Name" "X" "Y" "Z")
          (setq xlCell (variant-value (vlax-get-property xlCells 'item row colm)))
          (vlax-put-property xlCell 'value2 (vlax-make-variant header )
          (setq colm (1+ colm))
        )
       ;;write the rest data
        (setq row 1)
        (foreach line exc_data
          (setq row (1+ row))
          (setq colm 1)
          (foreach single line
            (setq xlCell (variant-value (vlax-get-property xlCells 'item row colm)))
            (vlax-put-property xlCell 'value2 (vlax-make-variant (cdr single)))
            (setq colm (1+ colm))
          )
        )
        ;; add some format
        (setq frow (vlax-get-property Sht 'Range "A1:A4"))
        (vlax-put-property frow 'NumberFormat "@")
        (setq fcol (vlax-get-property Sht 'Range "A:A"))
        (vlax-put-property fcol 'NumberFormat "@")
        (setq fcol (vlax-get-property Sht 'Range "B:D"))
        (vlax-put-property fcol 'NumberFormat "#0.000")
        (vlax-invoke (vlax-get-property Sht 'Columns) 'AutoFit)
        (vlax-put-property ExcelApp 'ScreenUpdating :vlax-true)
        (vl-catch-all-apply 'vlax-invoke-method (list Wbk 'Save))
        (vl-catch-all-apply 'vlax-invoke-method (list Wbk 'Close))
 )
)
       (*error* nil)
       (princ)
)

(prompt "\n   >>   Start command with XLDEMO   <<")
(prin1)

[stevesfr]

fixo... using Acad2008, can't get xldemo to work....? HELP... what doing wrong ?? using Office 2000...

[fixo]

Hiya, Steve,

Perhaps you need to change on thisthis line

(setq filepath (getfiled "Data File" (getvar "dwgprefix") "xls" 2))

in Office 2000 just "xls" extension I think

You could be also add

(C:XLDEMO) at the very end of code and the run lisp from console,

after the error will be ooccurs go to menu Debug-->Last error source,

the problem line will be highlighted

[stevesfr]

Hiya, Steve,

Perhaps you need to change on thisthis line

(setq filepath (getfiled "Data File" (getvar "dwgprefix") "xls" 2))

in Office 2000 just "xls" extension I think

You could be also add

(C:XLDEMO) at the very end of code and the run lisp from console,

after the error will be ooccurs go to menu Debug-->Last error source,

the problem line will be highlighted

 

when I pick a block in the drawing, following message occurs at command line:

Command: xldemo

Select blocks that you want to write in Excel

Select objects: 0 found

Select objects:

 

debug is no help, because no definite error message is available yet.

Steve

TIA

[fixo]

My bad,

You have to select blocks then press Enter as usual

[stevesfr]

My bad,

You have to select blocks then press Enter as usual

 

nada

program does not recognize block that is picked on screen, says

Command: XLDEMO

Select blocks that you want to write in Excel

Select objects: 0 found