网页上数据导出到EXCEL

引用方式: Export(Ado.Recordset) 或 Export(Rds.RecordSet)

/// S T A R T //

Function FieldType(intType)
   Select Case intType
      Case 20
         FieldType = "int"
      Case 128
         FieldType = "binary"
      Case 11
         FieldType = "bit"
      Case 129
         FieldType = "char"
      Case 135
         FieldType = "datetime"
      Case 131
         FieldType = "varchar"
      Case 5
         FieldType = "float"
      Case 205
         FieldType = "image"
      Case 3
         FieldType = "int"
      Case 6
         FieldType = "money"
      Case 130
         FieldType = "char"
      Case 203
         FieldType = "text"
      Case 131
         FieldType = "numeric"
      Case 202
         FieldType = "varchar"
      Case 4
         FieldType = "real"
      Case 135
         FieldType = "datetime"
      Case 2
         FieldType = "int"
      Case 6
         FieldType = "money"
      Case 204
         FieldType = "varchar"
      Case 201
         FieldType = "text"
      Case 128
         FieldType = "timestamp"
      Case 17
         FieldType = "varchar"
      Case 72
         FieldType = "varchar"
      Case 204
         FieldType = "varbinary"
      Case 200
         FieldType = "varchar"
    End Select
End Function

Sub Export(AdoRecordSet)
Rem AdoRecordSet 传入一个对象,可以是 Rds.Recordset 或者是 Adodb.RecordSet
Rem 导出到用户桌面的  Query_数字组合.xls
On Error Resume Next
    Dim Excel_Dsn
    Dim Excel_Conn
    Dim Excel_Adodc
    Dim mySql, fs
    Dim i, j, TmpField, FileName, WshShell
    Rem 桌面路径
    Set WshShell = CreateObject("Wscript.Shell")
    Rem 创建一个连接
    Set Excel_Conn = CreateObject("ADODB.Connection")
    Rem 创建一条记录
    Set Excel_Adodc = CreateObject("ADODB.RecordSet")
    Rem 创建文件对象
    Set fs = CreateObject("Scripting.FileSystemObject")
    Rem 判断文件是否存在, 自动更名 (0 - 99), 可以修改
    For i = 0 To 99
        If Len(i) = 1 Then
            FileName = WshShell.SpecialFolders("Desktop") & "/Query_0" & i
        Else
            FileName = WshShell.SpecialFolders("Desktop") & "/Query_" & i
        End If
        If Not fs.FileExists(FileName & ".xls") Then
            Exit For
        End If
    Next
    FileName = FileName & ".xls"
    Rem 创建Excel驱动,一般 Window 98 以上的电脑都有这个驱动
    Excel_Dsn = "DRIVER={Microsoft Excel Driver (*.xls)};DSN='';FIRSTROWHASNAMES=1;READONLY=FALSE;CREATE_DB=""" & FileName & """;DBQ=" & FileName
    Excel_Conn.Open Excel_Dsn
    With AdoRecordSet
        If Not (.EOF And .BOF) Then
   .MoveFirst
            mySql = "Create Table [Query] ("
            For i = 0 To .Fields.Count - 1
                TmpField = FieldType(.Fields(i).Type)
                If TmpField = "char" Or TmpField = "varchar" Or TmpField = "nchar" Or TmpField = "nvarchar" Or TmpField = "varbinary" Then
                    If .Fields(i).DefinedSize >= 256 Then
                        mySql = mySql & Trim(.Fields(i).Name) & " text,"
                    Else
                        mySql = mySql & Trim(.Fields(i).Name) & " " & FieldType(.Fields(i).Type) & "(" & .Fields(i).DefinedSize & ")" & ","
                    End If
                Rem Image 的数据类型不导出
                ElseIf TmpField <> "image" Then
                    mySql = mySql & Trim(.Fields(i).Name) & " " & FieldType(.Fields(i).Type) & ","
                End If
            Next
            mySql = Left(Trim(mySql), Len(Trim(mySql)) - 1)
            mySql = mySql & ")"
            Rem 创建表名
            Rem 这个不能使用 Excel_Adodc.Close,因为等待这句执行完,对象会自动关闭,不会给服务器造成负担
            Excel_Adodc.Open mySql, Excel_Dsn
            Rem 捕捉错误信息
            If Err.number <> 0 Then
  MsgBox "发生错误：" & Err.Description, 64, "系统信息："
  Exit Sub
            End If
            Rem 插入数据
            For i = 0 To .RecordCount - 1
                mySql = "Insert into [Query] Values("
                For j = 0 To .Fields.Count - 1
                    TmpField = FieldType(.Fields(j).Type)
                    Rem Image 的数据类型不导出
                    If TmpField <> "image" Then
   if ISNULL(.Fields(j).Value) then
                         mySql = mySql & "NULL,"
   else
                         mySql = mySql & "'" & Trim(.Fields(j).Value) & "',"
   end if
                    End If
                Next
                mySql = Left(Trim(mySql), Len(Trim(mySql)) - 1)
                mySql = mySql & ")"
                Rem 这个不能使用 Excel_Adodc.Close,因为等待这句执行完,对象会自动关闭,不会给服务器造成负担
                Excel_Adodc.Open mySql, Excel_Dsn
                Rem 捕捉错误信息
                If Err.number <> 0 Then
   MsgBox "发生错误：" & Err.Description, 64, "系统信息："
   Exit Sub
                End If
                .MoveNext
            Next
            MsgBox "系统提示：" & Chr(13) & "已经将文件保存到 """ & FileName & """ ]", 64, "系统信息："
        End If
        Rem 关闭与释放对象
        Excel_Conn.Close
        Set Excel_Conn = Nothing
        Set Excel_Adodc = Nothing
    End With
End Sub

// E N D   I F //