MS Access Export to Excel or CSV

Exporting data from Ms Access 2007 to Excel from code is just a one line statement using DoCmd.TransferSpreadsheet, but in CSV there's an inherent bug so I created my own export module. Plus a special function that saves file to disk, which I modified a bit to make it work on 64 bit machine.

Private Sub cmdExport_Click()
On Error GoTo ShowError
Dim strFilter As String
Dim strFilename As String


'Ask for SaveFileName
Select Case optFileType.value
Case 1
strFilter = ahtAddFilterItem(strFilter, "Excel Files (*.xls)", "*.xls")
Case 2
strFilter = ahtAddFilterItem(strFilter, "CSV Files (*.csv)", "*.csv")
End Select

strFilename = ahtCommonFileOpenSave(OpenFile:=False, _
Filter:=strFilter, _
Flags:=ahtOFN_OVERWRITEPROMPT Or ahtOFN_READONLY, _
FileName:="Export as of " & Format(Now, "mm-dd-yyyy hh-MM AMPM"))


If Len(Trim(strFilename)) > 0 Then
Select Case optFileType.value
Case 1

 Select Case cboExcelVersion.ListIndex
 Case 0  '2007
   DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "ExportDescriptive", strFilename
 Case 1  '2000
   DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "ExportDescriptive", strFilename
 Case 2  '97
   DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, "ExportDescriptive", strFilename
 Case 3  '95
   DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel7, "ExportDescriptive", strFilename
 End Select
 MsgBox "Data has been exported successfully to excel", vbInformation
Case 2

 'this has bug, so not using this
 'DoCmd.TransferText acExportDelim, "SaveCSV", "ExportDescriptive", strFilename, True
 'use this instead
 Export2CSV strFilename & ".csv", ","

End Select
MsgBox "Records exported", vbInformation
End If
GoTo NoError

ShowError:
MsgBox Error

NoError:

End Sub

As you can see from the code, I commented out the DoCmd.TransferText and replaced it with The Export2CSV customized function. Here's the code.

Option Explicit

Public Sub Export2CSV(strFilename, strDelimiter)
On Error GoTo ShowError

Dim dbItem As Database
Dim rsExport As DAO.Recordset
Dim strCol As String
Dim strTemp As String
Set dbItem = CurrentDb
Set rsExport = dbItem.OpenRecordset("ExportDescriptive")
Dim nRow As Long
Dim nCol As Long

Open strFilename For Output As #1
 strCol = ""  'print headers
  For nCol = 1 To rsExport.Fields.Count - 1
   strTemp = rsExport.Fields(nCol - 1).Name
   If nCol < rsExport.Fields.Count Then
      strCol = strCol & strTemp & strDelimiter
   End If
  Next nCol
  Write #1, strCol & vbCrLf

If rsExport.RecordCount > 0 Then
 rsExport.MoveLast
 rsExport.MoveFirst
 
 'nRow = 0
 Do While Not rsExport.EOF
 'For nRow = 1 To rsExport.RecordCount
   'nRow = nRow + 1
   strCol = ""
       
   For nCol = 1 To rsExport.Fields.Count - 1
    strTemp = IIf(IsNull(rsExport.Fields(nCol - 1).value), "", rsExport.Fields(nCol - 1).value)
    If strDelimiter = vbTab Then
      strTemp = Replace(strTemp, vbTab, "")
    End If
    strTemp = Replace(strTemp, Chr(34), Chr(34) & Chr(34)) 'find double quote and escape it with double quote
    
    If strDelimiter <> vbTab Then  'if delimiter is other than tab
       If InStr(1, strTemp, strDelimiter) > 0 Then
         strTemp = Chr(34) & strTemp & Chr(34)  ' enclosed in double quote, as entire text qualifier
       End If
    End If
    strCol = strCol + strTemp
    If nCol < rsExport.Fields.Count Then
      strCol = strCol & strDelimiter
    End If
   Next nCol

   Write #1, strCol & vbCrLf
   rsExport.MoveNext
 Loop 'Next nRow
End If
Close #1
rsExport.Close
GoTo Bypass

ShowError:
  MsgBox Error, vbCritical

Bypass:
  Set dbItem = Nothing
  Set rsExport = Nothing
End Sub

And lastly the customized function for saving the CSV file to disk. It's quite a long script so I'll just provide here the link to that, click here to view.