<%
Class DataBaseToExcel
'/***************************************************************************
'/* 转移数据到Excel文件(备份数据库类 Excel篇) V1.0
'/*作者:死在水中的鱼(死鱼)
'/*日期:2004年8月4日
'/*Blog:http://blog.csdn.net/bpfish
'/*
'/*声明:使用此类必需服务器上装有Office(Excel)程序,否则使用时可能不能转移数据
'/* 此版本的类暂时只支持一次转换一个数据表,即一个数据表只能对应一个Excel文件。
'/* 如果转换一个数据表后不更换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的“字段列表”,“查询条件”格式相同
'/* "字段列表"为空则是所有字段,“查询条件”为空则获取所有数据
'/***************************************************************************
Private s_Conn
Private objExcelApp,objExcelSheet,objExcelBook
Private sChar,EndChar
'/***************************************************************************
'/* 全局变量
'/*外部直接使用:[Obj].SourceFile=源文件名 [Obj].TargetFile=目标文件名
'/***************************************************************************
Public SourceFile,TargetFile
Private Sub Class_Initialize
sChar="ABCDEFGHIJKLNMOPQRSTUVWXYZ"
objExcelApp=Null
s_Conn=Null
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)到ACCESS数据库的数据转移而设置的
'/***************************************************************************
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
'/***************************************************************************
'/* 数据转移
'/*函数功能:转移源数据到TargetFile数据库文件
'/*函数说明:利用SQL语句的Select Into In方法转移
'/*函数返回:返回一些状态代码True = 转移数据成功 False = 转移数据失败
'/*函数参数:sTableName = 源数据库的表名
'/* sCol = 要转移数据的字段列表,格式则同Select 的字段列表格式相同
'/* sSql = 转移数据时的条件 同SQL语句的Where 后面语句格式一样
'/***************************************************************************
Public Function Transfer(sTableName,sCol,sSql)
On Error Resume Next
Dim SQL,Rs
Dim iFieldsCount,iMod,iiMod,iCount,i
If TargetFile="" Then '没有目标保存文件,转移失败
Transfer=False
Exit Function
End If
If Not InitConn Then '如果不能初始化Conn对象则转移数据出错
Transfer=False
Exit Function
End If
If Not InitExcel Then '如果不能初始化Excel对象则转移数据出错
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
CloseExcel
Exit Function
End If
iFieldsCount=Rs.Fields.Count
'没字段和没有记录则退出
If iFieldsCount<1 Or Rs.Eof Then
Transfer=False
Set Rs=Nothing
CloseExcel
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
CloseExcel
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
CloseExcel
Exit Function
End If
'保存文件
objExcelBook.SaveAs TargetFile
If Err.Number<>0 Then '出错则转移数据错误,否则转移数据成功
Err.Clear
Transfer=False
Rs.Close
Set Rs=Nothing
CloseExcel
Exit Function
End If
Rs.Close
Set Rs=Nothing
CloseExcel
Transfer=True
End Function
'/***************************************************************************
'/* 初始化Excel组件对象
'/*
'/***************************************************************************
Private Function InitExcel()
On Error Resume Next
If Not IsObject(objExcelApp) Or IsNull(objExcelApp) Then
Set objExcelApp=Server.CreateObject("Excel.Application")
objExcelApp.DisplayAlerts = False
objExcelApp.Application.Visible = False
objExcelApp.WorkBooks.add
Set objExcelBook=objExcelApp.ActiveWorkBook
set objExcelSheet = objExcelBook.Sheets(1)
If Err.Number<>0 Then
CloseExcel
InitExcel=False
Err.Clear
Exit Function
End If
End If
InitExcel=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
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
%>