VB将数据导出到EXCEL

'************************************************************************* '**

'** VB将数据导出到EXCEL,没有安装EXCEL的一样也可以导出.

'**

'** 调用方式: s_Export2Excel(Ado.Recordset) 或s_Export2Excel(Rds.RecordSet) '** 支持Rds 与Ado 的记录导出

'**

'*************************************************************************

'得到所有数据类型,有些数据类型EXCEL不支持,已经替换掉

Public Function f_FieldType$(ByVal sType&)

Dim iRe$

Select Case sType

Case 2, 3, 20

iRe = "int "

Case 5

iRe = "float "

Case 6

iRe = "money "

Case 131

iRe = "numeric "

Case 4

iRe = "real "

Case 128

iRe = "binary "

Case 204

iRe = "varbinary "

Case 11

iRe = "bit "

Case 129, 130

iRe = "char "

Case 17, 72, 131, 200, 202, 204

iRe = "varchar "

Case 201, 203

iRe = "text "

Case 7, 135

iRe = "datetime "

Case 205

iRe = "image "

Case 128

iRe = "timestamp "

End Select

f_FieldType = iRe

End Function

'导出ADO记录集到EXCEL

Public Function f_Export2Excel(ByVal sRecordSet As ADODB.Recordset, ByVal sExcelFileName$ _

, Optional ByVal sTableName$, Optional ByVal sOverExist As Boolean = False) As Boolean

'On Error GoTo lbErr

Dim iConcStr, iSql$, iFdlist$, iDB As ADODB.Connection

Dim iI&, iFdType$, j, TmpField, FileName

Dim iRe As Boolean

'检查文件名

If Dir(sExcelFileName) <> " " Then

If sOverExist Then

Kill sExcelFileName

Else

iRe = False

GoTo lbexit

End If

End If

'生成创建表的SQL语句

With sRecordSet

For iI = 0 To .Fields.Count - 1

iFdType = f_FieldType(.Fields(iI).Type)

Select Case iFdType

Case "char ", "varchar ", "nchar ", "nvarchar ", "varbinary "

If .Fields(iI).DefinedSize > 255 Then

iSql = iSql & ",[ " & .Fields(iI).Name & "] text "

Else

iSql = iSql & ",[ " & .Fields(iI).Name & "] " & iFdType & _

"( " & .Fields(iI).DefinedSize & ") "

End If

Case "image "

Case Else

iSql = iSql & ",[ " & .Fields(iI).Name & "] " & iFdType

End Select

Next

If sTableName = " " Then sTableName = .Source

iSql = "create table [ " & sTableName & "]( " & Mid(iSql,

2) & ") "

End With

'数据库连接字符串

iConcStr = "DRIVER={Microsoft Excel Driver (*.xls)};DSN= ' ';FIRSTROWHASNAMES=1;READONL Y=FALSE; " & _

"CREATE_DB= " " " & sExcelFileName & " " ";DBQ= " & sExcelFileName

'创建Excel文件,并创建表

Set iDB = New ADODB.Connection

iDB.Open iConcStr

iDB.Execute iSql

'插入数据

With sRecordSet

.MoveFirst

While .EOF = False

iSql = " "

iFdlist = " "

For iI = 0 To .Fields.Count - 1

iFdType = f_FieldType(.Fields(iI).Type)

If iFdType <> "image " And IsNull(.Fields(iI).Value) = False Then

iFdlist = iFdlist & ",[ " & .Fields(iI).Name & "] "

Select Case iFdType

Case "char ", "varchar ", "nchar ", "nvarchar ", "text "

iSql = iSql & ", ' " & .Fields(iI).Value & " ' "

Case "datetime "

iSql = iSql & ",# " & .Fields(iI).Value & "# "

Case "image "

Case Else

iSql = iSql & ",