Here is some code that is written generically so you pass
the parameters to define what you want, but you can make it
specific to suit your needs:
'~~~~~~~~~~~~~~~
Sub ExportDelimitedText( _
pRecordsetName As String, _
pFilename As String, _
Optional pBooIncludeFieldnames As Boolean, _
Optional pBooDelimitFields As Boolean, _
Optional pFieldDeli As String)
'written by Crystal
'strive4peace2008 at yahoo dot com
'NEEDS reference to Microsoft DAO Library
'PARAMETERS
'pRecordsetName --> name of query or table;
' or SQL statement
'pFilename -- name of file to create
'pBooIncludeFieldnames
' -- TRUE if you want fieldnames at top
' default is False
'pBooDelimitFields
' -- TRUE for delimiter, FALSE for none
'pFieldDeli -- string to use as delimiter
' TAB will be used if nothing specified
'BASIC USEAGE
' ExportDelimitedText _
"QueryName", "c:\path\filename.csv"
'set up error handler
On Error GoTo Proc_Err
Dim mPathAndFile As String, mFileNumber As Integer
Dim r As dao.Recordset, mFieldNum As Integer
Dim mOutputString As String
Dim booDelimitFields As Boolean
Dim booIncludeFieldnames As Boolean
Dim mFieldDeli As String
booDelimitFields = Nz(pBooDelimitFields, False)
booIncludeFieldnames = Nz(pBooIncludeFieldnames, False)
'make the delimiter a TAB character unless specified
If Nz(pFieldDeli, "") = "" Then
mFieldDeli = Chr(9)
Else
mFieldDeli = pFieldDeli
End If
'if there is no path specfied,
' put file in current directory
If InStr(pFilename, "\") = 0 Then
mPathAndFile = CurrentProject.Path
Else
mPathAndFile = ""
End If
mPathAndFile = mPathAndFile & "\" & pFilename
'if there is no extension specified, add TXT
If InStr(pFilename, ".") = 0 Then
mPathAndFile = mPathAndFile & ".txt"
End If
'get a handle
mFileNumber = FreeFile
'close file handle if it is open
'ignore any error from trying to close it if it is not
On Error Resume Next
Close #mFileNumber
On Error GoTo Proc_Err
'delete the output file if already exists
If Dir(mPathAndFile) <> "" Then
Kill mPathAndFile
DoEvents
End If
'open file for output
Open mPathAndFile For Output As #mFileNumber
'open the recordset
Set r = CurrentDb.OpenRecordset(pRecordsetName)
'write fieldnames if specified
If booIncludeFieldnames Then
mOutputString = ""
For mFieldNum = 0 To r.Fields.Count - 1
If booDelimitFields Then
mOutputString = mOutputString & """" _
& r.Fields(mFieldNum) & """" _
& mFieldDeli
Else
mOutputString = mOutputString _
& r.Fields(mFieldNum).Name _
& mFieldDeli
End If
Next mFieldNum
'remove last delimiter
if pBooDelimitFields then
mOutputString = Left( _
mOutputString _
, Len(mOutputString) - Len(mFieldDeli) _
)
end if
'write a line to the file
Print #mFileNumber, mOutputString
End If
'loop through all records
Do While Not r.EOF()
'tell OS (Operating System) to pay attention to things
DoEvents
mOutputString = ""
For mFieldNum = 0 To r.Fields.Count - 1
If booDelimitFields Then
Select Case r.Fields(mFieldNum).Type
'string
Case 10, 12
mOutputString = mOutputString & """" _
& r.Fields(mFieldNum) & """" _
& mFieldDeli
'date
Case 8
mOutputString = mOutputString & "#" _
& r.Fields(mFieldNum) & "#" _
& mFieldDeli
'number
Case Else
mOutputString = mOutputString _
& r.Fields(mFieldNum) _
& mFieldDeli
End Select
Else
mOutputString = mOutputString _
& r.Fields(mFieldNum) _
& mFieldDeli
End If
Next mFieldNum
'remove last TAB
if booDelimitFields then _
mOutputString = Left( _
mOutputString _
, Len(mOutputString) - Len(mFieldDeli)_
)
'write a line to the file
Print #mFileNumber, mOutputString
'move to next record
r.MoveNext
Loop
MsgBox "Done Creating " & mPathAndFile, , "Done"
Proc_Exit:
on error resume next
'close the file
Close #mFileNumber
'close the recordset
r.Close
'release object variables
Set r = Nothing
Exit Sub
'ERROR HANDLER
Proc_Err:
MsgBox Err.Description _
, , "ERROR " & Err.Number _
& " ExportDelimitedText"
Resume Proc_Exit
'if you want to single-step code to find error,
CTRL-Break at MsgBox
'then set this to be the next statement
Resume
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~
once you get the code exporting what you want the way you
want it, you can use a scheduler to run it each day
Warm Regards,
Crystal
remote programming and training
http://MSAccessGurus.com
free video tutorials
http://www.YouTube.com/user/LearnAccessByCrystal
Access Basics
http://www.AccessMVP.com/strive4peace
free 100-page book that covers essentials in Access
*
have an awesome day
*
