Charlotte Foust
cfoust at infostatsystems.com
Tue Apr 11 11:25:29 CDT 2006
Oops! I suppose it would have helped if I had remembered to paste the
code in! LOL
Charlotte
'**** Code Begins **********
Public Function CreateTextFileFromRST(ByVal strOutputTblNm As String, _
ByVal strLinkSpec As String, _
ByRef rst As ADODB.Recordset, _
Optional blnOverwrite As Boolean = True, _
Optional blnFieldNames As Boolean = True)
As Boolean
'Author: Charlotte Foust
'Created: 7/3/2001
'modified 7/5/2001 - added code to write fieldnames to file
'Based on CreateTextFile by Charlotte Foust
'requires reference to Microsoft Scripting Library
'SCRRUN.DLL for early binding of FileSystemObject
'A reference to Microsoft Office 9.0 object library
'will work with late binding
'Creates tab delimited text file from table or query then links file.
'Used to replace temporary tables and reduce bloat.
On Error GoTo Proc_err
Dim varItem As Variant
Dim strOutputFile As String
Dim strTempTblNm As String
Dim intPosition As Integer 'holds result of instr() function
Dim varFields As Variant
Dim varLines As Variant
Dim intFldCount As Integer
Dim lngRecords As Long
Dim intLoop As Integer
Dim intIndex As Integer
Dim blnContinue As Boolean
Dim intCmdType As Integer 'holds commandtype constant
Dim fld As ADODB.Field 'holds each ADO field object
Dim cnn As ADODB.Connection 'holds ADO connection object
Dim errsCnn As ADODB.Errors 'holds ADO Errors collection
Dim errCurr As ADODB.Error 'holds each ADO error
Dim objFS As FileSystemObject 'holds FileSystemObject
Dim objTxtStream As TextStream 'holds TextStream object
'instantiate the objects
Set cnn = CurrentProject.Connection
Set errsCnn = cnn.Errors
'make sure the output file name has a txt extension
intPosition = InStr(strOutputTblNm, ".")
If intPosition = 0 Then
strTempTblNm = strOutputTblNm
strOutputTblNm = strOutputTblNm & ".txt"
Else 'intPosition = 0
strTempTblNm = Left(strOutputTblNm, intPosition - 1)
strOutputTblNm = Left(strOutputTblNm, intPosition) & "txt"
End If 'intPosition = 0
'create the full path and temp file name
'if only a filename was passed
If InStr(strOutputTblNm, "\") = 0 Then
strOutputFile = CurrentProject.path & "\" & strOutputTblNm
Else
strOutputFile = strOutputTblNm
End If 'InStr(strOutputTblNm, "\") = 0
'delete the old temp file
On Error Resume Next
Kill strOutputFile
On Error GoTo Proc_err
With rst
If .EOF Then
'there are no records to process
'so the routine will exit
lngRecords = 0
Else '.EOF
blnContinue = True
'get the recordcount
.MoveLast
lngRecords = .RecordCount
.MoveFirst
'set up the array to hold the
'field values
intFldCount = .Fields.Count
intLoop = 0
'dim the array depending on whether
'fieldnames are being included
If Not blnFieldNames Then
ReDim varLines(lngRecords - 1)
Else 'If Not blnFieldNames
ReDim varLines(lngRecords)
'create a "field names" record for the file
'put each field name into a string array
varFields = Null
Set fld = Nothing
For Each fld In .Fields
'add the field value to a semicolon
'delimited string of values
varFields = varFields & fld.name & ";"
Next fld
'strip off the last semicolon
varFields = Left(varFields, Len(varFields) - 1)
'convert the string to an array based
'on the semicolon delimiter.
varFields = Split(varFields, ";")
'turn the array into a tab delimited string
'and assign it to a single element of the line array
varLines(intLoop) = Join(varFields, Chr(9))
intLoop = intLoop + 1
End If 'Not blnFieldNames
'add the records to the array
Do
'put the data from each field into
'a string then put the string
'into an array
varFields = Null
Set fld = Nothing
For Each fld In .Fields
varItem = fld.Value
If Not IsNull(varItem) Then
'strip out any non-printing characters
'remove the vbNewLine/vbCr character chr(13)
If InStr(CStr(varItem), vbCr) > 0 Then
varItem = Replace(CStr(varItem), vbCr, ", ")
End If 'InStr(CStr(varItem), vbCr) > 0
'remove the vbLf character chr(10)
If InStr(CStr(varItem), vbLf) > 0 Then
varItem = Replace(CStr(varItem), vbLf, ", ")
End If 'InStr(CStr(varItem), vbLf) > 0
End If 'Not IsNull(varItem)
'add the field value to a semicolon
'delimited string of values
varFields = varFields & varItem & ";"
Next fld
'strip off the last semicolon
varFields = Left(varFields, Len(varFields) - 1)
'convert the string to an array based
'on the semicolon delimiter. This gets
'around fields than contain commas
varFields = Split(varFields, ";")
'turn the array into a tab delimited string
'and assign it to a single element of the line array
varLines(intLoop) = Join(varFields, Chr(9))
'go to the next record
intLoop = intLoop + 1
.MoveNext
Loop Until .EOF
End If '.EOF
End With 'rst
'clean up object variables
Set fld = Nothing
rst.Close
Set rst = Nothing
If blnContinue Then
'create a FileSystemObject
Set objFS = CreateObject("scripting.filesystemobject")
'create a TextStream Object to handle output
Set objTxtStream = objFS.CreateTextFile(strOutputFile, blnOverwrite)
'loop through the Lines array and
'write each line to the TextStream object
For intLoop = 0 To UBound(varLines)
objTxtStream.WriteLine varLines(intLoop)
Next intLoop
objTxtStream.Close
End If 'blnContinue
If lngRecords = 0 Then
MsgBox "There were no records to write to the specified file."
End If 'lngRecords = 0
Proc_exit:
On Error Resume Next
'clean up object variables
Set objTxtStream = Nothing
Set objFS = Nothing
Set fld = Nothing
rst.Close
Set rst = Nothing
Set errsCnn = Nothing
Set errCurr = Nothing
Set cnn = Nothing
CreateTextFileFromRST = blnContinue
Exit Function
Proc_err:
If errsCnn.Count > 0 Then
For Each errCurr In errsCnn
MsgBox errCurr.Number & "--" & errCurr.Description & vbCrLf _
& CurrentProject.name & ".CreateTextFile"
Next errCurr
errsCnn.Clear
End If
If Err <> 0 Then
MsgBox Err.Number & "--" & Err.Description
End If
blnContinue = False
Resume Proc_exit
End Function 'CreateTextFileFromRST(ByVal strOutputTblNm As String, _
ByVal strLinkSpec As String, _
ByRef rst As ADODB.Recordset, _
Optional blnOverwrite As Boolean = True)
As Boolean
'**** Code Ends **********
-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Charlotte
Foust
Sent: Tuesday, April 11, 2006 9:03 AM
To: Access Developers discussion and problem solving
Subject: Re: [AccessD] Exporting comma delimited data
John,
Here's an ancient bit from my early ADO days for creating a tab
delimited file with optional fieldnames. You can probably adapt it, but
don't expect it to be terribly elegant because it was written based on
ADO 2.1 and I was fumbling my way through it.
Charlotte Foust
-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of John Colby
Sent: Tuesday, April 11, 2006 8:22 AM
To: 'Access Developers discussion and problem solving'
Subject: [AccessD] Exporting comma delimited data
Does anyone have code for exporting an ADO recordset to comma delimited,
complete with header (if desired), quoting of data if the data contains
commas etc?
John W. Colby
www.ColbyConsulting.com