1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65
| Private Sub Txt_Click()
Dim obj_Access As Access.Application
Dim Nom_Base_Access As String
Dim Nom_Fichier As String
Dim Nom_Table As String
Nom_Fichier = "D:\Projets\Retraitements\essai.txt"
Nom_Base_Access = "D:\Projets\Retraitements\retraiteo.mdb"
Nom_Table = "Table1"
Dim rep, Nom_Tbl As String
'obtient le premier fichier ou répertoire qui est dans "D:\"
rep = Dir("D:\Projets\Retraitements\" & "*.txt", vbDirectory)
'boucle tant que le répertoire n'a pas été entièrement parcouru
On Error GoTo Erreur
Do While (rep <> "")
'teste si c'est un fichier ou un répertoire
If (GetAttr(Dossier & rep) And vbDirectory) = vbDirectory Then
MsgBox "Répertoire " & rep
Else
Nom_Tbl = Mid(rep, InStrRev(rep, "\") + 1, Len(rep) - (4 + InStrRev(rep, "\")))
' Création d'un objet Access
Set obj_Access = New Access.Application
' Ouverture de la base Access
obj_Access.OpenCurrentDatabase Nom_Base_Access
' Si mot de passe
'SendKeys MotDePasse & "~"
' destruction de la table de réception sinon ça ajoute dans la table
On Error Resume Next
obj_Access.Docmd.DeleteObject acTable, Nom_Table
On Error GoTo 0
' importation d'un fichier texte délimité par des ';'
obj_Access.Docmd.TransferText acImportDelim, , Nom_Table, Nom_Fichier, False
' Fermeture de la base
obj_Access.Quit
' Libération de la mémoire
Set obj_Access = Nothing
Docmd.TransferText acImportDelim, "Export Spécification d'importation", Nom_Tbl, Dossier & rep, False, rep & "!"
End If
Suite:
'passe à l'élément suivant
rep = Dir
Loop
Exit Sub
Erreur:
MsgBox "Erreur " & Dossier & rep & " " & Err.Number & " " & _
Err.Description
Resume Suite
End Sub |
Partager