by Gideon Cole (3 Submissions)
Category: Databases/Data Access/DAO/ADO
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Sun 11th July 1999
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
This code writes the contents of an ADO RecordSet to a ascii text file with user specified column & row delimiters. Simple but usefull.
VBcoders
'Revision History:
'
' 26/07/1999 GC - v1.00.0000 Initial Version.
'
'Notes: Writes a record set to a file in ascii text mode.
Option Explicit
Private iFileNumber As Integer
Private sFilePath As String
Private sDelimeter As String
Private sRowDelimeter As String
Private lErrorNumber As Long
Private sErrorDescription As String
Private sErrorPlace As String
Public Property Get GetErrorNumber() As Long
GetErrorNumber = lErrorNumber
End Property
Public Property Get GetErrorDescription() As String
GetErrorDescription = sErrorDescription
End Property
Public Property Get GetErrorPlace() As String
GetErrorPlace = sErrorPlace
End Property
Public Property Let FilePath(ByVal inFilePath As String)
sFilePath = inFilePath
End Property
Public Property Get GetFilePath() As String
GetFilePath = sFilePath
End Property
Public Property Let Delimeter(ByVal inDelimeter As String)
sDelimeter = inDelimeter
End Property
Public Property Get GetDelimeter() As String
GetDelimeter = sDelimeter
End Property
Public Property Let RowDelimeter(ByVal inRowDelimeter As String)
sRowDelimeter = inRowDelimeter
End Property
Public Property Get GetRowDelimeter() As String
GetRowDelimeter = sRowDelimeter
End Property
Public Function Write2File(Optional ByRef inRecordSet As ADODB.Recordset, _
Optional ByRef inFilePath As String, _
Optional ByRef inDelimeter As String, _
Optional ByRef inRowDelimeter As String, _
Optional ByRef inAppend As Boolean, _
Optional ByRef inHeaderRecord As String) As Long
On Error GoTo ErrorHandler
'Default: Delimeter is ","
' RowDelimeter is VBCrLF
Dim sTempRecord As String
Dim dRecords As Double
Dim dIndex As Double
Dim iCol As Integer
Dim iMaxCols As Integer
'Check if anything to do
If (IsEmpty(inRecordSet)) Then
Exit Function
Else
If (inRecordSet.RecordCount = 0) Then
Exit Function
Else
dRecords = inRecordSet.RecordCount
End If
End If
'File Path
If (Len(inFilePath) > 0) Then
sFilePath = inFilePath
Else
If (Len(sFilePath) < 1) Then
Exit Function
End If
End If
'Set up the Column Delimeter
If (Len(inDelimeter) > 0) Then
sDelimeter = inDelimeter
Else
If (Len(sDelimeter) < 1) Then
sDelimeter = ","
End If
End If
'Set up the Row Delimeter
If (Len(inRowDelimeter) > 0) Then
sRowDelimeter = inRowDelimeter
Else
If (Len(sRowDelimeter) < 1) Then
sRowDelimeter = vbCrLf
End If
End If
Call OpenFile(inAppend)
If (Len(inHeaderRecord) > 0) Then
Print #iFileNumber, inHeaderRecord
End If
iMaxCols = inRecordSet.Fields.Count - 1
inRecordSet.MoveFirst
'This if statement is to accomodate a bug in .movenext
'where the record set only contains one record...
If (dRecords = 1) Then
sTempRecord = inRecordSet.Fields(0).Value
For iCol = 1 To iMaxCols
sTempRecord = sTempRecord & sDelimeter & inRecordSet.Fields(iCol).Value
Next iCol
Print #iFileNumber, sTempRecord
Else
While dIndex < dRecords
sTempRecord = inRecordSet.Fields(0).Value
For iCol = 1 To iMaxCols
sTempRecord = sTempRecord & sDelimeter & inRecordSet.Fields(iCol).Value
Next iCol
Print #iFileNumber, sTempRecord
dIndex = dIndex + 1
inRecordSet.MoveNext
Wend
End If
CloseFile
DoEvents
Exit Function
ErrorHandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "OpenInterfaceFile()"
End Function
Private Sub OpenFile(ByRef inAppend As Boolean)
On Error GoTo ErrorHandler
iFileNumber = FreeFile
If (inAppend) Then
'Check if Error file already exists
If (Dir(sFilePath) = "") Then
Open sFilePath For Output As #iFileNumber
Else
Open sFilePath For Append As #iFileNumber
End If
Else
Open sFilePath For Output As #iFileNumber
End If
Exit Sub
ErrorHandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "OpenLogFile()"
End Sub
Private Sub CloseFile()
On Error GoTo ErrorHandler
Close #iFileNumber
Exit Sub
ErrorHandler:
lErrorNumber = Err.Number
sErrorDescription = Err.Description
sErrorPlace = "CloseInterfaceFile()"
End Sub
No comments have been posted about This code writes the contents of an ADO RecordSet to a ascii text file with user specified column &. Why not be the first to post a comment about This code writes the contents of an ADO RecordSet to a ascii text file with user specified column &.
