Attribute VB_Name = "TextFile2Database"
Public Function ImportTextFile(cn As Object, _
  ByVal tblName As String, FileFullPath As String, _
  Optional FieldDelimiter As String = ",", _
  Optional RecordDelimiter As String = vbCrLf) As Boolean
 
'PURPOSE: Imports a delimited text file into a database

'PARAMTERS: cn -- an open ado connection
'          : tblName -- import destination table name
'          : FileFullPath -- Full Path of File to import form
'          : FieldDelimiter -- (Optional) String character(s) in
'                              file separating field values
'                              within a record; defaults
'                              to ","
'          : RecordDelimiter -- (Optional) String character(s)
'                                separating records within text
'                                file; defaults to vbcrlf

'RETURNS: True if successful, false otherwise
'EXAMPLE:
'dim cn as new adodb.connection
'cn.connectionstring = _
'   "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\db1.mdb"
'cn.open
'ImportTextFile cn, "MyTable", "C:\myCSVFile.csv"

'REQUIRES: VB6

Dim cmd As New ADODB.Command
Dim rs As New ADODB.Recordset
Dim sFileContents As String
Dim iFileNum As Integer
Dim sTableSplit() As String
Dim sRecordSplit() As String
Dim lCtr As Integer
Dim iCtr As Integer
Dim iFieldCtr As Integer
Dim lRecordCount As Long
Dim iFieldsToImport As Integer


'These variables prevent
'having to requery a recordset
'for each record
Dim asFieldNames() As String
Dim abFieldIsString() As Boolean
Dim iFieldCount As Integer
Dim sSQL As String
Dim bQuote As Boolean


On Error GoTo errHandler
If Not TypeOf cn Is ADODB.Connection Then Exit Function
If Dir(FileFullPath) = "" Then Exit Function

If cn.State = 0 Then cn.Open
Set cmd.ActiveConnection = cn
cmd.CommandText = tblName
cmd.CommandType = adCmdTable
Set rs = cmd.Execute
iFieldCount = rs.Fields.Count
rs.Close



ReDim asFieldNames(iFieldCount - 1) As String
ReDim abFieldIsString(iFieldCount - 1) As Boolean

For iCtr = 0 To iFieldCount - 1
    asFieldNames(iCtr) = "[" & rs.Fields(iCtr).Name & "]"
    abFieldIsString(iCtr) = FieldIsString(rs.Fields(iCtr))
Next
    

iFileNum = FreeFile
Open FileFullPath For Input As #iFileNum
sFileContents = Input(LOF(iFileNum), #iFileNum)
Close #iFileNum
'split file contents into rows
sTableSplit = Split(sFileContents, RecordDelimiter)
lRecordCount = UBound(sTableSplit)
'make it "all or nothing: whole text
'file or none of it
cn.BeginTrans

For lCtr = 0 To lRecordCount - 1
        'split record into field values
    
    sRecordSplit = Split(sTableSplit(lCtr), FieldDelimiter)
    iFieldsToImport = IIf(UBound(sRecordSplit) + 1 < _
        iFieldCount, UBound(sRecordSplit) + 1, iFieldCount)
 
   'construct sql
    sSQL = "INSERT INTO " & tblName & " ("
    
    For iCtr = 0 To iFieldsToImport - 1
        bQuote = abFieldIsString(iCtr)
        sSQL = sSQL & asFieldNames(iCtr)
        If iCtr < iFieldsToImport - 1 Then sSQL = sSQL & ","
    Next iCtr
    
    sSQL = sSQL & ") VALUES ("
    
    For iCtr = 0 To iFieldsToImport - 1
        If abFieldIsString(iCtr) Then
             sSQL = sSQL & prepStringForSQL(sRecordSplit(iCtr))
        Else
            sSQL = sSQL & sRecordSplit(iCtr)
        End If
        
        If iCtr < iFieldsToImport - 1 Then sSQL = sSQL & ","
    Next iCtr
    
    sSQL = sSQL & ")"
    cn.Execute sSQL

Next lCtr

cn.CommitTrans
rs.Close
Close #iFileNum
Set rs = Nothing
Set cmd = Nothing

ImportTextFile = True
Exit Function

errHandler:
On Error Resume Next
If cn.State <> 0 Then cn.RollbackTrans
If iFileNum > 0 Then Close #iFileNum
If rs.State <> 0 Then rs.Close
Set rs = Nothing
Set cmd = Nothing


End Function

Private Function FieldIsString(FieldObject As ADODB.Field) _
   As Boolean
    
     Select Case FieldObject.Type
         Case adBSTR, adChar, adVarChar, adWChar, adVarWChar, _
               adLongVarChar, adLongVarWChar
               FieldIsString = True
            Case Else
               FieldIsString = False
        End Select
        
End Function

Private Function prepStringForSQL(ByVal sValue As String) _
   As String

Dim sAns As String
sAns = Replace(sValue, Chr(39), "''")
sAns = "'" & sAns & "'"
prepStringForSQL = sAns

End Function