因為項目需要，所以從網上找了一個類，但是那個類問題比較多，所以自己修改了一下，增加容錯程度，提升一些性能，里面有部分代碼是根據我的項目修改的，所以大家在使用的時候自己改一下就可以了。
使用方法：
<%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 閱讀(2215)
評論(8) 編輯 收藏 所屬分類:
VB/ASP