Visual Basic : Generate A Csv File

First Add reference to Microsoft Activex Data Objects 2.5 Library

Option Explicit

Private m_cnDatabase As ADODB.Connection

Private Sub cmdExport_Click()

Call ExportToCVS("tbl_Watcher")

End Sub

Private Sub Form_Load()

Set m_cnDatabase = New ADODB.Connection

With m_cnDatabase

.CursorLocation = adUseClient

.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\folder\Project1\AccessDirectory.mdb;"

.Open

End With

End Sub

Private Sub ExportToCVS(ByRef sTable As String)

Dim sExportLine As String

Dim rsData As ADODB.Recordset

Dim sSql As String

Dim hFile As Long

Dim oField As ADODB.Field

On Error GoTo PROC_ERR

' ' Open the table. '

Set rsData = New ADODB.Recordset

With rsData

.ActiveConnection = m_cnDatabase

.CursorLocation = adUseClient

.CursorType = adOpenForwardOnly

.LockType = adLockReadOnly

.Source = "SELECT * FROM " & sTable

.Open

If (.State = adStateOpen) Then

hFile = FreeFile Open "C:\Temp\" & sTable & ".CSV" For Output As hFile

' Print file header with fieldnames.

sExportLine = ""

For Each oField In .Fields

sExportLine = sExportLine & oField.Name & ","

Next

sExportLine = VBA.Left$(sExportLine, Len(sExportLine) - 1)

Print #hFile, sExportLine

Do Until .EOF

sExportLine = ""

For Each oField In .Fields

sExportLine = sExportLine & oField.Value & ","Next

sExportLine = VBA.Left$(sExportLine, Len(sExportLine) - 1)

Print #hFile, sExportLine

.MoveNext

Loop

End If

End With

PROC_EXIT: ' ' Clean up and exit gracefully. '

If (Not rsData Is Nothing) Then

With rsData

If (.State <> adStateClosed) Then

.Close

End If

End With

End If

If (hFile <> 0) Then

Close hFile

End If

PROC_ERR:

Select Case Err.Number

Case Is <> 0

MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ExportToCVS of Form frmMain"

Err.Clear

Resume PROC_EXIT

End Select

End Sub