引用方式: 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 //////////////////////////////////