Discussion :

[Ne0zenith]

Bonjour à tous,

Je travaille en ce moment sur un module access qui a été développé par une autre personne. L'une des fonctions VBA permet d'importer les fichiers csv avec pour délimiteur de champ une virgule et pour délimiteur de texte des guillemets "".
Cette fonction marche bien, et permet d'importer des fichiers n'ayant pas forcément le même nombre de colonnes (contrairement aux spécifications d'importations enregistrées).

Mon problème est que maintenant, certains fichiers csv à importer ont pour délimiteur de champ une tabulation et aucun délimiteur de texte. Lorsque je remplace dans le code, plus rien ne marche.

Voici le code original, avec en vert les modifications que j'ai apportées.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
ImportReq "fichier.csv", "table_fichier"

Function ImportReq(NomFichier As String, NomTab As String)

Dim TextLine As String
Dim f As Integer, i  As Integer, j As Integer, k As Integer, Pos As Integer, verif As Integer
Dim champ(255) As String
Dim tb As DAO.Recordset, tb2 As DAO.Recordset
Dim Idmodele As Integer
Dim ReqSQL1 As String, ReqSQL2 As String, ReqSQL3 As String

On Error GoTo Exit_Import

Open Path(Application.CurrentDb.Name) & NomFichier For Input As #1
'on place dans la variable TextLine la premiere ligne du fichier censée contenir le nom des champs
Line Input #1, TextLine
TextLine = TextLine & ","    TextLine = TextLine & chr(9)
i = 2
f = 0
k = 1
'on parcours la variable TextLine pour récuperer le nom des champs que l'on place dans champ(f)
'le cas présent est celui d'enregistrement séparé par des tabulations ( char(9) )
Do While i <= Len(TextLine)
   Pos = InStr(i, TextLine, ",")    Pos = InStr(i, TextLine, chr(9))
   If Pos <> 0 Then
   j = Pos
   f = f + 1
   champ(f) = Mid(TextLine, i, j - i)
   ' on verifie que le nom du champ n'est pas en doublon
    If f > 1 Then
      For verif = 1 To f - 1
         If champ(verif) = champ(f) Then
          k = k + 1
          champ(f) = champ(f) & "_" & k
         End If
      Next verif
    End If
   'Debug.Print f & ":" & champ(f)
   i = j + 1
   End If
Loop

Close #1

'On enregistre un modèle d'importation temporaire "Modele tmp"
'Ouverture de la table contenant les spécifications d'importation de la base
Set tb = CurrentDb().OpenRecordset("MSysIMEXSpecs", dbOpenTable)

If tb.BOF Then
    Idmodele = 1 'au cas où la table est vide
    Else
    tb.MoveLast
    Idmodele = tb![SpecID] + 1
End If
With tb
    .AddNew
    ![DecimalPoint] = "."
    ![TextDelim] = """"    ![TextDelim] = ""
    ![FileType] = 0
    ![FieldSeparator] = ","    ![FieldSeparator] = chr(9)
    ![SpecType] = 1
    ![StartRow] = 0
    ![SpecID] = Idmodele
    ![SpecName] = "Modele tmp" & Int(Rnd * 1000) ' suffixe aléatoire pour éviter les doublons d'index
    .Update                                      ' sur les tables systèmes
End With

'Ouverture de la table contenant le détail des spécifications d'importation de la base
Set tb2 = CurrentDb().OpenRecordset("MSysIMEXColumns", dbOpenTable)

For i = 1 To f 'on parcours chaque champ
With tb2
    .AddNew
    ![DataType] = 10
    ![FieldName] = champ(i)
    ![Start] = 1 + (i - 1) * 255
    ![Width] = 255
    ![SpecID] = Idmodele
    .Update
    .Bookmark = tb2.LastModified
End With
Next i

DoCmd.TransferText acImportDelim, tb![SpecName], NomTab, Path(Application.CurrentDb.Name) & NomFichier, True, ""

tb2.Close
tb.Close

ReqSQL1 = "DELETE MSysIMEXSpecs.* FROM MSysIMEXSpecs WHERE MSysIMEXSpecs.SpecID = " & Idmodele & _
" WITH OWNERACCESS OPTION;"

ReqSQL2 = "DELETE MSysIMEXColumns.* FROM MSysIMEXColumns WHERE MSysIMEXColumns.SpecID = " & Idmodele & _
" WITH OWNERACCESS OPTION;"

DoCmd.SetWarnings False
DoCmd.RunSQL ReqSQL1
DoCmd.RunSQL ReqSQL2
DoCmd.SetWarnings True

Exit Function

Exit_Import:
MsgBox Err.Description, vbCritical + vbOKOnly

ReqSQL1 = "DELETE MSysIMEXSpecs.* FROM MSysIMEXSpecs WHERE MSysIMEXSpecs.SpecID = " & Idmodele & _
" WITH OWNERACCESS OPTION;"

ReqSQL2 = "DELETE MSysIMEXColumns.* FROM MSysIMEXColumns WHERE MSysIMEXColumns.SpecID = " & Idmodele & _
" WITH OWNERACCESS OPTION;"

DoCmd.SetWarnings False
DoCmd.RunSQL ReqSQL1
DoCmd.RunSQL ReqSQL2
DoCmd.SetWarnings True


End Function

Avec la fonction originale, je récupère bien des tables avec toutes mes colonnes et des noms de champ valides, mais avec la version modifiée par mes "soins", je n'ai plus que 3 colonnes avec comme noms de champs "ÿþ","F2","F3".

Si quelqu'un a une idée du problème...

[jean-paul lepetit]

Salut,

Si tu fais un import manuel en enregistrant ta specif d'importation, tu pourras voir dans tes tables "MSysIMEXSpecs" et MSysIMEXColumns les valeurs stockées et tu pourras ainsi les re coder....

[Ne0zenith]

C'est justement ce que j'ai fait. Lorsque je le fait manuellement, ça marche.
Après avoir copié chacune des valeurs stockées pour mon import manuel des tables MSysImexSpecs et MSysImexColumns dans mon code VBA, ça ne marche plus.

Ca me dépasse complètement, car il m'affiche correctement le nom de chacun de mes champs dans la table MSysImexColumns, et chaque valeur de la spécification créée automatiquement grâce au code VBA correspond à celle que j'ai enregistrée lors de mon import manuel.

[BlackOut]

Malgré le retard, voici le code initial revu et fonctionnel (c'est le principal).

Il n'est pas très performant puisque les champs sont volumineux (255 caractères pour les champs textes) et transforme tout seul les champs dans le type que reconnait Access (les valeurs '005434' deviendraient alors des nombres '5434'). Mais lorsqu'on a pas les formats à l'avance (Nombre et qualité des champs), on s'en contentera.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
ImportReq "TabTest.txt", "TabTest", vbTab
 
Function ImportReq(NomFichier As String, NomTab As String, Optional TypSep As String = ",")
On Error GoTo Err_ImportReq
 
    Dim TextLine As String          ' Première Ligne du Fichier (Nom des Champs)
    Dim PosCur As Integer           ' Position du Curseur de texte
    Dim PosSep As Integer           ' Position du Séparateur de Champs
    Dim NumFld As Integer           ' Numéro du Champs
    Dim IndDbl As Integer           ' Indice ajouté aux Titres en Doublon
    Dim Fields(255) As String       ' Collection des Titres de Champs (Maximum 255 Champs)
    Dim i As Integer
    Dim tSpecs As DAO.Recordset     ' Table des Spécifications Générales d'import
    Dim tColums As DAO.Recordset    ' Table des Spécifications Détaillées d'import
    Dim IdSpec As Integer           ' Id de la Spécification à Ajouter
    Dim ReqSQL1 As String, ReqSQL2 As String, ReqSQL3 As String
 
 
    Open Application.CurrentProject.Path & "\" & NomFichier For Input As #1
    Line Input #1, TextLine
    TextLine = TextLine & TypSep
    PosCur = 2
    NumFld = 0
    IndDbl = 1
 
    ' Chaque chaîne de caractère de TextLine séparée par le séparateur (TypSep)
    ' est stockée dans la collection Fields
    Do While PosCur <= Len(TextLine)
        PosSep = InStr(PosCur, TextLine, TypSep)
        If PosSep <> 0 Then
            NumFld = NumFld + 1
            Fields(NumFld) = Mid(TextLine, PosCur, PosSep - PosCur)
            If NumFld > 1 Then ' Si nom du champs existe => Ajout d'un indice
                For i = 1 To NumFld - 1
                    If Fields(i) = Fields(NumFld) Then
                        IndDbl = IndDbl + 1
                        Fields(NumFld) = Fields(NumFld) & "_" & IndDbl
                    End If
                Next
            End If
            PosCur = PosSep + 1
        End If
    Loop
 
    Close #1
 
    ' Ajout du modèle d'importation en deux phases: Données générales (Specs), puis Détail par Champs (Columns)
    Set tSpecs = CurrentDb().OpenRecordset("MSysIMEXSpecs", dbOpenTable)
    With tSpecs
        If .BOF Then        ' Teste si la table est vide
            IdSpec = 1
        Else
            .MoveLast
            IdSpec = ![SpecID] + 1
        End If
        .AddNew             ' Ajoute la spécification
        ![DecimalPoint] = "."
        ![TextDelim] = ""
        ![FileType] = 0
        ![FieldSeparator] = TypSep
        ![SpecType] = 1
        ![StartRow] = 0
        ![SpecID] = IdSpec
        IdSpec = Int(Rnd * 1000)    ' nom aléatoire pour éviter les doublons d'index
        ![SpecName] = IdSpec
        .Update
        .Close
    End With
 
    Set tColums = CurrentDb().OpenRecordset("MSysIMEXColumns", dbOpenTable)
    With tColums
        For i = 1 To NumFld
            .AddNew         ' Ajout des détails de la spécification (par champs)
            ![DataType] = 10
            ![FieldName] = Fields(i)
            ![Start] = 1 + (i - 1) * 255
            ![Width] = 255
            ![SpecID] = IdSpec
            .Update
            .Bookmark = .LastModified
        Next i
        .Close
    End With
 
    ' Importation des données en utilisant les spécifications créées ci-dessus
    DoCmd.TransferText acImportDelim, IdSpec, NomTab, _
        Application.CurrentProject.Path & "\" & NomFichier, True, ""
 
 
Exit_ImportReq:
    ' Suppression des spécifications
    DoCmd.SetWarnings False
    DoCmd.RunSQL "DELETE * FROM MSysIMEXSpecs WHERE SpecID = " & IdSpec
    DoCmd.RunSQL "DELETE * FROM MSysIMEXColumns WHERE SpecID = " & IdSpec
    DoCmd.SetWarnings True
    Exit Function
 
Err_ImportReq:
    MsgBox Err.Description & " (" & Err.Number & ")", vbCritical
    GoTo Exit_ImportReq
 
End Function
 
' Exécuté sur Access 2002 sans problème