|
注意:此版本的类暂时只支持一次转换一个数据表，即一个数据表只能对应一个Excel文件。如果转换一个数据表后不更换TargetFile参数，则将覆盖以前的表数据！！！！
使用方法请仔细阅读下面的注解说明!!
<%
Class DataBaseToExcel
''/***************************************************************************
''/* 转移数据到Excel文件(备份数据库类 Excel篇） V1.0
''/*作者：死在水中的鱼(死鱼）
''/*日期：2004年8月4日
''/*Blog:http://blog.lznews.cn/blog.asp?name=哇哇鱼
''/*
''/*声明：使用此类必需服务器上装有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
%>
（编辑：济南站长网）
【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!
|
