求数据写入EXCEL

VBALISPER

搞完美点当然好.
如果只是自己用,我觉得用文本文件写入带逗号的的格式,另存为csv格式,直接就可以用EXCEL打开了.这样操作可能简单得多.

革天明

每天一顶，有好例子的发一个，谢谢了

VBALISPER

我网上找的.你主要看最后一句
通过在明经、晓东里边转了一圈又一圈之后终于能从Excellibian把单元格的数据读出来了。但是，还有个大问题解决不了：
1．
(vla-put-visible xlapp 1);1-可见，0-隐藏
一句把所有打开的Excel文件都给隐藏掉了！！！！！

2．同样的
(vlax-invoke-method xlapp 'quit)
一句把所有打开的Excel文件都给关掉了！！！！！

如何处理，能够让我可以把数据读出来且不影响其它打开的Excel文件？或者这么说：是否可以不打开指定的Excel文件就能将其中的数据读出来？


(defun excel-get-data (/ xlapp xlfile fn H8)
  (vl-load-com)
  ;读取单元格数据
  (defun Excel-Get-CellValue(xlapp cell / xlsrng xlsval)
    (setq xlsrng (vlax-get-property xlapp "range" cell))
    (setq xlsval (vlax-variant-value (vlax-get-property xlsrng "Value")))
  )
  (setq xfile (getfiled "打开法兰计算文件" "" "xls" 8))
  (if (setq fn (findfile xfile))
    (if (setq xlapp (vlax-get-or-create-object "Excel.Application"))
      (progn
(vlax-invoke-method
   (vlax-get-property xlapp 'WorkBooks)
   'Open
   fn
)
(vla-put-visible xlapp 0);1-可见，0-隐藏

;单元格数据读取
(setq H8 (Excel-Get-CellValue xlapp "H8"))

;退出并关闭Excel进程
(vlax-invoke-method xlapp 'quit)
(vlax-release-object xlapp)
      )
     )
    )
  H8
)


问题已解决
下面是测试的程序：

;;;取出Excel文件中第一个工作表中指定单元格的数据
(defun c:ttt ()
  (Excel-Get-data)
)

(defun Excel-Get-data ( / xfile cell ADOCONNECT ADORECORDSET ConnectionString lst Sheet-name source cell-tmp cell-value)
  ;指定单元格的数据
  (defun Excel-Get-CellValue (Sheet-name cell)
    (setq source (strcat "SELECT * FROM [" Sheet-name cell":" cell "]"))
    (vlax-invoke-method  ADORecordset "Open" source ADOConnect 1 3 nil)
    (setq cell-tmp (vlax-safearray->list (vlax-variant-value (vlax-invoke-method ADORecordset "GetRows" 1))))
    (vlax-variant-value (car (car cell-tmp)))  
  )

  (setq xfile (getfiled "打开法兰计算文件" "" "xls" 8))
  (setq ADOConnect (vlax-get-or-create-object "ADODB.Connection"))
  (setq ADORecordset (vlax-get-or-create-object "ADODB.Recordset"))
  (setq ConnectionString (strcat "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" xfile ";Extended Properties=;Excel 8.0;HDR=No" ))
  (if (not
(vl-catch-all-error-p
   (vl-catch-all-apply
     (function vlax-invoke-method)
     (list ADOConnect "Open" ConnectionString  "admin" "" nil)
   )
)
      )
    (progn
      (setq lst
      (vlax-safearray->list
        (vlax-variant-value
   (vlax-invoke-method (vlax-invoke-method ADOConnect "OpenSchema" 4 ) "GetRows" 1)
        )
     )
      )
      (setq Sheet-name (vlax-variant-value (car (caddr lst))));确定"第一个"工作表的名称
      (setq cell-value (Excel-Get-CellValue Sheet-name "H16"));H16单元格
      (vlax-invoke-method ADORecordset "Close")
      (vlax-invoke-method ADOConnect "Close")
    )
    (progn
      (princ "\n打开Excel数据文件出错")
      (vl-catch-all-apply 'vlax-invoke-method (list ADOConnect "Close"))
      (setq cell-value nil)
    )
  )
  (vlax-release-object ADORecordset)
  (vlax-release-object ADOConnect)
  cell-value
)


>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

不用ADO原来也是可以实现的

;退出并关闭Excel进程
(vlax-invoke-method xlapp 'quit)
(vlax-release-object xlapp)
上边两句改成以下内容即可

;退出并关闭Excel文件
(vlax-invoke-method
   (vlax-get-property xlapp 'ActiveWorkbook)   
   'close
)















  查看文章   
简单的LISP读取EXCEL文档的内容的例子2011-11-17 17:04;;简单示例lisp读取excel里的数据（没有判断容错功能）by snddd2000 2011-11-17
(setq excelapp0 (vlax-get-object "Excel.Application"))
;;excel程序对象，没开excel下边的都是白搭
(setq activeworkbook0 (vlax-get-property excelapp0 'ActiveWorkbook))
;;excel工作簿对象
(setq activesheet0 (vlax-get-property activeworkbook0 'ActiveSheet))
;;excel工作表对象
(setq cells0 (vlax-get-property activesheet0 'cells))
;;excel单元格对象
(setq a1 (vlax-get-property cells0 'item 1 1))
;;A1单元格对象
(setq a1-value (vlax-variant-value
(vlax-get-property (vlax-variant-value a1) 'text)
;;或者'value
)
)
;;A1里的值



(vlax-put-property cells0 'item 1 1 "123");_向A1单元格写文本

sscylh

如果可以用vba来做的话,很简单的几句代码即可

langjs

转别人的，觉得是真正写入EXCEL
;;; 前不久从台湾买了一本书，其中有一个将块的一些信息提取到excel的程序很不错，拿来与诸位分享。
(defun c:blk2xls (/ apl-exit initexcel endexcel datacell dorow dotable appxls xlsworkbooks newbook newsheet newitem xlscells objs
                    count ent claves numrow title blkss blksub blk_qty k0 i0 blkname xscale yscale zscale rotang blkdxf numcol
                    insert0
                 )                     ; 1.定义离开函数
  (defun apl-exit (msg)
    (endexcel)
    (prompt msg)
    (setq *error* oer)
  )                                    ; 2.initexcel用来初始m excel
  (defun initexcel ()
    (setq appxls (vlax-get-or-create-object "excel.application")
          xlsworkbooks (vlax-get-property appxls "workbooks")
          newbook (vlax-invoke-method xlsworkbooks "add")
          newsheet (vlax-get-property newbook "sheets")
          newitem (vlax-get-property newsheet "item" 1)
          xlscells (vlax-get-property newitem "cells")
    )
    (vla-put-visible appxls :vlax-true)
  )                                    ; 3.endexcel用来释放excel
  (defun endexcel ()
    (vlax-release-object xlscells)
    (vlax-release-object newitem)
    (vlax-release-object newsheet)
    (vlax-release-object newbook)
    (vlax-release-object xlsworkbooks)
    (vlax-release-object appxls)
  )                                    ; 4.datacell将value填入numrow,col的格子中
  (defun datacell (nurow col value)
    (vlax-put-property xlscells "item" numrow col (vl-princ-to-string value))
  )
  (setq oer *error*
        *error* apl-exit
  )
  (vl-load-com)
  (initexcel)
  (setq numrow 1
        numcol 0
  )                                    ; 5.列出表头
  (datacell numrow (setq numcol (1+ numcol))
            "Bock name"
  )
  (datacell numrow (setq numcol (1+ numcol))
            "X scale"
  )
  (datacell numrow (setq numcol (1+ numcol))
            "Y scale"
  )
  (datacell numrow (setq numcol (1+ numcol))
            "Z scale"
  )
  (datacell numrow (setq numcol (1+ numcol))
            "Angle"
  )
  (datacell numrow (setq numcol (1+ numcol))
            "Number"
  )                                    ; 6.依次处理各图块的参考
  (setq blkdxf (tblnext "BLOCK" t))
  (while blkdxf                        ; while1
    (setq blkname (cdr (assoc 2 blkdxf))
          blkss (ssget "x" (list (cons 0 "INSERT") (cons 2 blkname)))
    )
    (setq i0 0)
    (if blkss
      (setq blkss_qty (sslength blkss)) ; 写出块的数量
      (setq blkss_qty 0)               ; 图面上没有这个块则数量为0
    )
    (while (< i0 blkss_qty)            ; while2 ;当有这个图块时;;;7.依条件建立图块参考的选集
      (setq insert0 (ssname blkss i0)
            xscale (cdr (assoc 41 (entget insert0)))
            yscale (cdr (assoc 42 (entget insert0)))
            zscale (cdr (assoc 43 (entget insert0)))
            rotang (cdr (assoc 50 (entget insert0)))
            blksub (ssget "x" (list (cons 0 "INSERT") (cons 2 blkname) (cons 41 xscale) (cons 42 yscale) (cons 43 zscale)
                                    (cons 50 rotang)
                              )
                   )
            blkss_qty (- blkss_qty (sslength blksub))
            numrow (1+ numrow)
            numcol 0
            k0 0
      )
      (while (< k0 (sslength blksub))  ; while3
        (setq blkss (ssdel (ssname blksub k0) blkss))
        (setq k0 (1+ k0))
      )                                ; end whlie3
                                       ; 8.写入资料
      (datacell numrow (setq numcol (1+ numcol))
                blkname
      )
      (datacell numrow (setq numcol (1+ numcol))
                (rtos xscale)
      )
      (datacell numrow (setq numcol (1+ numcol))
                (rtos yscale)
      )
      (datacell numrow (setq numcol (1+ numcol))
                (rtos zscale)
      )
      (datacell numrow (setq numcol (1+ numcol))
                (rtos (* 180 (/ rotang pi)))
      )
      (datacell numrow (setq numcol (1+ numcol))
                (rtos (sslength blksub) 2 0)
      )
    )                                  ; end while2
    (setq blkdxf (tblnext "BLOCK"))
  )                                    ; end while1 (endexcel)
  (setq *error* oer)
  (princ)
)

sscylh

Sub aa() Dim xls As Excel.Application Set xls = New Excel.Application xls.DisplayAlerts = False xls.Quit Dim s As String s = Dir("c:/test.xls") If s = "" Then With xls.Workbooks.Add    .Sheets(1).[a1:f1] = Array("日期", "时间", "月份", "X", "L", "GG")    .SaveAs FileName:="c:\test.xls", Password:="123456"    .Close savechanges:=True End With Else xls.Workbooks.Open "c:\" & s, , , , "123456" xls.ActiveWorkbook.Sheets(1).[a65536].End(xlUp).Offset(1, 0).Resize(1, 6) = Array("日期", "时间", "月份", "X", "L", "GG") For i = 1 To xls.Workbooks.Count xls.Workbooks(i).Close savechanges:=True Next End If xls.DisplayAlerts = True xls.Quit Set xls = Nothing End Sub

sscylh

2. Sub aa()
   
3. Dim xls As Excel.Application
   
4. Set xls = New Excel.Application
   
5. xls.DisplayAlerts = False
   
6. xls.Quit
   
7. Dim s As String
   
8. s = Dir("c:/test.xls")
   
9. If s = "" Then
   
10. With xls.Workbooks.Add
    
11.    .Sheets(1).[a1:f1] = Array("日期", "时间", "月份", "X", "L", "GG")
    
12.    .SaveAs FileName:="c:\test.xls", Password:="123456"
    
13.    .Close savechanges:=True
    
14. End With
    
15. Else
    
16. xls.Workbooks.Open "c:" & s, , , , "123456"
    
17. xls.ActiveWorkbook.Sheets(1).[a65536].End(xlUp).Offset(1, 0).Resize(1, 6) = Array("日期", "时间", "月份", "X", "L", "GG")
    
18. For i = 1 To xls.Workbooks.Count
    
19. xls.Workbooks(i).Close savechanges:=True
    
20. Next
    
21. End If
    
22. xls.DisplayAlerts = True
    
23. xls.Quit
    
24. Set xls = Nothing
    
25. End Sub
    

Sub aa()<br /> Dim xls As Excel.Application<br /> Set xls = New Excel.Application<br /> xls.DisplayAlerts = False<br /> xls.Quit<br /> Dim s As String<br /> s = Dir("c:/test.xls")<br /> If s = "" Then<br /> With xls.Workbooks.Add<br />    .Sheets(1).[a1:f1] = Array("日期", "时间", "月份", "X", "L", "GG")<br />    .SaveAs FileName:="c:\test.xls", Password:="123456"<br />    .Close savechanges:=True<br /> End With<br /> Else<br /> xls.Workbooks.Open "c:" & s, , , , "123456"<br /> xls.ActiveWorkbook.Sheets(1).[a65536].End(xlUp).Offset(1, 0).Resize(1, 6) = Array("日期", "时间", "月份", "X", "L", "GG")<br /> For i = 1 To xls.Workbooks.Count<br /> xls.Workbooks(i).Close savechanges:=True<br /> Next<br /> End If<br /> xls.DisplayAlerts = True<br /> xls.Quit<br /> Set xls = Nothing<br /> End Sub<br />

xiabin68

帮楼主顶一下，，，，

革天明

sscylh 发表于 2012-9-24 13:13

sscylh

打开vbe编辑器,工具--引用--microsoft excel object libiray