曾经由于需要将数据库里的数据导出到excel里，因为数据表的内容太多，直接导出呢？不符合阅读者的习惯，到处找代码，读方法，都没有一个能做到自己定义任意形式的excel数据导取方案，没法子了，自己研究了好久，总算做出了一些代码。可以按照网页上自己显示的形式，原搬不动的导出一模一样的excel表了，只要您的服务器支持asp，就OK了，不能任何组件！
以下为代码:
< %
'定义数据库链接文件
Const AccessPath="Statisticdata"
Const AccessFile="Statisticdata.asp"
'定义数据库连接
Dim Conn
Set Conn= Server.CreateObject("ADODB.Connection")
Conn.ConnectionString="Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password=01;Data Source="& Server.MapPath(AccessPath&"/"&AccessFile)
Conn.Open
If Err Then
Err.Clear
Set Conn = Nothing
Response.Write("<head><meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312"" /><title>数据库连接出错，请检查连接字串</title></head><body><div align=""center"" style=""width:400px;height:100px;padding: 8px;font-size:9pt;border: 1px solid ThreeDShadow;POSITION:absolute;top:expression((document.body.offsetHeight-100)/2);left:expression((document.body.offsetWidth-400)/2);""><table width=""100%"" height=""100%"" style=""font-size:12px;font-family:Tahoma;""><tr><td align=""center""><strong>数据库连接出错，请检查连接字串</strong></td></tr></table></div></body>")
Response.End
End If
Dim sql,ObjFso,XlsPath,StrLine,ResponseStr,filename
sql = "SELECT * FROM [表名]" ' 查询数据库
filename=replace(now(),"-","") '生成文件名
Set ObjFso = Server.CreateObject("Scripting.FileSystemObject") '建立FSO对象
XlsPath = Server.MapPath("xls/"& DateToStr(Now(),"YmdHIS") &".xls") '
rso rs,sql
If ObjFso.FileExists(XlsPath) Then '如果服务器端文件存在则删除
ObjFso.DeleteFile(XlsPath)
End If
'--创建EXCEL文件
Set NewFile = ObjFso.CreateTextFile(XlsPath,true)
'根据数据库中定义的字段名生成excel表里的列名
'StrLine=""
'For Each x In Rs.fields
'StrLine = StrLine & x.name & chr(9)
'Next
'或者根自定义字段名生成excel表里的列名
StrLine = "" & "类型编号" & chr(9) & "类型名称" & chr(9) & "类型说明" & chr(9) & "折算比率" & chr(9)
'--将表的列名先写入EXCEL
NewFile.WriteLine strLine
While Not Rs.EOF
StrLine=""
For Each x In rs.Fields
StrLine = StrLine & x.value & chr(9)
Next
'--将表的数据写入EXCEL
NewFile.WriteLine StrLine
Rs.MoveNext
Wend
Rs.Close
Set Rs = Nothing
Set NewFile = Nothing
Set ObjFso = Nothing
down =trim("xls/"& DateToStr(Now(),"YmdHIS") &".xls")
'Response.write"电子表格已经生成。<a href='"&down&"'>点击下载</a>"
Response.Redirect down
Function DateToStr(DateTime,ShowType) '日期转换函数
Dim DateMonth,DateDay,DateHour,DateMinute
DateMonth=Month(DateTime)
DateDay=Day(DateTime)
DateHour=Hour(DateTime)
DateMinute=Minute(DateTime)
If Len(DateMonth)<2 Then DateMonth="0"&DateMonth
If Len(DateDay)<2 Then DateDay="0"&DateDay
Select Case ShowType
Case "Y-m-d"
DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay
Case "Y-m-d H:I A"
Dim DateAMPM
If DateHour>12 Then
DateHour=DateHour-12
DateAMPM="PM"
Else
DateHour=DateHour
DateAMPM="AM"
End If
If Len(DateHour)<2 Then DateHour="0"&DateHour
If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&" "&DateAMPM
Case "Y-m-d H:I:S"
Dim DateSecond
DateSecond=Second(DateTime)
If Len(DateHour)<2 Then DateHour="0"&DateHour
If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&":"&DateSecond
Case "YmdHIS"
DateSecond=Second(DateTime)
If Len(DateHour)<2 Then DateHour="0"&DateHour
If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
DateToStr=Year(DateTime)&DateMonth&DateDay&DateHour&DateMinute&DateSecond
Case "ym"
DateToStr=Right(Year(DateTime),2)&DateMonth
Case "d"
DateToStr=DateDay
Case Else
If Len(DateHour)<2 Then DateHour="0"&DateHour
If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute
End Select
End Function
% >