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 |
Partager