網頁上數據導出到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 //////////////////////////////////