NOTHING IS IMPOSSIBLE!!!!
==================================================
http://www.tek-tips.com/faqs.cfm?fid=3566
==================================================
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