ASP导出EXCEL代码

<!--#include file="conn.asp"-->


<%
Set xlApplication = Server.CreateObject("Excel.Application") '调用excel对象
xlApplication.Visible = False '无需打开excel
xlApplication.SheetsInNewWorkbook=1 '指定excel中表的数量
xlApplication.Workbooks.Add '添加工作簿
Set xlWorksheet = xlApplication.Worksheets(1) '生成第1个工作表的子对象
xlWorksheet.name="统计" '指定工作表名称
'指定列的宽度以及对齐方式 1左对齐 2右对齐 3居中
xlApplication.ActiveSheet.Columns(1).ColumnWidth=5  
xlApplication.ActiveSheet.Columns(1).HorizontalAlignment=3    
xlApplication.ActiveSheet.Columns(2).ColumnWidth=10
xlApplication.ActiveSheet.Columns(2).HorizontalAlignment=3
xlApplication.ActiveSheet.Columns(3).ColumnWidth=20
xlApplication.ActiveSheet.Columns(3).HorizontalAlignment=3

'xlApplication.ActiveSheet.Rows(i).RowHeight = 30'行的高度
'指定列的高度以及特定列
xlWorksheet.Range(xlWorksheet.Cells(1,1), xlWorksheet.Cells(1,3)).MergeCells =True '合并列
xlWorksheet.Range("A1").value="2005年统计"
xlWorksheet.Range("A1").font.Size=14'字体大小
xlWorksheet.Range("A1").font.bold=true'粗体
xlWorksheet.Range("A1").HorizontalAlignment=3'水平对齐
xlWorksheet.Range("A1").VerticalAlignment=3'垂直对齐

xlWorksheet.Cells(2,1).Value = "编号"
xlWorksheet.Cells(2,2).Value = "姓名"
xlWorksheet.Cells(2,3).Value = "单位"


'xlWorksheet.Range("A1:C1").Borders.LineStyle=1  '设置行style

'--------------------------------------------------自己可做循环i=i+1（数据库数据）



i=1
strSql = "select * from excel"
Set rs =conn.execute(strSql)
if not rs.eof then
do while not rs.eof
xlWorksheet.Cells(2+i,1).Value = rs(0)
xlWorksheet.Cells(2+i,2).Value = rs(1)
xlWorksheet.Cells(2+i,3).Value = rs(2)
i=i+1
rs.movenext
loop
end if



'--------------------------------------------------



Set fs = CreateObject("Scripting.FileSystemObject")
tfile=Server.MapPath("test.xls")
if fs.FileExists(tfile) then
Set f = fs.GetFile(tfile)
f.delete true
Set f = nothing
end if
Set fs = nothing
xlWorksheet.SaveAs tfile '保存文件
xlApplication.Quit '释放对象
Set xlWorksheet = Nothing
Set xlApplication = Nothing
%>
<p align="center"><a href="downfile.asp?fileSpec=<%=tfile%>">下载</a></p>

<%
Function downLoadFile(FileSpec)
on error resume next
Const ForReading=1
Const TristateTrue=-1  
Const FILE_TRANSFER_SIZE=1024 '16384
Dim objFileSystem, objFile, objStream
Dim char
Dim sent
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
If objFileSystem.FileExists(fileSpec)=false Then
response.write("<Script>alert(""请求文件不存在！"");history.back();</script>")
Exit Function
End If
FileName = objFileSystem.GetFileName(FileSpec)
send=0
TransferFile = True
Set objFileSystem = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = objFileSystem.GetFile(FileSpec)
Set objStream = objFile.OpenAsTextStream(ForReading, TristateTrue)
Response.AddHeader "content-type", "application/octet-stream"
Response.AddHeader "Content-Disposition","attachment;filename=" & filename
  
Response.AddHeader "content-length", objFile.Size
Do While Not objStream.AtEndOfStream
char = objStream.Read(1)
Response.BinaryWrite(char)
sent = sent + 1
If (sent MOD FILE_TRANSFER_SIZE) = 0 Then
Response.Flush
If Not Response.IsClientConnected Then
TransferFile = False
Exit Do
End If
End If
Loop
Response.Flush
If Not Response.IsClientConnected Then TransferFile = False
objStream.Close
Set objStream = Nothing
Set objFileSystem = Nothing
End Function
fileSpec =Lcase(Cstr(Trim(Request("fileSpec"))))
downLoadFile(fileSpec)
%>