access MDB 转换为 Execl(ASP类)

由于下载这个clsExport2Excel 代码时，已经找不到代码出处

感谢上传这个类的朋友，为大家带来了方便

我只对其中的属性传递做了一些调整，希望更能贴近实际应用。

<％
'lucker.chu 留
'
'类开始
Class clsExport2Excel
'声明常量、变量
Private strFilePath,strTitle,strSql,strField,strRows,strCols,cFileName,DataBasePath
Private strCn,strHtml,strPath
Private objDbCn,objRs
Private objXlsApp,objXlsWorkBook,objXlsWorkSheet
Private arrField

'初始化类
Private Sub Class_Initialize()
strFilePath = ".\"
strTitle = "查询结果"
strRows = 2
strCols = 1
End Sub

'销毁类
Private Sub Class_Terminate()

End Sub

'数据表位置
Public Property Let DataPath(value)
DataBasePath = value
End Property

Public Property Get DataPath()
DataPath = DataBasePath
End Property

'属性FilePath
Public Property Let FilePath(value)
strFilePath = value
End Property

Public Property Get FilePath()
FilePath = strFilePath
End Property

'文件名
Public Property Let FileName(value)
cFileName = value
End Property

Public Property Get FileName()
FileName = cFileName
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()
DataBasePath=Server.MapPath(DataBasePath) '修改要打开的数据表所在位置
strCn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DataBasePath
set objDbCn = server.CreateObject("adodb.connection")
objDbCn.open strCn

if strSql = "" or strField = "" then
   response.write "参数设置错误，请与管理员联系！谢谢"
   response.end
end if

if right(strFilePath,1) = "/" or right(strFilePath,1) = "\" then
   strFilePath = left(strFilePath,len(strFilePath)-1)
end if
if instr("/",strFilePath) > 0 then
   strFilePath = replace(strFilePath,"/","\")
end if
strFilePath = strFilePath & "\"

set objFso = createobject("scripting.filesystemobject")
if objFso.FolderExists(server.mappath(strFilePath)) = False then
   objFso.Createfolder(server.mappath(strFilePath))
end if

strFileName = strFilePath & cFileName

set objRs = server.CreateObject("adodb.RecordSet")
objRs.open strSql,objDbCn,3,3
if objRs.recordcount <= 0 then
   strHtml = "暂时没有任何合适的数据导出，如有疑问，请与管理员联系！抱歉"
else
   set objXlsApp = server.CreateObject("Excel.Application")
   objXlsApp.Visible = false
   objXlsApp.WorkBooks.Add

   set objXlsWorkBook = objXlsApp.ActiveWorkBook
   set objXlsWorkSheet = objXlsWorkBook.WorkSheets(1)

   objXlsWorkSheet.Cells(1,1).Value = strTitle

   arrField = split(strField,"||")
   for f = 0 to Ubound(arrField)
    objXlsWorkSheet.Cells(2,f+1).Value = arrField(f)
   next

   for c = 1 to objRs.recordcount
    for f = 0 to objRs.fields.count - 1
     '''身份证号码特殊处理
     if objRs.fields(f).name = "pm_field_41325" or objRs.fields(f).name = "cardID" then
      objXlsWorkSheet.Cells(c+2,f+1).Value = "'" & objRs.fields(f).value
     '''就业特殊处理
     elseif objRs.fields(f).name = "JiuYe" then
      select case objRs.fields(f).value
       case 1
        objXlsWorkSheet.Cells(c+2,f+1).Value = "是"
       case 0
        objXlsWorkSheet.Cells(c+2,f+1).Value = "否"
       case -1
        objXlsWorkSheet.Cells(c+2,f+1).Value = "(未知)"
      end select
     else
      objXlsWorkSheet.Cells(c+2,f+1).Value = objRs.fields(f).value
     end if
    next
    objRs.movenext
   next

   objXlsWorkSheet.SaveAs server.mappath(strFileName)

   strHtml = "Excel文件已经导出成功，您可以<a href='" & strFileName & "' target='_blank'>打开</a>文件并将文件另存到本地目录中！"
   'strhtml = server.mappath(strFileName)
   objXlsApp.Quit
   set objXlsWorkSheet = nothing
   set objXlsWorkBook = nothing
   set objXlsApp = nothing
end if
objRs.close
set objRs = nothing

if err > 0 then
   strHtml = "Excel文件导出时出现意外错误，请<a href='#' onclick='window.history.back();'>返回</a>，如有疑问，请与管理员联系！抱歉"
end if

export2Excel = strHtml
End Function

'Public Function debug(varStr)
' response.write varStr
' response.end
'End Function

'类结束
End Class

％>

类的使用方法：

<％
Function createFileName()
fName=now
fName=replace(fName,":","")
fName=replace(fName,"-","")
fName=replace(fName," ","")
createFileName=fName
End Function

'on error resume next
'引用内容
set newExcel = New clsExport2Excel    '调用MdbToExecl输出类
newExcel.DataPath = "OADB/DB.MDB"    '数据源
newExcel.FileName = "okok.xls"     'Execl存放的文件名
newExcel.FilePath = "/execl"     'Execl文件存放的位置
newExcel.Sql = "select * from Information" '查询语句
newExcel.Title = ""        '输出标题
newExcel.Field = "wenjm||tuplj||"    '输出列名
response.write newExcel.export2Excel()
％>