因为项目需要，所以从网上找了一个类，但是那个类问题比较多，所以自己修改了一下，增加容错程度，提升一些性能，里面有部分代码是根据我的项目修改的，所以大家在使用的时候自己改一下就可以了。
使用方法：
<%On Error Resume Next%>
<!--#include file="../Include/Constants.Class.asp"-->
<!--#include file="../Include/Config.Class.asp"-->
<!--#include file="../Include/DBControl.Class.asp"-->
<!--#include file="../Include/FunctionLib.Class.asp"-->
<!--#include file="../Include/Manager.Class.asp"-->
<!--#include file="../Include/Export2Excel.Class.asp"-->
<%
Dim Cfg,Db,Flib,Admin,Con,newExcel,url
Set Cfg=New Config
Set Con=New Constants
Set Admin=New Manager
Set Flib=New FunctionLib
Set Db=New DBControl
If session(request.QueryString("sql"))="" or session(request.QueryString("field"))="" Then
Flib.MessageBox "Excel导出页面参数出错！请联系管理员","",0
End If
response.Write "导出过程可能需要很长时间,请稍等
<br>"
response.Flush()
set newExcel = New Export2Excel
newExcel.FilePath = "Excel/"
newExcel.Sql = session(request.QueryString("sql"))
newExcel.Field = session(request.QueryString("field"))
response.write newExcel.export2Excel()
%>类的源代码：
<%
' 使用方法：
' set newExcel = New Export2Excel
' newExcel.FilePath = "/mail/excel/"----------------------------------路径
' newExcel.Sql = "select * from user"-------------------------------查询语句
' newExcel.Field = "帐号||姓名||所属部门||"----------------------输出列名
' response.write newExcel.export2Excel()
'类开始
Class Export2Excel
'声明常量、变量
Private strFilePath,strTitle,strSql,strField,strRows,strCols
Private strCn,strHtml,strPath,strServerPath,Filename
Private objDbCn,objRs
Private objXlsApp,objXlsWorkBook,objXlsWorkSheet
Private arrField
'初始化类
Private Sub Class_Initialize()
set objDbCn = Db
strTitle = "查询结果"
strFilePath="Excel/"
strRows = 2
strCols = 1
End Sub
'销毁类
Private Sub Class_Terminate()
End Sub
'属性FilePath
Public Property Let FilePath(value)
strFilePath = value
strServerPath=strFilePath
End Property
Public Property Get FilePath()
FilePath = strFilePat
End Property
'属性Title
Public Property Let Title(value)
strTitle = value
End Property
Public Property Get Title()
Title = strTitle
End Property
'属性Sql
Public Property Let Sql(value)
strSql = value
End Property
Public Property Get Sql()
Sql = strSql
End Property
'属性Field
Public Property Let Field(value)
strField = value
End Property
Public Property Get Field()
Field = strField
End Property
'属性Rows
Public Property Let Rows(value)
strRows = value
End Property
Public Property Get Rows()
Rows = strRows
End Property
'属性Cols
Public Property Let Cols(value)
strCols = value
End Property
Public Property Get Cols()
Cols = strCols
End Property
'
Public Function export2Excel()
if strSql = "" or strField = "" then
response.write "参数设置错误，请与管理员联系！谢谢"
response.end
end if
strFilePath = GetFilePath(Server.mappath(strFilePath&"upload.asp"),"\")
set objFso = createobject("scripting.filesystemobject")
if objFso.FolderExists(strFilePath) = False then
objFso.Createfolder(strFilePath)
end if
Filename=cstr(createFileName()) & ".xls"
strFileName = strFilePath & Filename
objDbCn.Open()
set objRs = objDbCn.execute(strSql)
if objRs.EOF And objRs.BOF then
strHtml = "抱歉，暂时没有任何合适的数据导出，如有疑问，请与管理员联系！"
else
set objXlsApp = server.CreateObject("Excel.Application")
objXlsApp.Visible = false
objXlsApp.WorkBooks.Add
set objXlsWorkBook = objXlsApp.ActiveWorkBook
set objXlsWorkSheet = objXlsWorkBook.WorkSheets(1)
arrField = split(strField,"||")
for f = 0 to Ubound(arrField)
objXlsWorkSheet.Cells(1,f+1).Value = arrField(f)
'response.Write arrField(f)&" "
next
'response.Write "<br>"
objRs=objRs.getRows()
If instr(Sql,"exportEnterprise ")=0 then
for c=0 to ubound(objRs,2)
If response.IsClientConnected=false then exit for '数据多导出时间很长，所以需要探测下客户端是否还在连接
response.Write "正在导出第"&cstr(c+1)&"条<br>"
response.Flush()
for f = 0 to ubound(objRs,1)
If response.IsClientConnected=false then exit for
objXlsWorkSheet.Cells(c+2,f+1).Value = trim(Cstr(objRs(f,c)))&VBCR
'objXlsWorkSheet.Columns(f+1).ColumnWidth=Len(Cstr(objRs(f,c)))*2
next
next
Else
for c=0 to ubound(objRs,2)
If response.IsClientConnected=false then exit for
response.Write "正在导出第"&cstr(c+1)&"条<br>"
response.Flush()
for f = 0 to ubound(objRs,1)
If response.IsClientConnected=false then exit for
If f<>1 then
objXlsWorkSheet.Cells(c+2,f+1).Value = trim(Cstr(objRs(f,c)))&VBCR
'objXlsWorkSheet.Columns(f+1).ColumnWidth=Len(Cstr(objRs(f,c)))*2
Else
objXlsWorkSheet.Cells(c+2,f+1).Value = trim(replace(replace(Cstr(objRs(f,c)),"0",""),"|"," "))&VBCR
'objXlsWorkSheet.Columns(f+1).ColumnWidth=Len(Cstr(objXlsWorkSheet.Cells(c+2,f+1).Value))*2
End If
next
next
End If
'必不可少，否则会出现错误
If objFso.fileExists(strFileName)=true then
objFso.deletefile strFileName
End if
response.Write "导出成功！<br>"
response.Flush()
objXlsWorkSheet.SaveAs strFileName
strHtml = "<script>location.href='" & GetFilePath(Request.ServerVariables("HTTP_REFERER"),"/")&strServerpath&Filename & "';</script>"
objXlsApp.Quit'重要
set objXlsWorkSheet = nothing
set objXlsWorkBook = nothing
set objXlsApp = nothing
end if
objDbCn.Close()
set objRs = nothing
if err > 0 then
strHtml = "系统忙,请稍后重试"
end if
export2Excel = strHtml
End Function
'函数
Public Function createFileName()
If Admin.id<>"" then
fName=Admin.id
Else
fName=now
fName=replace(fName,":","")
fName=replace(fName,"-","")
fName=replace(fName," ","")
End If
createFileName=fName
End Function
Public function GetFilePath(FullPath,str)
If FullPath <> "" Then
GetFilePath = left(FullPath,InStrRev(FullPath, str))
Else
GetFilePath = ""
End If
End function
'Public Function debug(varStr)
' response.write varStr
' response.end
'End Function
'类结束
End Class
%>
---------------------------------------------------------
专注移动开发
Android, Windows Mobile, iPhone, J2ME, BlackBerry, Symbian
posted on 2007-07-29 16:28
TiGERTiAN 阅读(2204)
评论(8) 编辑 收藏 所属分类:
VB/ASP