此版本比1.0版本功能增强了许多,并且也和ACCESS那类一样,可以多表存为一个文件,并也可每一表存一文件,使用方法都是相同的了。在此版本中还增加了一个方法:[Obj].Close,此方法是为了不想注销类,但又想结束类使用的Excel进程时所增加的。
<%
Class DataBaseToExcel
'/***************************************************************************
'/* 转移数据到Excel文件(备份数据库类 Excel篇) V2.0
'/*作者:死在水中的鱼(死鱼)
'/*日期:2004年8月4日
'/*Blog:http://blog.csdn.com/bpfish
'/*
'/*声明:使用此类必需服务器上装有Office(Excel)程序,否则使用时可能不能转移数据
'/* 此版本的类支持一Excel文件存放多数据表,也可将每一个数据表存放为一个文件,
'/* 使用方法是在Transfer表之前更换TargetFile参数值即可
'/*用法:
'/*方法一:(Access数据库文件 TO Excel数据库文件)
'/*1、先设置源数据库文件SourceFile(可选)和目标数据库文件TargetFile(必选)
'/*2、再使用Transfer("源表名","目标表名","字段列表","转移条件")方法转移数据
'/*例子:
'/* Dim sFile,tFile,ObjClass,sResult
'/* sFile=Server.MapPath("data/data.mdb")
'/* tFile=Server.Mappath(".")&"/back.xls"
'/* Set ObjClass=New DataBaseToExcel
'/* ObjClass.SourceFile=sFile
'/* ObjClass.TargetFile=tFile
'/* sResult=ObjClass.Transfer("table1","表一","","")
'/* If sResult Then
'/* Response.Write "转移数据成功!"
'/* Else
'/* Response.Write "转移数据失败!"
'/* End If
'/* Set ObjClass=Nothing
'/*
'/*方法二:(其它数据库文件 To Excel数据库文件)
'/*1、设置目标数据库文件TargetFile
'/*2、设置Adodb.Connection对象
'/*3、再使用Transfer("源表名","目标表名","字段列表","转移条件")方法转移数据
'/*例子:(在此使用Access的数据源做例子,你可以使用其它数据源)
'/* Dim Conn,ConnStr,tFile,ObjClass,sResult
'/* tFile=Server.Mappath(".")&"/back.xls"
'/* Set Conn=Server.CreateObject("ADODB.Connection")
'/* ConnStr="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("data/data.mdb")
'/* Conn.Open ConnStr
'/* Set ObjClass=New DataBaseToExcel
'/* Set ObjClass.Conn=Conn '此处关键
'/* ObjClass.TargetFile=tFile
'/* sResult=ObjClass.Transfer("table1","表一","","")
'/* If sResult Then
'/* Response.Write "转移数据成功!"
'/* Else
'/* Response.Write "转移数据失败!"
'/* End If
'/* Set ObjClass=Nothing
'/* Conn.Close
'/* Set Conn=Nothing
'/*
'/*说明:TargetFile属性一定要设置!(备份文件地址,绝对地址!)
'/* 如果不设置SourceFile则一定要设置Conn,这两个属性必选之一,但优先权是Conn
'/* 方法:Transfer("源数据表名","目标数据表名","字段列表","转移条件")
'/* “字段列表;转移条件”格式与SQL的“字段列表”,“查询条件”格式相同
'/* "字段列表"为空则是所有字段,“查询条件”为空则获取所有数据
'/* 此版本增加了一个方法Close,此方法是为了不想注销类但又想把数据保存到文件并结束Excel进程时使用
'/***************************************************************************
Private s_Conn
Private objExcelApp,objExcelSheet,objExcelBook
Private sChar,EndChar,iSheet
'/***************************************************************************
'/* 全局变量
'/*外部直接使用:[Obj].SourceFile=源文件名
'/***************************************************************************
Public SourceFile
Private s_TargetFile
Private Sub Class_Initialize
sChar="ABCDEFGHIJKLNMOPQRSTUVWXYZ"
objExcelApp=Null
s_Conn=Null
iSheet=1 '标记当前的活动的Excel工作表(初始范围是1--3)
End Sub
Private Sub Class_Terminate
If IsObject(s_Conn) And Not IsNull(s_Conn) Then
s_Conn.Close
Set s_Conn=Nothing
End If
CloseExcel
End Sub
'/***************************************************************************
'/* 设置/返回Conn对象
'/*说明:添加这个是为了其它数据库(如:MSSQL)到Excel数据库的数据转移而设置的
'/***************************************************************************
Public Property Set Conn(sNewValue)
If Not IsObject(sNewValue) Then
s_Conn=Null
Else
Set s_Conn=sNewValue
End If
End Property
Public Property Get Conn
If IsObject(s_Conn) Then
Set Conn=s_Conn
Else
s_Conn=Null
End If
End Property
'/***************************************************************************
'/* 设置/返回Target对象
'/*说明:当改变TargetFile时对以前有做移动数据的则保存
'/***************************************************************************
Public Property Let TargetFile(sNewValue)
If UCase(sNewValue)<>UCase(s_TargetFile) Then '改变文件,则关闭以前的Excel进程
CloseExcel
End If
s_TargetFile=sNewValue
End Property
Public Property Set TargetFile(sNewValue)
If UCase(sNewValue)<>UCase(s_TargetFile) Then '改变文件,则关闭以前的Excel进程
CloseExcel
End If
s_TargetFile=sNewValue
End Property
Public Property Get TargetFile
TargetFile=s_TargetFile
End Property
'/***************************************************************************
'/* 数据转移
'/*函数功能:转移源数据到TargetFile数据库文件
'/*函数说明:利用SQL语句的Select Into In方法转移
'/*函数返回:返回一些状态代码True = 转移数据成功 False = 转移数据失败
'/*函数参数:sTableName = 源数据库的表名
'/* sCol = 要转移数据的字段列表,格式则同Select 的字段列表格式相同
'/* sSql = 转移数据时的条件 同SQL语句的Where 后面语句格式一样
'/***************************************************************************
Public Function Transfer(sTableName,tTableName,sCol,sSql)
On Error Resume Next
Dim SQL,Rs
Dim iFieldsCount,iMod,iiMod,iCount,i
If s_TargetFile="" Then '没有目标保存文件,转移失败
Transfer=False
Exit Function
End If
If sTableName="" Then '没有数据表,转移失败
Transfer=False
Exit Function
End If
If tTableName="" Then '没有目标表名使用源表名
tTableName=sTableName
End If
If Not InitConn Then '如果不能初始化Conn对象则转移数据出错
Transfer=False
Exit Function
End If
If Not CreateSheet(tTableName) Then '如果不能初始化Excel对象并不能激活Sheet工作表则转移数据出错
Transfer=False
Exit Function
End If
If sSql<>"" Then '条件查询
sSql=" Where "&sSql
End If
If sCol="" Then '字段列表,以","分隔
sCol="*"
End If
Set Rs=Server.CreateObject("ADODB.RecordSet")
SQL="SELECT "&sCol&" From ["&sTableName&"]"&sSql
Rs.Open Sql,s_Conn,1,1
If Err.Number<>0 Then '出错则转移数据错误,否则转移数据成功
Err.Clear
Transfer=False
Set Rs=Nothing
Exit Function
End If
iFieldsCount=Rs.Fields.Count
'没字段和没有记录则退出
If iFieldsCount<1 Or Rs.Eof Then
Transfer=False
Set Rs=Nothing
Exit Function
End If
'获取单元格的结尾字母
iMod=iFieldsCount Mod 26
iCount=iFieldsCount / 26
If iMod=0 Then
iMod=26
iCount=iCount
End If
EndChar=""
Do While iCount>0
iiMod=iCount Mod 26
iCount=iCount / 26
If iiMod=0 Then
iiMod=26
iCount=iCount
End If
EndChar=Mid(sChar,iiMod,1)&EndChar
Loop
EndChar=EndChar&Mid(sChar,iMod,1)
Dim sExe '运行字符串
'字段名列表
i=1
sExe="objExcelSheet.Range(""A"&i&":"&EndChar&i&""").Value = Array("
For iMod=0 To iFieldsCount-1
sExe=sExe&""""&Rs.Fields(iMod).Name
If iMod=iFieldsCount-1 Then
sExe=sExe&""")"
Else
sExe=sExe&""","
End if
Next
Execute sExe '写字段名
If Err.Number<>0 Then '出错则转移数据错误,否则转移数据成功
Err.Clear
Transfer=False
Rs.Close
Set Rs=Nothing
Exit Function
End If
i=2
Do Until Rs.Eof
sExe="objExcelSheet.Range(""A"&i&":"&EndChar&i&""").Value = Array("
For iMod=0 to iFieldsCount-1
sExe=sExe&""""&Rs.Fields(iMod).Value
If iMod=iFieldsCount-1 Then
sExe=sExe&""")"
Else
sExe=sExe&""","
End if
Next
Execute sExe '写第i个记录
i=i+1
Rs.MoveNext
Loop
If Err.Number<>0 Then '出错则转移数据错误,否则转移数据成功
Err.Clear
Transfer=False
Rs.Close
Set Rs=Nothing
Exit Function
End If
'保存文件
If iSheet=1 Then '第一张工作表时保存为文件
objExcelBook.SaveAs s_TargetFile
Else
objExcelBook.Save '其它工作表直接Save
End If
If Err.Number<>0 Then '出错则转移数据错误,否则转移数据成功
Err.Clear
Transfer=False
Rs.Close
Set Rs=Nothing
Exit Function
End If
Rs.Close
Set Rs=Nothing
iSheet=iSheet+1 '新Excel工作表
Transfer=True
End Function
'/***************************************************************************
'/* 关闭Excel进程,并保存数据
'/*
'/***************************************************************************
Public Sub Close
CloseExcel
End Sub
'/***************************************************************************
'/* 初始化Excel组件对象
'/*
'/***************************************************************************
Private Function InitExcel()
On Error Resume Next
If Not IsObject(objExcelApp) Then
Set objExcelApp=Server.CreateObject("Excel.Application")
objExcelApp.DisplayAlerts = False
objExcelApp.Application.Visible = False
objExcelApp.WorkBooks.add
Set objExcelBook=objExcelApp.ActiveWorkBook
If Err.Number<>0 Then
CloseExcel
InitExcel=False
Err.Clear
Exit Function
End If
End If
InitExcel=True
End Function
Private Function CreateSheet(sName) '建立Excel的Sheet并激活
If Not InitExcel Then
CreateSheet=False
Exit Function
End If
On Error Resume Next
If iSheet<=3 Then '如果iSheet的值还在1,2,3则不用新建工作表,Excel默认有三张表
Set objExcelSheet = objExcelBook.Sheets(iSheet)
Else
Set objExcelSheet = objExcelBook.Sheets.add
End If
objExcelSheet.Name=sName
If Err.Number<>0 Then
CreateSheet=False
Exit Function
End If
CreateSheet=True
End Function
Private Sub CloseExcel()
On Error Resume Next
If IsObject(objExcelApp) Then
objExcelApp.Quit
Set objExcelSheet=Nothing
Set objExcelBook=Nothing
Set objExcelApp=Nothing
End If
ObjExcelApp=Null
iSheet=1
End Sub
'/***************************************************************************
'/* 初始化Adodb.Connection组件对象
'/*
'/***************************************************************************
Private Function InitConn()
On Error Resume Next
Dim ConnStr
If Not IsObject(s_Conn) Or IsNull(s_Conn) Then
If SourceFile="" Then
InitConn=False
Exit Function
Else
Set s_Conn=Server.CreateObject("ADODB.Connection")
ConnStr="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & SourceFile
s_Conn.Open ConnStr
If Err.Number<>0 Then
InitConn=False
Err.Clear
s_Conn=Null
Exit Function
End If
End If
End If
InitConn=True
End Function
End Class
%>