You could use this code:
It uses the array function ArrayTranspose, which you can download from
Alan Beban's website:
http://home.pacbell.net/beban/
Function RecordSetToText(ByRef rs As ADODB.Recordset, _
ByVal txtFile As String, _
ByVal doFields As Boolean, _
Optional ByRef fldArray As Variant) As Boolean
'makes a comma delimited text file from an ADO recordset
'optionally puts the field names in the first row
'if the fldArray is supplied this will be used for the
'fields, if not it will be taken from the field names of
'the recordset
'returns true if successfull
'-------------------------------------------------------
Dim tempArray()
Dim LC As Byte
Dim LR As Long
On Error GoTo NORECORDS
tempArray = rs.GetRows
tempArray = ArrayTranspose(tempArray)
LC = UBound(tempArray, 2)
LR = UBound(tempArray, 1)
If doFields = True Then
If IsMissing(fldArray) Then
SaveArrayToText2 txtFile, _
tempArray, _
0, _
LR, _
0, _
LC, _
fieldArrayFromRS(rs)
Else
SaveArrayToText2 txtFile, _
tempArray, _
0, _
LR, _
0, _
LC, _
fldArray
End If
Else
SaveArrayToText2 txtFile, _
tempArray, _
0, _
LR, _
0, _
LC
End If
rs.Close
Set rs = Nothing
RecordSetToText = True
Exit Function
NORECORDS:
If Not rs Is Nothing Then
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
RecordSetToText = False
End Function
Sub SaveArrayToText2(ByVal txtFile As String, _
ByRef arr As Variant, _
Optional ByVal LBRow As Long = -1, _
Optional ByVal UBRow As Long = -1, _
Optional ByVal LBCol As Long = -1, _
Optional ByVal UBCol As Long = -1, _
Optional ByRef fieldArr As Variant)
'this one organises the text file like
'a table by inserting the right line breaks
'------------------------------------------
Dim R As Long
Dim c As Long
Dim hFile As Long
If LBRow = -1 Then
LBRow = LBound(arr, 1)
End If
If UBRow = -1 Then
UBRow = UBound(arr, 1)
End If
If LBCol = -1 Then
LBCol = LBound(arr, 2)
End If
If UBCol = -1 Then
UBCol = UBound(arr, 2)
End If
hFile = FreeFile
Open txtFile For Output As hFile
If IsMissing(fieldArr) Then
For R = LBRow To UBRow
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, arr(R, c)
Else
Write #hFile, arr(R, c);
End If
Next
Next
Else
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, fieldArr(c)
Else
Write #hFile, fieldArr(c);
End If
Next
For R = LBRow To UBRow
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, arr(R, c)
Else
Write #hFile, arr(R, c);
End If
Next
Next
End If
Close #hFile
End Sub
RBS
