VBA/Excel/Access/Word/Access/Recordset Save

Copy Records to a Text File

 
Sub WriteToFile()
   Dim conn As ADODB.Connection
   Dim myRecordset As ADODB.Recordset
   Dim f As ADODB.Field
   Dim myFileSystemObject As Object
   Dim txtfile As Object
   Set conn = New ADODB.Connection
   conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & CurrentProject.Path & "\mydb.mdb"
   Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
   Set txtfile = myFileSystemObject.CreateTextFile("c:\testfile.txt", True)
   Set myRecordset = New ADODB.Recordset
   myRecordset.Open "[Order Details]", conn
   With myRecordset
      For Each f In .Fields
         txtfile.Write (f.Name)
         txtfile.Write Chr(9)
      Next
      txtfile.WriteLine
      txtfile.Write myRecordset.GetString(adClipString)
      .Close
   End With
   txtfile.Close
   Set myRecordset = Nothing
   conn.Close
   Set conn = Nothing
End Sub

Saving Records to a Disk File

 
Sub SaveRecordsToDisk()
    Dim conn As ADODB.Connection
    Dim myRecordset As ADODB.Recordset
    Dim strFileName As String
    Dim strNorthPath As String
    strFileName = CurrentProject.Path & "\Companies.rst"
    strNorthPath = CurrentProject.Path & "\mydb.mdb"
     On Error GoTo ErrorHandle
     Set conn = New ADODB.Connection
     With conn
          .Provider = "Microsoft.Jet.OLEDB.4.0"
          .ConnectionString = "Data Source = " & strNorthPath
          .Mode = adModeReadWrite
          .Open
      End With
     Set myRecordset = New ADODB.Recordset
     With myRecordset
        .CursorLocation = adUseClient
        .Open "Customers", conn, adOpenKeyset, adLockBatchOptimistic, adCmdTable
        .ActiveConnection = Nothing
        .Save strFileName, adPersistADTG
        .Close
      End With
      Debug.Print "Records were saved in " & strFileName & "."
ExitHere:
    Set myRecordset = Nothing
    Exit Sub
ErrorHandle:
    If Not IsEmpty(Dir(strFileName)) Then
      Kill strFileName
      Resume
    Else
      MsgBox Err.Number & ": " & Err.Description
      Resume ExitHere
    End If
End Sub