Access - Importar txt

Private Sub LeerArchivos(smptRuta As String)

Dim sArchivo As String

'Dim sRuta  As String

DoCmd.SetWarnings (False)

DoCmd.RunSQL "DELETE * FROM tbArchivos", False

DoCmd.SetWarnings (True)

Set tbArchivos = CurrentDb.OpenRecordset("tbArchivos")

sRuta = smptRuta

sArchivo = Dir(sRuta & "*.txt")     ' Recupera la primera entrada.

Do While sArchivo <> ""     ' Inicia el bucle.

    tbArchivos.AddNew

    tbArchivos.Fields("sArchivo") = sArchivo

    tbArchivos.Update

    sArchivo = Dir    ' Obtiene siguiente entrada.

Loop

End Sub

'==================================================

Sub sImporta(smptRuta As String)

Dim i As Long

tbArchivos.MoveFirst

While tbArchivos.EOF = False

' ---------- Aqui procesar los imports, por cada uno de los archivos ------------

DoCmd.TransferText acImportFixed, "TblText_x88", "TblText_x88", "D:\Datos\Mis documentos\My eBooks\ArxiuSumat.txt", False, ""

' ---------- Aqui procesar los imports, por cada uno de los archivos ------------

docmd.runsql ("update   Todos  SET ArchivoOrig = "  & tbArchivos.fields("Archivo") " " )

    tbArchivos.MoveNext

Wend

end sub

private Sub Comando21_Click()

On Error GoTo Err_Comando21_Click

Dim bytArchivo As Byte, _

    strRutaArchivo As String, _

    strArchivo As String, _

    strLinea As String, _

    strSQL As String, _

    lngLinea As Long, _

    Contador As Long, Cuenta As Long

Dim Iniciales As String, Cadena As Long

Dim RutaFichero As String, PrimeraIni As String

    'Me.EtiEspera.Visible = True

    'Me.NomArchivo.Visible = True

    'Me.txtStatusBar.Visible = True

    'Me.txtStatusPercent.Visible = True

    'NomArchivo = Null 'En este caso es un campo independiente, pero puede ser una variable pública

    strRutaArchivo = "D:\Datos\Mis documentos\My eBooks\"

    strArchivo = Dir(strRutaArchivo & "*.txt")

    Contador = 0

    Cuenta = 0

  'Cuento los archivosde texto

  Do While strArchivo <> ""

      PrimeraIni = Left(strArchivo, 1)

      strArchivo = strRutaArchivo & strArchivo

      strArchivo = Dir

      Contador = Contador + 1

    If PrimeraIni = "M" Then

      Cuenta = Cuenta + 1

    Else

      Cuenta = Cuenta

    End If

  Loop

    CantArchivos = Contador

    CantMax = Cuenta

    strArchivo = Dir(strRutaArchivo & "*.txt")

    'DoCmd.SetWarnings False

 'For CantArchivos = 0 To CantArchivos

    'Cadena = Len(FileName(strRutaArchivo & strArchivo)) - 4

    'NomArchivo = UCase(Left(FileName(strArchivo), Cadena))

    'Iniciales = UCase(Right(Left(FileName(strArchivo), 3), 2))

    'bytArchivo = FreeFile

 If strArchivo <> "." And strArchivo <> ".." And Right(strArchivo, 3) = "txt" And Left(strArchivo, 1) = "M" Then

 strArchivo = strRutaArchivo & strArchivo

    'DoCmd.OpenQuery "CnsExportarExcelEliminar"

Open strArchivo For Input As #bytArchivo 'Recorrida para insertar en las tablas

 Do While Not EOF(bytArchivo)

  DoCmd.SetWarnings False

    DoCmd.TransferText acImportFixed, "TblText_X88", "TblText_X88", "strArchivo & NomArchivo", False, """"

    DoCmd.TransferText acImportFixed, "TblText_X78", "TblText_X78", "strArchivo & NomArchivo", False, """"

    DoCmd.TransferText acImportFixed, "TblText_X68", "TblText_X68", "strArchivo & NomArchivo", False, """"

    DoCmd.TransferText acImportFixed, "TblText_X58", "TblText_X58", "strArchivo & NomArchivo", False, """"

    DoCmd.TransferText acImportFixed, "TblText_X48", "TblText_X48", "strArchivo & NomArchivo", False, """"

    DoCmd.SetWarnings True

 Loop

    Close #bytArchivo

    FileCopy strRutaArchivo & NomArchivo & ".txt", "D:\Datos\Mis documentos\My eBooks\Fitxers\" & NomArchivo & ".txt"

    Kill strRutaArchivo & NomArchivo & ".txt"

    strArchivo = Dir

 ElseIf strArchivo <> "." And strArchivo <> ".." And Right(strArchivo, 3) = "txt" Then

    strArchivo = strRutaArchivo & strArchivo

    strArchivo = Dir

 End If

    If Left(NomArchivo, 1) = "M" Then

      DoEvents

      Avanzar

    End If

 'Next CantArchivos

  '  Me.EtiProceso.Visible = True

   ' Resetear

    'DoCmd.SetWarnings True

Exit_Comando21_Click:

    Exit Sub

Err_Comando21_Click:

    MsgBox Err.Description

    Resume Exit_Comando21_Click

End Sub

Sub sImporta(smptRuta As String)

Dim i As Long

' -------------- NOTA, NOTA, NOTA -------------- 

'Debes de crear una tabla llamada "tbFinal", que debe de tener la misma estructura que los archivos que estas inportando y al FINAL,  le agragas un campo llamado "sNomArchivo" de tipo texto.

' -------------- NOTA, NOTA, NOTA -------------- 

sRuta = "D:\Datos\Mis documentos\My eBooks\"

tbArchivos.MoveFirst

While tbArchivos.EOF = False

' ---------- Aqui procesar los imports, por cada uno de los archivos ------------

DoCmd.TransferText acExportFixed, "TblText_x88", "e_" & tbArchivos.Fields("sArchivo"), sRuta &  tbArchivos.Fields("sArchivo"), False, ""

' ---------- Aqui procesar los imports, por cada uno de los archivos ------------	

	dbs.Execute "ALTER TABLE e_" & tbArchivos.Fields("sArchivo") & "  ADD COLUMN sNomArchivo;"

	dbs.Execute "UPDATE TABLE e_" & tbArchivos.Fields("sArchivo") & "  SET sNomArchivo = '" & tbArchivos.Fields("sArchivo") & "'"

	dbs.Execute "INSERT INTO tbFinal SELECT * FROM e_" & tbArchivos.Fields("sArchivo")

    tbArchivos.MoveNext

Wend

end sub