数据库备份转换为Excel文件类

数据库备份转换为Excel文件类2009-12-12死鱼注意:此版本的类暂时只支持一次转换一个数据表，即一个数据表只能对应一个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（"."）&"ack.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（"."）&"ack.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
%>