Importar texto para o Access com ADO/RDO/DAO/filesys/automação ImportText.exe

Sub DAOOpenTextFileImport()
On Error GoTo ErrHandler

lblAction.Caption = "DAO Import..."

Dim daoDB As DAO.Database
Dim strSQL As String
   
If chkCreateTbl.Value = 1 Then
    DBEngine.IniPath = App.Path & "\Schema_Header.ini"
Else
    DBEngine.IniPath = App.Path & "\Schema.ini"
End If

Set daoDB = OpenDatabase(App.Path, False, False, _
                    "Text;Database=" & App.Path & ";table=" & txtFile.Text)

If chkCreateTbl.Value = 1 Then
    'Use this if you do not already have a table created in Access.
    'Creates and appends the data in one step.
    strSQL = "SELECT * INTO [" & txtTable.Text & "] IN '" & _
                   App.Path & "\" & txtDatabase.Text & " '"
    strSQL = strSQL & "FROM " & txtFile.Text
    daoDB.Execute strSQL
Else
    'Delete data before importing - use if necessary.
    strSQL = "DELETE FROM [" & txtTable.Text & "] IN '" & _
                    App.Path & "\" & txtDatabase.Text & "'"
    daoDB.Execute strSQL
    'Append data to Access table.
    strSQL = "INSERT INTO [" & txtTable.Text & "] IN '" & _
                    App.Path & "\" & txtDatabase.Text & "'"
    strSQL = strSQL & "SELECT * FROM " & txtFile.Text
    daoDB.Execute strSQL
End If

GoTo ExitSub
   
ErrHandler:
    lblAction.Caption = "DAO Import - Error."
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
    
ExitSub:
    lblAction.Caption = "Complete..."
    daoDB.Close
    Set daoDB = Nothing
End Sub
				

Private Sub FileSysImport()
On Error GoTo ErrHandler

lblAction.Caption = "FileSys Import..."

Dim daoDB As DAO.Database
Dim daoRs As DAO.Recordset
Dim fs As FileSystemObject
Dim ts As TextStream
Dim inLine As Variant
Dim strSQL As String
Dim i As Integer

If chkCreateTbl.Value = 1 Then
    'This is an eazy way to create the Table layout in Access based on the Schema_Header.ini file.
    DBEngine.IniPath = App.Path & "\Schema_Header.ini"
    Set daoDB = OpenDatabase(App.Path, False, False, "Text;Database=" & App.Path & ";table=" & txtFile.Text)
    strSQL = "SELECT * INTO [" & txtTable.Text & "] IN '" & App.Path & "\" & txtDatabase.Text & " '"
    strSQL = strSQL & "FROM " & txtFile.Text & " WHERE 1=0"
    daoDB.Execute strSQL
    Set daoDB = Nothing
    Set daoDB = OpenDatabase(App.Path & "\" & txtDatabase.Text, False, False)
Else
    DBEngine.IniPath = App.Path & "\Schema.ini"
    Set daoDB = OpenDatabase(App.Path & "\" & txtDatabase.Text, False, False)
    strSQL = "DELETE * FROM [" & txtTable.Text & "] IN '" & App.Path & "\" & txtDatabase.Text & "'"
    daoDB.Execute strSQL, dbFailOnError
End If

strSQL = "SELECT * FROM [" & txtTable.Text & "] WHERE 1=0"
Set daoRs = daoDB.OpenRecordset(strSQL, dbOpenDynaset, dbAppendOnly)

Set fs = New FileSystemObject
Set ts = fs.OpenTextFile(App.Path & "\" & txtFile.Text, ForReading, False, TristateUseDefault)

'This skips the column header.
If chkColHeader.Value = 1 Then
    inLine = Split(ts.ReadLine, ",")
End If

While Not ts.AtEndOfStream
    inLine = Split(ts.ReadLine, ",")
    daoRs.AddNew
    For i = 0 To UBound(inLine) - 1
        daoRs.Fields(i).Value = Left(inLine(i), daoRs.Fields(i).Size)
    Next i
    daoRs.Update
Wend

GoTo ExitSub

ErrHandler:
    lblAction.Caption = "FileSys Import - Error."
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
    
ExitSub:
    lblAction.Caption = "Complete..."
    If Not ts Is Nothing Then ts.Close
    If Not daoRs Is Nothing Then daoRs.Close
    daoDB.Close
    Set daoRs = Nothing
    Set daoDB = Nothing
    Set ts = Nothing
    Set fs = Nothing
End Sub
				

Private Sub AccessAutomateImport()
'Assumes table already exists.
On Error GoTo ErrHandler

lblAction.Caption = "Access Automation..."
   
Dim AccessApp As access.Application
Dim strDB As String
   
strDB = App.Path & "\" & txtDatabase.Text

Set AccessApp = New access.Application
AccessApp.OpenCurrentDatabase strDB
   
'To Import with/without Column names in first row create another Import/Export Specification
'and put the name of that specification in the Text box 'txtSpecName' on the Tab Control.
'An example Specification is included in the sample MDB - 'Sample w/columns'.
AccessApp.DoCmd.TransferText acImportDelim, txtSpecName.Text, txtTable.Text, App.Path & "\" & txtFile.Text

AccessApp.CloseCurrentDatabase

GoTo ExitSub

ErrHandler:
    lblAction.Caption = "Access Automation - Error."
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
    
ExitSub:
    lblAction.Caption = "Complete..."
    appAccess.Quit
    Set appAccess = Nothing
End Sub