网页上数据导出到EXCEL

王朝other·作者佚名  2006-01-08
窄屏简体版  字體: |||超大  

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

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
 
 
© 2005- 王朝網路 版權所有  導航