【原创 / 源码】导出窗体Recordset为任意Access支持格式的数据文件

LucasLynn

以下代码将DAO的RecordSet（包括Access窗体的Recordset）中的当前数据导出为任何Access支持的导出格式。无论你这个Recordset是从窗体的，还是代码创建的，是筛选后结果，还是链接了字段的主窗体，本程序均能正确导出结果，格式包括任何Access支持的导出格式。

备注：数据类型转换的部分可能还会有些小问题，如果有谁使用中发现导出后数据格式错误请告诉我，便于我改进。

（2006年5月13日修改，增加了取消导出的异常处理）

'调用范例

Private Sub Botton_Click()
    Call Output_Recordset(Me.Recordset)
End Sub

<DIV class=quote>


'公共模块

Option Compare Database
Option Explicit

Public Sub Output_Recordset(ByRef frmRs As DAO.Recordset)
    Dim frmField As DAO.Field
    Dim daoDbs As DAO.Database
    Dim daoRs As DAO.Recordset

    Dim strSQL As String
    Dim strFields As String
   
    Set daoDbs = Application.CurrentDb
    Set daoRs = frmRs.Clone
   
    strSQL = "CREATE TABLE USysDAORecordsetOutport"
    strFields = "("
   
    For Each frmField In daoRs.Fields
        strFields = strFields & frmField.Name & " "
        Select Case frmField.Type
            Case dbBigInt:
                strFields = strFields & "Currency"
            Case dbBinary:
                strFields = strFields & "Binary"
            Case dbBoolean:
                strFields = strFields & "Bit"
            Case dbByte:
                strFields = strFields & "TinyInt"
            Case dbChar:
                strFields = strFields & "Char"
            Case dbCurrency:
                strFields = strFields & "Money"
            Case dbDate:
                strFields = strFields & "DateTime"
            Case dbDecimal:
                strFields = strFields & "Decimal"
            Case dbDouble:
                strFields = strFields & "Double"
            Case dbFloat:
                strFields = strFields & "Float"
            Case dbGUID:
                strFields = strFields & "Guid"
            Case dbInteger:
                strFields = strFields & "Integer"
            Case dbLong:
                strFields = strFields & "Long"
            Case dbLongBinary:
                strFields = strFields & "LongBinary"
            Case dbMemo :
                strFields = strFields & "Memo"
            Case dbNumeric:
                strFields = strFields & "Numeric"
            Case dbSingle:
                strFields = strFields & "Single"
            Case dbText:
                strFields = strFields & "Text(" & frmField.Size & ")"
            Case dbTime:
                strFields = strFields & "Time"
            Case dbTimeStamp:
                strFields = strFields & "DateTime"
            Case dbVarBinary:
                strFields = strFields & "VarBinary"
        End Select
        
        strFields = strFields & ","
    Next frmField
    strFields = Left(strFields, Len(strFields) - 1) & ")"
   
    On Error Resume Next
        daoDbs.Execute "DROP TABLE USysDAORecordsetOutport"
    On Error GoTo 0
    daoDbs.Execute strSQL & strFields
   
    daoRs.MoveFirst

    Do Until daoRs.EOF
        strSQL = "INSERT INTO USysDAORecordsetOutport("
        strFields = " Values("
        For Each frmField In daoRs.Fields
            If Not IsNull(frmField.Value) And Not IsEmpty(frmField.Value) Then
                strSQL = strSQL & frmField.Name & ","
                If frmField.Type = dbText Then
                    strFields = strFields & "'" & frmField.Value & "',"
                Else
                    strFields = strFields & frmField.Value & ","
                End If
            End If
        Next frmField
      

chaojianan

谢谢，收藏了。

sunwrsun

西湖渔夫

公共模块代码不全，怎么办？

5988143

原帖由 zouwen 于 2006-9-17 16:02 发表
当记录有 '   / 字符号时 导出会出错

是的,好像定義為時間類型時會出錯,請作者再跟進哈!

maple99

很不错的代码! 多学习

zouwen

当记录有 '   / 字符号时 导出会出错

zouwen

我在导出 有十几个字段,记录有1万-40万条 时会出错 处理几条记录不会出错

运行是错误'3075'

语法错误(操作符丢失)在'2005-7-19 9:03:31'

进入调试后

Do Until daoRs.EOF
        strSQL = "INSERT INTO USysDAORecordsetOutport("
        strFields = " Values("
        For Each frmField In daoRs.Fields
            If Not IsNull(frmField.Value) And Not IsEmpty(frmField.Value) Then
                strSQL = strSQL & frmField.Name & ","
                If frmField.Type = dbText Then
                    strFields = strFields & "'" & frmField.Value & "',"
                Else
                    strFields = strFields & frmField.Value & ","
                End If
            End If
        Next frmField
        strSQL = Left(strSQL, Len(strSQL) - 1) & ")"
        strFields = Left(strFields, Len(strFields) - 1) & ")"


        daoDbs.Execute strSQL & strFields     这一行是黄色

        daoRs.MoveNext
    Loop
   
    On Error Resume Next
        DoCmd.OutputTo acOutputTable, "USysDAORecordsetOutport"
    On Error GoTo 0
        
    daoDbs.Execute "DROP TABLE USysDAORecordsetOutport"

End Sub

videochat

厉害啊，啥时候偶能写出来啊

谢谢

aone

以前导出子窗体筛选记录的时候总是需要在多做一个过渡查询！好帖！谢谢分享，学习中！