（原创）备份数据库类 Excel篇(V2.0版)

关注

原创最新推荐文章于 2026-07-18 12:01:57 发布 1.7k 阅读 AI 写同款· GEO 优化 ›

DataEase v2.13.0 开源BI部署实战：Docker Compose 一键搭建，对接3类数据源本文详细介绍了如何使用Docker Compose一键部署DataEase v2.13.0开源BI工具，并演示如何对接MySQL、Excel和API三类数据源。通过实战案例，帮助用户快速构建数据可视化平台，提升企业数据分析效率，特别适合中小企业和技术团队使用。阅读详情

此版本比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
%>