|
Hi,
I have copied 2 functions below that will export the contents of the report control into a file. The functions create a TAB delimited file If you want a CSV file, simply change the TAB delimiter to a comma and the filename extension to csv instead of txt.
To use the function, simply execute the line below
Call ExportRecords(ReportControl, False)
The second parameter is for exporting selecting rows or all rows.
You will also need a reference to the Microsoft Scripting Runtime library to create the file. You can change this to use VB intrinsic file functions of course.
Public Function ExportRecords(ByRef rptControl As XtremeReportControl.ReportControl, Optional ByVal bolUseSelectedRows As Boolean = False) As Boolean
Dim Row As ReportRow
Dim Col As ReportColumn
Dim Columns As ReportColumns
Dim Rows As ReportRows
Dim lngCols As Long
Dim Cols() As Long
Dim strItemLine As String
Dim strColumnHeaders As String
Dim strBuffer As String
Dim strFileName As String
Dim objStream As TextStream
Dim objFS As FileSystemObject
On Error GoTo ErrHandler
'A reference to a Common Dialog control on your Form
'Get the file to export to from user
With dlgCommonDialog
.CancelError = False
.DialogTitle = "Save as..."
.FileName = "Exported data.txt"
.Filter = "Exported data|*.txt"
.FilterIndex = 1
.flags = cdlOFNNoReadOnlyReturn Or cdlOFNHideReadOnly
.InitDir = App.Path
.ShowSave
strFileName = .FileName
End With
If LenB(strFileName) > 0 Then
Set objFS = New FileSystemObject
Set objStream = objFS.OpenTextFile(strFileName, ForWriting, True)
strColumnHeaders = ""
Set Columns = rptControl.Columns
lngCols = 0
'Create an array of the column order indexes as they may have changed by user
For Each Col In Columns
If Col.Visible Then 'I am interested in visible columns only
If lngCols > 0 Then strColumnHeaders = strColumnHeaders & vbTab
strColumnHeaders = strColumnHeaders & Col.Caption
ReDim Preserve Cols(lngCols)
Cols(lngCols) = Col.ItemIndex 'Get the order of the column indexes
lngCols = lngCols + 1
End If
Next Col
objStream.WriteLine strColumnHeaders
If bolUseSelectedRows Then
For Each Row In rptControl.SelectedRows
strItemLine = GetExportRecord(Columns, Row, Cols, True, False)
If LenB(strItemLine) > 0 Then
objStream.WriteLine strItemLine
End If
Next Row
Else
For Each Row In rptControl.Rows
strItemLine = GetExportRecord(Columns, Row, Cols, True, False)
If LenB(strItemLine) > 0 Then
objStream.WriteLine strItemLine
End If
Next Row
End If
objStream.Close
ExportRecords = True
End If 'LenB(strFileName)
Exit_Proc:
Set objStream = Nothing
Set objFS = Nothing
Set Row = Nothing
Set Col = Nothing
Set Columns = Nothing
Set Rows = Nothing
Exit Function
ErrHandler:
'Error handling here
Resume Exit_Proc:
End Function
'GetExportRecord
Private Function GetExportRecord(ByRef Columns As ReportColumns, ByRef Row As ReportRow, ByRef Cols() As Long, Optional ByVal bolOnlyVisibleRecords = True, Optional ByVal bolUseDoubleQuoteData As Boolean = False) As String
Dim Col As ReportColumn
Dim Item As ReportRecordItem
Dim i As Long, j As Long, k As Long
Dim lngCols As Long
Dim strItem As String
Dim bolContinue As Boolean
'Test the Col array to ensure you have columns to traverse
On Error Resume Next
lngCols = UBound(Cols)
If Err.Number = 0 Then
On Error GoTo ErrHandler
GetExportRecord = ""
If Not Row.GroupRow Then
If bolOnlyVisibleRecords Then
bolContinue = Row.Record.Visible
Else
bolContinue = True
End If
If bolContinue Then
For i = 0 To lngCols
strItem = ""
Set Col = Columns.Find(Cols(i))
If Col.Visible Then
Set Item = Row.Record.Item(Cols(i))
If Item.HasCheckbox Then
strItem = IIf(Item.Checked, "TRUE", "FALSE")
Else
If Col.EditOptions.ConstraintEdit Then
k = Col.EditOptions.Constraints.Count - 1
For j = 0 To k
If Col.EditOptions.Constraints(j).Data = Item.value Then
strItem = Col.EditOptions.Constraints(j).Caption
Exit For
End If
Next j
Else
strItem = Item.value
End If 'ConstraintEdit
End If 'HasCheckbox
If LenB(GetExportRecord) > 0 Then GetExportRecord = GetExportRecord & vbTab
If bolUseDoubleQuoteData Then strItem = """" & strItem & """"
'Replace carriage return line feed characters with a space
GetExportRecord = GetExportRecord & Replace(strItem, vbCrLf, " ")
End If 'Col.Visible
Next i
End If 'Row.Record.Visible
End If 'Not Row.GroupRow
End If
Exit Function
ErrHandler:
Debug.Print "GetExportRecord", Err.Number, Err.Description
End Function
|