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 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
|
' ===========================================================================================
Sub exporterTables()
' ===========================================================================================
Dim NomTable As String
Dim Dossier As String
Dim i As Integer
Dossier = "C:\Données\"
For i = 1 To 5
NomTable = Choose(i, "Table1", "Table2", "Table3", "Table4", "Table5")
Debug.Print "Exportation de " & NomTable
If Not exporteUneTable(Dossier, NomTable) Then
Stop
End If
Next i
DoCmd.Echo True, ""
MsgBox "Exportations terminées"
End Sub
' ===========================================================================================
Function exporteUneTable(ByVal Dossier As String, ByVal NomTable As String) As Boolean
' ===========================================================================================
Dim Txt As String
Dim i As Integer
Dim NomFichier As String
Dim Fs As New FileSystemObject
Dim Ts As TextStream
Dim Ts2 As TextStream
Dim NomFichier2 As String
Dim n As Integer
Dim m As Integer
Dim Phrase As String
Dim ligne As String
Const CR As String = "¤"
DoCmd.Echo True, " Traiement de la table " & NomTable & "..."
NomFichier = Dossier & "_" & NomTable & ".txt"
NomFichier2 = Dossier & NomTable & ".txt"
DoCmd.TransferText acExportDelim, , NomTable, NomFichier, False
Set Ts = Fs.OpenTextFile(NomFichier, ForReading)
Set Ts2 = Fs.OpenTextFile(NomFichier2, ForWriting, True)
Do Until Ts.AtEndOfStream
Txt = Ts.ReadLine ' Lit la ligne suivante
If InStr(Txt, CR) > 0 Then
Stop
End If
n = InStr(Txt, """")
Do While n > 0
m = InStr(n + 1, Txt, """")
If m = 0 Then
Txt = Txt & " " & Ts.ReadLine ' Ajoute la ligne suivante sans CRLF
m = InStr(n + 1, Txt, """")
If m = 0 Then
Stop
End If
End If
Phrase = Mid(Txt, n + 1, m - n - 1)
Phrase = Replace(Phrase, ",", CR)
Phrase = Replace(Phrase, "°", " ")
Txt = Left(Txt, n - 1) & Phrase & Mid(Txt, m + 1)
n = InStr(Txt, """")
Loop
' remplace les virgules par des tubes
Txt = Replace(Txt, ",", "|")
' remplace les doubles tubes par des virgules
Txt = Replace(Txt, CR, ",")
' ecrit la ligne convertie
Ts2.WriteLine Txt
Loop
' Ferme les fichiers
Ts.Close
Ts2.Close
DoCmd.Echo True, ""
exporteUneTable = True
End Function |
Partager