01 Dim Conn, StrConn, RS, SQL
02 set Conn = CreateObject("ADODB.Connection")
03 set RS = CreateObject("ADODB.Recordset")
04 StrConn = "Provider=SQLOLEDB;data source=SQLSERVER;Initial Catalog=DB;User ID=sa;Password=passwd"
05 SQL = "select * from mytable"
06 Conn.Open StrConn
07 RS.Open SQL,conn,1,1
08 rstoexcel(RS,"c:\sql.xls")
09
10 'sqltoexcel "TEXT;c:\11.txt","c:\test.xls",null
11 'sqltoexcel "URL;http://amupdate.nxt.ru/","c:\url.xls",null
12 sqltoexcel "OLEDB;" & StrConn ,"c:\sql.xls",SQL
13
14 'RS记录导出到EXCEL文件 by chenall http://chenall.net
15 '使用方法
16 'rsToExcel Recordset,ExcelFileName
17 'rsToExcel rs,"c:\test.xls"
18 sub rsToExcel(rs,file)
19     'on error resume next
20     dim n,x
21     dim xlApp,xlBook,xlSheet
22     Set xlApp = CreateObject("Excel.Application")'创建EXCEL对象
23     with xlApp.Workbooks.Add().Worksheets(1)'创建新的工作表对像
24         n = 0
25         for each x in rs.Fields
26             n=n+1
27             .Cells(1,n) = x.name
28             .Cells(1,n).Font.Bold   =   True '加粗
29             .Cells(1,n).HorizontalAlignment=3 '居中
30         next
31         .Range("A2").CopyFromRecordset rs
32         .Range("A1:" & chr(asc("A")+n-1) & rs.recordcount+1).Borders.LineStyle = 1'画表框
33         .Range("A1:" & chr(asc("A")+n-1) & rs.recordcount+1).EntireColumn.AutoFit() '自动调整列宽
34         xlApp.displayalerts=false'不显示覆盖文件的提示
35         .SaveAs file'另存为新的文件名
36         xlApp.displayalerts=true'恢复显示
37     end with
38     xlApp.Quit'退出excel
39     set xlApp=nothing
40 end sub
41
42 '任意数据源导出到EXCEL文件 by chenall http://chenall.net
43 '使用方法,sql参数可以为null
44 'sqlToExcel conn,ExcelFileName,sql
45 'sqlToExcel conn,"c:\test.xls",sql
46 sub sqlToExcel(conn,file,sql)
47 '    on error resume next
48     dim xlApp,xlBook,xlSheet,QryTable
49     Set xlApp = CreateObject("Excel.Application")'创建EXCEL对象
50     with xlApp.Workbooks.Add().Worksheets(1)'创建新的工作表对像
51         if isnull(sql) then
52             set QryTable = .QueryTables.add(conn,.Range("A1")) '导入数据
53         else
54             set QryTable = .QueryTables.add(conn,.Range("A1"),sql) '导入数据
55         end if
56         QryTable.Refresh false
57         xlApp.displayalerts=false'不显示覆盖文件的提示
58         .SaveAs file'另存为新的文件名
59         xlApp.displayalerts=true'恢复显示
60     end with
61     xlApp.Quit'退出excel
62     set xlApp=nothing
63 end sub