备份数据库类 Excel篇(V1.0版)-优快云博客

<%
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
%>