VB export to excel without office

Public 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
Public Sub ExportToExcel(AdoRecordSet As ADODB.Recordset)
On Error GoTo Excel_Err
Dim Excel_Dsn As String
Dim Excel_Conn As New ADODB.Connection
Dim Excel_Adodc As New ADODB.Recordset
Dim mySql As String
Dim i, j, TmpField, FileName
Rem 得到文件名
For i = 0 To 100
If Len(i) = 1 Then
FileName = "C:\Query_0" & i
Else
FileName = "C:\Query_" & i
End If
If Dir(FileName & ".xls", vbHidden) = "" Then
Exit For
End If
Next
FileName = FileName & ".xls"
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
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
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 创建表名
Excel_Adodc.Open mySql, Excel_Dsn, adOpenDynamic, adLockPessimistic
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 & "'" & .Fields(j).Value & "',"
End If
End If
Next
mySql = Left(Trim(mySql), Len(Trim(mySql)) - 1)
mySql = mySql & ")"
Excel_Adodc.Open mySql, Excel_Dsn, adOpenDynamic, adLockPessimistic
.MoveNext
Next
MsgBox "系统提示:" & Chr(13) & " 已经将文件保存到 [ " & FileName & " ]", 64, "系统信息:"
End If
End With
Excel_Conn.Close
Set Excel_Conn = Nothing
Set Excel_Adodc = Nothing
Exit Sub
Excel_Err:
MsgBox "发生错误:" & Err.Description & Chr(13) & "错误代码:" & Err.Number, 64, "系统信息:"End Sub