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
| Public Sub IntegrerUnFichierXls(NomTableCible As String, PathXlsSource As String, Types As String, Optional AvecNotification As Boolean = False)
Dim sTypes As String
Dim aTypes As Variant
Dim strmemo As String, strtext As String
Dim repeater As Integer, iNbCol As Integer
Dim i As Integer, j As Integer
Dim infouser As Variant
'initialisations :
strmemo = ""
strtext = ""
'initialisation
For i = 1 To 256
strmemo = strmemo & "m"
Next
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
sTypes = Replace(Types, "text", "t") 'on devra, dans un second passage déclarer le nombre de caractères choisis
aTypes = Split(sTypes, ";")
iNbCol = UBound(aTypes)
For i = LBound(aTypes) To iNbCol
If Left(aTypes(i), 1) = "t" Then
repeater = Int(Replace(aTypes(i), "t", ""))
For j = 1 To repeater
strtext = strtext & "t"
Next
'on actualise le contenu de la colonne considérée,
'filtrée exclusivement sur du contenu texte;
'on remplace le contenu entier !!!
aTypes(i) = Replace(aTypes(i), aTypes(i), strtext)
Else
'tous les autres types concernant les colonnes
'dès que l'on détecte "memo", entre points virgules,
'on le remplace par un contenu de 256 caractères
aTypes(i) = Replace(aTypes(i), "memo", strmemo)
aTypes(i) = Replace(aTypes(i), "date", "01/01/1900")
End If
'puis on réinitialise strtext, avant de poursuivre la boucle
strtext = ""
Next
'on prévoit un remplacement de contenu pour les champs,
'qui viendra s'implanter en première ligne d'importation
'du fichier excel.
'ouverture du classeur, Initialisations
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(PathXlsSource)
'on garantit que l'importation se passera bien, également pour l'importation des dates,
'en décochant systématiquement l'option d'affichage xls valeur zéro
xlApp.ActiveWindow.DisplayZeros = False
xlApp.Visible = False
''se positionner sur la feuille active pour y insérer la ligne prévue pour contenu fictif
With xlBook.ActiveSheet
.Rows("2:2").Insert Shift:=xlDown
End With
'écriture de la première ligne technique
For i = 1 To iNbCol + 1
xlBook.ActiveSheet.Cells(2, i).value = aTypes(i - 1) 'sans précision option base, commence à 0
Next
'on connaît et on limite le nombre de colonnes fortement typées,reçu en paramèter de la fonction,
'mais on a le luxe de dépasser par sécurité le nombre de colonnes
'un passage de confort, pour admettre le typage explicite facultatif
For i = 1 To 100
If i <= iNbCol + 1 Then
On Error Resume Next 'pour ne pas faire tomber le programme
If Len(aTypes(i - 1)) > 0 Then
xlBook.ActiveSheet.Cells(2, i).value = aTypes(i - 1) 'sans précision option base, commence à 0
Else
'on récupère le contenu de la ligne 3, ou 4, selon la présence de contenu
If Len(xlBook.ActiveSheet.Cells(3, i).value) > 0 Then
xlBook.ActiveSheet.Cells(2, i).value = xlBook.ActiveSheet.Cells(3, i).value
ElseIf Len(xlBook.ActiveSheet.Cells(3, i).value) = 0 Then
xlBook.ActiveSheet.Cells(2, i).value = xlBook.ActiveSheet.Cells(4, i).value
End If
End If
Else
'on récupère le contenu de la ligne 3, systématiquement, dès que les colonnes en retypage sont traitées
xlBook.ActiveSheet.Cells(2, i).value = xlBook.ActiveSheet.Cells(3, i).value
End If
Next
xlApp.ActiveWorkbook.Save
Set xlSheet = Nothing
xlApp.Quit
Set xlApp = Nothing
'=========================================
'importation proprement dite, sous access
'à adapter selon sa version (2003,2010 etc...)
'==========================================
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel97, NomTableCible, PathXlsSource, True
'et suppression de la ligne technique devenue inutile
Call SuppressionDePremiereLigne(NomTableCible)
If AvecNotification = True Then
infouser = MsgBox("Le fichier " & PathXlsSource & vbCrLf & "a été intégré dans la table " & NomTableCible, vbInformation, "OK")
End If
End Sub
Private Function SuppressionDePremiereLigne(NomTableCible As String)
Dim db As Database
Dim strSQL As String
Set db = CurrentDb
strSQL = _
"Delete from " & _
"( " & _
" select top 1 '" & NomDeColonne(NomTableCible, 1) & "' from '" & NomTableCible & _
") "
db.Execute (strSQL)
db.Close
End Function
Private Function NomDeColonne(NomTable As String, NumCol As Integer)
Dim i As Integer
i = 1
Set db = CurrentDb()
Set rs1 = db.OpenRecordset(NomTable)
Dim fld As DAO.Field
For Each fld In rs1.Fields
If i = NumCol Then
NomDeColonne = fld.Name
Exit For
End If
i = i + 1
Next
Set fld = Nothing
End Function |
