' following is a simplistic approach to importing CSV data into Access. ' note the lack of any real error handling; this should be dealt with. ' However, it should get you started ' At the end is a sample 'call' to the function ' note that this code will support storing the field names ' in the first line of the record
Option Compare Database Option Explicit
' read a csv file into a recordset ' can handle a first line with field names (e.g. a header) ' deals with quoted strings in csv data (e.g. "this is a test,,,,", this,is,a,test ' Function ImportCsvFile(FileName As String, DestRst As Recordset, ErrorMsg As String, Optional HasHeaders As Boolean = False) As Long On Error GoTo ImportCsvFileError ' open the source file Dim InputFileHandle As Integer InputFileHandle = FreeFile Open FileName For Input As #InputFileHandle
' set the current character read from the file Dim CurChar As String CurChar = ""
' set the previous character read from the file Dim PrevChar As String PrevChar = ""
' indicate if the next character has already been 'read' Dim ReadAhead As Boolean ReadAhead = False
' store field names in a header Dim ReadFieldNames(0 To 511) As String
' indicate if we are currently reading a header line Dim ReadingHeaderLine As Boolean ReadingHeaderLine = HasHeaders
' the current field (text between commas) Dim CurField As String CurField = ""
' indicate if we are inside a quoted field Dim InQuote As Boolean InQuote = False
' the current field number (index into the field names array *or* the recordset) Dim FieldNumber As Integer FieldNumber = 0
' indicate if a field has been read (e.g. a comma or EOL has been reached) Dim SetField As Boolean SetField = False
' indicate if a record should be added (e.g. EOL has been reached) Dim AddRecord As Boolean AddRecord = False
' indicate if a DestRst.Update method needs to be invoked Dim NeedsUpdate As Boolean NeedsUpdate = False
' indicate if a DestRst.AddNew method needs to be invoked Dim NeedToAdd As Boolean NeedToAdd = True
Do While Not EOF(InputFileHandle) ' Loop until end of file. ' sometimes we need to read ahead one character (e.g. for a "), then find we want to put ' that character back into the input stream. If Not ReadAhead Then CurChar = Input(1, #InputFileHandle) ' Get one character. End If ReadAhead = False
Select Case CurChar ' handle quoted strings in the CSV data, allowing embedded commas or quotes. Case """" If InQuote Then If Not EOF(InputFileHandle) Then CurChar = Input(1, #InputFileHandle) If CurChar = """" Then CurField = CurField & """" Else ReadAhead = True InQuote = False End If Else InQuote = False End If Else InQuote = True End If ' handle the comma character (End of Field, unless in a quoted string) Case "," If InQuote Then CurField = CurField & "," Else SetField = True End If ' handle all other characters ' toss out any CR's, and treat LF's as end of line. Case Else If Asc(CurChar) <> 13 Then If Asc(CurChar) = 10 Then SetField = True AddRecord = True Else CurField = CurField & CurChar End If End If End Select ' either set a field name (if header), or set a field value (based on field name in header, or field number) If SetField Then If NeedToAdd Then DestRst.AddNew ' add a new record NeedToAdd = False ' clear need to add NeedsUpdate = True ' we do need to do an update before doing another Add End If CurField = Trim(CurField)
If ReadingHeaderLine Then ' store field name ReadFieldNames(FieldNumber) = CurField Else ' only add fields that are non-zero-length If Len(CurField) > 0 Then If HasHeaders Then ' set field value (either from name, or field number) DestRst(ReadFieldNames(FieldNumber)) = CurField Else DestRst(FieldNumber) = CurField End If End If End If FieldNumber = FieldNumber + 1 ' bump field number CurField = "" ' clear field for more data SetField = False ' wait for a comma or EOL End If
' if we hit EOL, Update any existing changes, and indicate we need to add ' another record if we encounter more data If AddRecord Then If NeedsUpdate Then DestRst.Update NeedsUpdate = False End If NeedToAdd = True ' if we hit more data, do an .AddNew FieldNumber = 0 ' start at field 0 ReadingHeaderLine = False ' there can only be one header line AddRecord = False DoEvents End If
PrevChar = CurChar Loop If NeedsUpdate Then DestRst.Update End If Close #InputFileHandle
ImportCsvFileExit: Exit Function
ImportCsvFileError: Resume End Function
Sub TestCsvImport() Dim ErrorMsg As String
Dim MyRst As Recordset Set MyRst = CurrentDb.OpenRecordset("SomeTable") ImportCsvFile "C:\SomeData.csv", MyRst, ErrorMsg, False MyRst.Close Set MyRst = Nothing End Sub