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 & ",
" & .Fields(iI).Value
End Select
End If
Next
iSql = "insert into [ " & sTableName & "]( " & _
Mid(iFdlist, 2) & ") values( " & Mid(iSql, 2) & ") "
iDB.Execute iSql
.MoveNext
Wend
End With
'处理完毕,关闭数据库
iDB.Close
Set iDB = Nothing
MsgBox "已经将数据保存到[ " & sExcelFileName & " ] ", 64
iRe = True
GoTo lbexit
lbErr:
MsgBox "发生错误: " & Err.Description & vbCrLf & _
"错误代码: " & Err.Number, 64, "错误"
lbexit:
f_Export2Excel = iRe
End Function。