Make CSV File from a Query using VBA?

[Guest]

Looking for sample code.

TIA - Bob

 

[John Vinson]

Looking for sample code.

TIA - Bob

Open the VBA editor (Ctrl-G); press F1; search for "TransferText";
click on Example.

John W. Vinson[MVP]

 

[strive4peace]

Hi Bob,

this code creates a TAB delimited file unless otherwise specified ...

'~~~~~~~~~~~~~~~
Sub ExportDelimitedText( _
pRecordsetName As String, _
pFilename As String, _
Optional pBooIncludeFieldnames As Boolean, _
Optional pBooDelimitFields As Boolean, _
Optional pFieldDeli As String)

'written by Crystal
'strive4peace2006 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 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"
'press F8 to step through code and correct problem
'comment next line after debugged
Stop : Resume
Resume Proc_Exit
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~

Warm Regards,
Crystal
*
have an awesome day
*
MVP Access
Remote Programming and Training
strive4peace2006 at yahoo.com
*