' 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
[tt]
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
This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
By continuing to use this site, you are consenting to our use of cookies.