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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
| Option Explicit
Option Private Module
'
' Établir la référence à ADODB : Microsoft ActiveX Data Objects 6.1 Library
' Pour les valeurs de Stream.Charset, voir dans le registre : HKEY_CLASSES_ROOT\MIME\Database\Charset
'
Public Const sepV$ = "," 'séparateur de valeurs
Public Const sepL$ = vbCrLf 'séparateur de lignes
Public Const idTxt$ = """" 'identificateur de texte chr(34)
'
Sub import_csv()
Dim nomfich As Variant
Dim wbk As Workbook
nomfich = Application.GetOpenFilename("Fichiers csv, *.csv")
If nomfich = False Then Exit Sub
Set wbk = Lire_csv_UTF8_avec_ou_sans_BOM(nomfich)
'.... code
'
Call Enregistrer_csv_UTF8_avec_BOM(wbk.Worksheets(1), nomfich)
' ou
' Call Enregistrer_csv_UTF8_sans_BOM(wbk.Worksheets(1), nomfich)
wbk.Close False
End Sub
Public Function Lire_csv_UTF8_avec_ou_sans_BOM(ByVal nomCompletFichier As String) As Workbook
' 16/01/19 Patrice33740 V1-0-00
Dim fUtf8 As ADODB.Stream 'flux de données Utf8
Dim wbk As Excel.Workbook 'Classeur résultat
Dim cel As Range 'cellule destination
Dim txt As String 'texte
Dim lgn As String 'ligne
Dim lgr As Long 'longueur
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbk = Application.Workbooks.Add(xlWBATWorksheet)
Set cel = wbk.Worksheets(1).Range("A1")
Set fUtf8 = New Stream
With fUtf8
' Définir le flux de données Utf8
.Charset = "utf-8" ' ou pour windows = "ISO-8859-1"
.Mode = adModeReadWrite
.Type = adTypeText
.LineSeparator = adCRLF
' Ouvrir le flux et charger le contenu du fichier
.Open
.LoadFromFile nomCompletFichier
Do Until .EOS
txt = .ReadText(-2) '-2 = une ligne
lgn = lgn & txt
lgr = Len(lgn) - Len(Replace(lgn, idTxt, ""))
If (lgr Mod 2) = 0 Then
' la ligne est complète
Call EcrireLigneCSV(lgn, cel)
Set cel = cel.Offset(1)
txt = "": lgn = ""
Else
' la ligne est incomplète
lgn = lgn & sepL
End If
Loop
.Close
End With
Set fUtf8 = Nothing
wbk.Worksheets(1).Columns.AutoFit
wbk.Worksheets(1).Rows.AutoFit
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set Lire_csv_UTF8_avec_ou_sans_BOM = wbk
End Function
Private Sub EcrireLigneCSV(lgn As String, cel As Range)
' 16/01/19 Patrice33740 V1-0-00
Dim txt As String 'texte
Dim frm As String 'formule (champ)
Dim lgr As Long 'longueur
Dim nbC As Long 'nombre de colonnes
Dim t As Variant 'Tableau des champs bruts
Dim i As Long 'index
If lgn = "" Then Exit Sub
t = Split(lgn, sepV)
For i = LBound(t) To UBound(t)
frm = txt & t(i)
lgr = Len(frm) - Len(Replace(frm, idTxt, ""))
If (lgr Mod 2) = 0 Then
' le champ est complet
If Mid(frm, 1, 1) = idTxt Then
' le texte est délimité, enlever les délimiteurs
frm = Mid(frm, 2, Len(frm) - 2)
' remplacer les doubles délimiteurs pas un simple délimiteur
frm = Replace(frm, idTxt & idTxt, idTxt)
End If
cel.Offset(0, nbC).FormulaLocal = frm
txt = "": nbC = nbC + 1
Else
' le champ est incomplet
txt = frm & sepV
End If
Next i
End Sub
Public Sub Enregistrer_csv_UTF8_avec_BOM(wsh As Worksheet, ByVal nomCompletFichier As String, Optional AllText As Boolean = False)
' Enregistrement d'une feuille Excel au format csv encodé UTF8 avec BOM (si Alltext : toutes les infos délimitées texte)
' 31/03/20 Patrice33740 V1-2-01
Dim fUtf8avecBOM As ADODB.Stream 'flux de données Utf8 avec BOM
Dim rngData As Range 'plage des données
Dim txt As String 'texte
Dim n°L As Long 'numéro de ligne
Dim n°C As Long 'numéro de colonne
' Définir le flux de données Utf8 avec BOM
Set fUtf8avecBOM = New Stream
fUtf8avecBOM.Charset = "utf-8"
fUtf8avecBOM.Mode = adModeReadWrite
fUtf8avecBOM.Type = adTypeText
fUtf8avecBOM.Open
' Ajouter les données séparées par une virgule et encadrées par des "
Set rngData = wsh.UsedRange
With rngData
For n°L = 1 To .Rows.Count
txt = AjoutIdTexte(.Cells(n°L, 1).Text, AllText)
fUtf8avecBOM.WriteText txt
For n°C = 2 To .Columns.Count
txt = AjoutIdTexte(.Cells(n°L, n°C).Text, AllText)
fUtf8avecBOM.WriteText sepV & txt
Next n°C
fUtf8avecBOM.WriteText sepL
Next n°L
End With
' Enregistrer le fichier
fUtf8avecBOM.Flush
fUtf8avecBOM.SaveToFile nomCompletFichier, adSaveCreateOverWrite
fUtf8avecBOM.Close
Set fUtf8avecBOM = Nothing
End Sub
Public Sub Enregistrer_csv_UTF8_sans_BOM(wsh As Worksheet, ByVal nomCompletFichier As String, Optional AllText As Boolean = False)
' Enregistrement d'une feuille Excel au format csv encodé UTF8 sans BOM (si Alltext : toutes les infos délimitées texte)
' 16/01/19 Patrice33740 V1-0-00
Dim fUtf8avecBOM As ADODB.Stream 'flux de données Utf8 avec BOM
Dim fUtf8sansBOM As ADODB.Stream 'flux de données Utf8 sans BOM
Dim rngData As Range 'plage des données
Dim txt As String 'texte
Dim n°L As Long 'numéro de ligne
Dim n°C As Long 'numéro de colonne
' Définir le flux de données Utf8 avec BOM
Set fUtf8avecBOM = New Stream
fUtf8avecBOM.Charset = "utf-8"
fUtf8avecBOM.Mode = adModeReadWrite
fUtf8avecBOM.Type = adTypeText
fUtf8avecBOM.Open
' Ajouter les données séparées par une virgule et encadrées par des "
Set rngData = wsh.UsedRange
With rngData
For n°L = 1 To .Rows.Count
txt = AjoutIdTexte(.Cells(n°L, 1).Text, AllText)
fUtf8avecBOM.WriteText txt
For n°C = 2 To .Columns.Count
txt = AjoutIdTexte(.Cells(n°L, n°C).Text, AllText)
fUtf8avecBOM.WriteText sepV & txt
Next n°C
fUtf8avecBOM.WriteText sepL
Next n°L
End With
' Pointer après le BOM
fUtf8avecBOM.Position = 3
' Définir le flux de données Utf8 sans BOM
Set fUtf8sansBOM = New Stream
fUtf8sansBOM.Mode = adModeReadWrite
fUtf8sansBOM.Type = adTypeBinary
fUtf8sansBOM.Open
'Ajouter les données (sans le BOM)
fUtf8avecBOM.CopyTo fUtf8sansBOM
fUtf8avecBOM.Flush
fUtf8avecBOM.Close
Set fUtf8avecBOM = Nothing
' Enregistrer le fichier
fUtf8sansBOM.SaveToFile nomCompletFichier, adSaveCreateOverWrite
fUtf8sansBOM.Close
Set fUtf8sansBOM = Nothing
End Sub
Private Function AjoutIdTexte(txt As String, Optional AllText As Boolean = False) As String
' 31/03/20 Patrice33740 V1-2-01
' Uniformiser les séparateurs de ligne, selon l'origine Cr ou CrLf ou Lf.
txt = Replace(Replace(Replace(txt, vbCrLf, vbLf), vbCr, vbLf), vbLf, sepL)
' Ajouter les identificateurs de texte indispensable (ou systèmatiques si AllText)
If AllText Or InStr(1, txt, sepL) > 0 Or InStr(1, txt, sepV) > 0 Or InStr(1, txt, idTxt) > 0 Then
txt = idTxt & Replace(txt, idTxt, idTxt & idTxt) & idTxt
End If
AjoutIdTexte = txt
End Function |
