从VB将数据导出到EXCEL(不需要安装EXCEL)

'从VB将数据导出到EXCEL,网上可能有很多这样的代码,但是前提都要安装EXCEL,今天我分享给大家的就是没有安装EXCEL的一样也可以导出.
'Rem 作者:谢炎锦  创建时间:2002-12-20   Mail:XieYanJin@163.Com
'Rem 内容如下:
'Rem 引用方式: Export(Ado.Recordset) 或 Export(Rds.RecordSet)
'Rem 支持 Rds 与 Ado 的记录导出
'Rem 得到所有数据类型,有些数据类型EXCEL不支持,已经替换掉

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

转载于:https://www.cnblogs.com/Spacecup/p/3642891.html