Import XML

Bonjour,

Je souhaite importer le contenu d'un grand nombre de petits fichier XML dans
access.
La structure des fichier est toujours +/-identique.
Idéalement pour limiter les données le fichier XML devrait se répartir sur
deux tables pour limiter l'encombrement.

Avez-vous déja travaillé sur ce type de code? Si oui quelques références
seraient bienvenues.

Merci de vos avis
Salut,

J'ai tout un module sur ce sujet mais va falloir mettre les mains dans
le cambouis car c'était du trés spécifique par moment.
Si ça t'interesse ...
Option Compare Database
Option Explicit

Function Decoupe(Nom_Table As String)
Dim db As DAO.Database
Dim Tbl_Def As DAO.TableDef
Dim Str_Source As String
Dim I, J, Nbr_Prod, Nbr_Champ As Integer
Set db = CurrentDb
DoCmd.SetWarnings False
Set Tbl_Def = db.TableDefs(Nom_Table)
Nbr_Prod = Int(Tbl_Def.Fields.Count / 5)
Nbr_Champ = 4
For I = 1 To Nbr_Prod
Str_Source = "SELECT [" & Nom_Table & "].Numéro, "
For J = 1 To Nbr_Champ
Str_Source = Str_Source & "[" & Nom_Table & "].F" & J +
((I - 1) * 5) & " AS Champ" & J & ", "
Next J
Str_Source = Left(Str_Source, Len(Str_Source) - 2) & " INTO
[" & Nom_Table & "_" & I & "]"
Str_Source = Str_Source & " FROM [" & Nom_Table & "];"
DoCmd.RunSQL Str_Source
Str_Source = "delete nz([Champ1],'') AS Expr1,
nz([Champ2],'') AS Expr2, nz([Champ3],'') AS Expr3, nz([Champ4],'') AS
Expr4 "
Str_Source = Str_Source & "FROM [" & Nom_Table & "_" & I & "] "
Str_Source = Str_Source & "WHERE
(((Trim(nz([Champ1],'')))='')) and (((Trim(nz([Champ2],'')))='')) and
(((Trim(nz([Champ3],'')))='')) and (((Trim(nz([Champ4],'')))=''));"
DoCmd.RunSQL Str_Source
Next I
DoCmd.DeleteObject acTable, Nom_Table
Set db = Nothing
End Function

Function test()

Decoupe "68 L132"

End Function

Sub ImportationGlobale(Classeur As String)
Dim appXl As Excel.Application
Dim intNbFeuille As Integer
Dim intIndex As Integer
Dim avarTabFeuille() As Variant
Dim WorkSheet As Excel.WorkSheet
Dim Tdf As TableDef
Dim Nom_Tbl As String
DoCmd.SetWarnings False
Set appXl = CreateObject("Excel.Application")
intNbFeuille = 1
On Error Resume Next
'OUVRE LE FICHIER .XLS ET TROUVE LERS DIFFERENTES FEUILLES
With appXl
.Workbooks.Open Classeur
ReDim avarTabFeuille(.Worksheets.Count)
For Each WorkSheet In .Worksheets
avarTabFeuille(intNbFeuille) = WorkSheet.Name
intNbFeuille = intNbFeuille + 1
Next
.Quit
End With
Set appXl = Nothing
On Error GoTo Erreur
'CREE UNE TABLE LINKEE POUR CHACUNES DES FEUILLES TROUVEES
For intIndex = 1 To UBound(avarTabFeuille)
Nom_Tbl = avarTabFeuille(intIndex)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9,
avarTabFeuille(intIndex), Classeur, False, avarTabFeuille(intIndex) & "!"
DoCmd.RunSQL "ALTER TABLE [" & Nom_Tbl & "] ADD COLUMN [Numéro]
COUNTER"
Decoupe Nom_Tbl
Next
DoCmd.SetWarnings True
Exit Sub
Erreur:
DoCmd.RunSQL "INSERT INTO [Erreur import xls] ( [Nom Fichier],
[Code erreur],[Description] ) values ( '" & Nom_Tbl & "' , " &
Err.Number & " , '" & Replace(Err.Description, "'", Chr$(32)) & "' )"
Resume Next

End Sub

Function ajoute_produit()
'Import des données depuis les tables linkées vers les tables sources
Dim Tdf As TableDef
Dim db As Database
Dim Rst As DAO.Recordset
Dim Str_Sql1, Str_Sql2, Nom_Table As String
Dim Nbr As Integer
Set db = CurrentDb
On Error GoTo Traite_erreur
DoCmd.SetWarnings False
For Each Tdf In db.TableDefs
If InStr(1, Tdf.Name, "_") > 0 And InStr(1, Tdf.Name, "$") = 0 Then
If Tdf.Name <> "Nv_Prod" Then
Nom_Table = Tdf.Name
Str_Sql1 = "SELECT TOP 1, [" & Nom_Table & "].Champ1,
[" & Nom_Table & "].Champ4 FROM [" & Nom_Table & "] where [" & Nom_Table
& "].Champ1 <>null or [" & Nom_Table & "].Champ4 <> null "
DoCmd.DeleteObject acQuery, "Nom Produit"
db.CreateQueryDef "Nom Produit", Str_Sql1
Nbr = Nz(DCount("[champ1]", "Nom Produit"), 0) +
Nz(DCount("[champ4]", "Nom Produit"), 0)
If Nbr > 0 Then
'Ajoute le Nouveau produits Issus du 1er enreg de
la table s'il n'est pas vide
Str_Sql1 = "INSERT INTO Produits ( [Libellé
Produit], [Code Gestion], [Code Commercial], [Code actif], [Code
Segment] ) "
Str_Sql1 = Str_Sql1 + "SELECT
IIf(Trim(nz([Champ1],''))='',[champ4],[champ1]) AS Expr1, '" & Nom_Table
& "' AS Expr2, IIf(Trim(nz([Champ1],''))='',[champ4],[champ1]) AS Expr3,
True AS act, 2 AS Coll "
Str_Sql1 = Str_Sql1 + "FROM [Nom Produit]"

DoCmd.RunSQL Str_Sql1
Else
' Ajoute par défaut le nom de la feuille xls comme
nom de produit
Str_Sql1 = "INSERT INTO Produits ( [Libellé
Produit], [Code Gestion], [Code Commercial], [Code actif], [Code
Segment] ) "
Str_Sql1 = Str_Sql1 & "SELECT '" & Nom_Table & "'
AS Expr1, '" & Nom_Table & "' AS Expr2, '" & Nom_Table & "' AS Expr3,
True AS act, 2 AS Coll "
DoCmd.RunSQL Str_Sql1
End If

' Vide Nv_Prod
DoCmd.OpenQuery "Vide Nv_Prod", acViewNormal, acEdit
' Remplis Nv_Prod avec les éléments de la table
produits importés
Str_Sql2 = "INSERT INTO nv_prod ( Champ1, Champ2,
Champ3, Champ4 ) "
Str_Sql2 = Str_Sql2 & "SELECT [" & Nom_Table &
"].Champ1, [" & Nom_Table & "].Champ2, [" & Nom_Table & "].Champ3, [" &
Nom_Table & "].Champ4 "
Str_Sql2 = Str_Sql2 & "FROM [" & Nom_Table & "]"
DoCmd.RunSQL Str_Sql2
' efface 4 premiers enregistrement de la table Nv_Prod
DoCmd.OpenQuery "efface 4 premiers", acViewNormal, acEdit
' Efface enreg sans RO RC Precisions
DoCmd.OpenQuery "Efface enreg sans RO RC Precisions",
acViewNormal, acEdit
' Ajout actes
DoCmd.OpenQuery "Ajout actes", acViewNormal, acEdit
' ajout produit
DoCmd.OpenQuery "ajout produit", acViewNormal, acEdit
'Debug.Print Nom_Table
End If
End If
Next
GoTo Fin
Traite_erreur:
If Err.Number = 7874 Then
Resume Next
Else
MsgBox "Erreur N° " & Err.Number & " " & Err.Description
End If
Fin:
DoCmd.SetWarnings True
Set db = Nothing
End Function
Sub Import_contenu_repertoire(Dossier As String)
Dim rep, Nom_Tbl As String
'obtient le premier fichier ou répertoire qui est dans "c:"
rep = Dir(Dossier & "*.xls", vbDirectory)
'boucle tant que le répertoire n'a pas été entièrement parcouru
On Error GoTo Erreur
Do While (rep <> "")
'teste si c'est un fichier ou un répertoire
If (GetAttr(Dossier & rep) And vbDirectory) = vbDirectory Then
'MsgBox "Répertoire " & rep
Else
Nom_Tbl = Left(rep, Len(rep) - 4)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9,
Nom_Tbl, Dossier & rep, False ', rep & "!"
DoCmd.RunSQL "ALTER TABLE [" & Nom_Tbl & "] ADD COLUMN [Numéro]
COUNTER"
Decoupe Nom_Tbl
End If
Suite:
'passe à l'élément suivant
rep = Dir
Loop
GoTo Fin
Erreur:
DoCmd.RunSQL "INSERT INTO [Erreur import xls] ( [Nom Fichier],
[Code erreur] ) SELECT '" & Dossier & rep & "' AS Fichier, " &
Err.Number & " AS Erreur" ', '" & Err.Description & "' AS MesErr"
Resume Suite
Fin:
End Sub
Sub main()
'Import d'un fichier excel seul
ImportationGlobale "\SrvaccessTableaux68 l1.xls"
'Import de tous les fichiers d'un répértoire
Import_contenu_repertoire "\SrvaccessTableausud"


End Sub
Function Efface_table_Import()
'Pour faire le ménage !!!
Dim Tdf As TableDef
Dim db As Database
Dim Rst As DAO.Recordset
Dim Nom_Table As String
Set db = CurrentDb
On Error GoTo Traite_erreur
DoCmd.SetWarnings False
For Each Tdf In db.TableDefs
If InStr(1, Tdf.Name, "_") > 0 And InStr(1, Tdf.Name, "$") = 0 Then
If Tdf.Name <> "Nv_Prod" And Tdf.Name <> "Erreur Import
Xls" Then
Nom_Table = Tdf.Name
DoCmd.DeleteObject acTable, Nom_Table
End If
End If
Next
GoTo Fin
Traite_erreur:
If Err.Number = 7874 Then
Resume Next
Else
MsgBox "Erreur N° " & Err.Number & " " & Err.Description
End If
Fin:
DoCmd.SetWarnings True
Set db = Nothing
End Function

Private Sub test2()

Dim db As DAO.Database
Dim Rst_data As DAO.Recordset

Set db = CurrentDb
Set Rst_data = db.OpenRecordset("select [Champs1], [Champs2] from
tarequete;")
If Not Rst_data.EOF Then
Me.Monchamp1 = Rst_data![Champ1]
Me.monchamp2 = Rst_data![Champ2]
End If
Rst_data.Close
Set db = Nothing
End Sub

@+

Bonjour,

Merci pour le code, malheureusement, je ne suis pas un utilisateur assez
avancé que pour pouvoir le modifier.
Mais si j'ai bien compris, il y a une conversion XML vers Excel (XLS) puis
une importation?
Si c'est le cas je devrais éviter cette voie au regard de la longueur de
texte de certains enregistrement qui seront tronqués par Excel.

Je connais la structure des Champs dans les tables destinées à recevoir
l'importation, je pensais au regard du petit menu d'importation, qu'il y
avait une commande "IMPORT XML" simple dans Access 2007.
L'exécution de cette commande ne donne rien, ou plus vraissemblablement je
ne la comprend pas.


Connaissez vous le logiciel:
BESIDE Data Conversion Software
Import Wizard v9.1.1a (Released 17-Sep-2007)?
Y arait-il une solution avec ce soft?

Je continue mes recherches.

Merci

Bonjour,

Je souhaite importer le contenu d'un grand nombre de petits fichier XML dans
access.
La structure des fichier est toujours +/-identique.
Idéalement pour limiter les données le fichier XML devrait se répartir sur
deux tables pour limiter l'encombrement.

Avez-vous déja travaillé sur ce type de code? Si oui quelques références
seraient bienvenues.

Merci de vos avis
Salut,

J'ai tout un module sur ce sujet mais va falloir mettre les mains dans
le cambouis car c'était du trés spécifique par moment.
Si ça t'interesse ...
Option Compare Database
Option Explicit

Function Decoupe(Nom_Table As String)
Dim db As DAO.Database
Dim Tbl_Def As DAO.TableDef
Dim Str_Source As String
Dim I, J, Nbr_Prod, Nbr_Champ As Integer
Set db = CurrentDb
DoCmd.SetWarnings False
Set Tbl_Def = db.TableDefs(Nom_Table)
Nbr_Prod = Int(Tbl_Def.Fields.Count / 5)
Nbr_Champ = 4
For I = 1 To Nbr_Prod
Str_Source = "SELECT [" & Nom_Table & "].Numéro, "
For J = 1 To Nbr_Champ
Str_Source = Str_Source & "[" & Nom_Table & "].F" & J +
((I - 1) * 5) & " AS Champ" & J & ", "
Next J
Str_Source = Left(Str_Source, Len(Str_Source) - 2) & " INTO
[" & Nom_Table & "_" & I & "]"
Str_Source = Str_Source & " FROM [" & Nom_Table & "];"
DoCmd.RunSQL Str_Source
Str_Source = "delete nz([Champ1],'') AS Expr1,
nz([Champ2],'') AS Expr2, nz([Champ3],'') AS Expr3, nz([Champ4],'') AS
Expr4 "
Str_Source = Str_Source & "FROM [" & Nom_Table & "_" & I & "] "
Str_Source = Str_Source & "WHERE
(((Trim(nz([Champ1],'')))='')) and (((Trim(nz([Champ2],'')))='')) and
(((Trim(nz([Champ3],'')))='')) and (((Trim(nz([Champ4],'')))=''));"
DoCmd.RunSQL Str_Source
Next I
DoCmd.DeleteObject acTable, Nom_Table
Set db = Nothing
End Function

Function test()

Decoupe "68 L132"

End Function

Sub ImportationGlobale(Classeur As String)
Dim appXl As Excel.Application
Dim intNbFeuille As Integer
Dim intIndex As Integer
Dim avarTabFeuille() As Variant
Dim WorkSheet As Excel.WorkSheet
Dim Tdf As TableDef
Dim Nom_Tbl As String
DoCmd.SetWarnings False
Set appXl = CreateObject("Excel.Application")
intNbFeuille = 1
On Error Resume Next
'OUVRE LE FICHIER .XLS ET TROUVE LERS DIFFERENTES FEUILLES
With appXl
.Workbooks.Open Classeur
ReDim avarTabFeuille(.Worksheets.Count)
For Each WorkSheet In .Worksheets
avarTabFeuille(intNbFeuille) = WorkSheet.Name
intNbFeuille = intNbFeuille + 1
Next
.Quit
End With
Set appXl = Nothing
On Error GoTo Erreur
'CREE UNE TABLE LINKEE POUR CHACUNES DES FEUILLES TROUVEES
For intIndex = 1 To UBound(avarTabFeuille)
Nom_Tbl = avarTabFeuille(intIndex)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9,
avarTabFeuille(intIndex), Classeur, False, avarTabFeuille(intIndex) & "!"
DoCmd.RunSQL "ALTER TABLE [" & Nom_Tbl & "] ADD COLUMN [Numéro]
COUNTER"
Decoupe Nom_Tbl
Next
DoCmd.SetWarnings True
Exit Sub
Erreur:
DoCmd.RunSQL "INSERT INTO [Erreur import xls] ( [Nom Fichier],
[Code erreur],[Description] ) values ( '" & Nom_Tbl & "' , " &
Err.Number & " , '" & Replace(Err.Description, "'", Chr$(32)) & "' )"
Resume Next

End Sub

Function ajoute_produit()
'Import des données depuis les tables linkées vers les tables sources
Dim Tdf As TableDef
Dim db As Database
Dim Rst As DAO.Recordset
Dim Str_Sql1, Str_Sql2, Nom_Table As String
Dim Nbr As Integer
Set db = CurrentDb
On Error GoTo Traite_erreur
DoCmd.SetWarnings False
For Each Tdf In db.TableDefs
If InStr(1, Tdf.Name, "_") > 0 And InStr(1, Tdf.Name, "$") = 0 Then
If Tdf.Name <> "Nv_Prod" Then
Nom_Table = Tdf.Name
Str_Sql1 = "SELECT TOP 1, [" & Nom_Table & "].Champ1,
[" & Nom_Table & "].Champ4 FROM [" & Nom_Table & "] where [" & Nom_Table
& "].Champ1 <>null or [" & Nom_Table & "].Champ4 <> null "
DoCmd.DeleteObject acQuery, "Nom Produit"
db.CreateQueryDef "Nom Produit", Str_Sql1
Nbr = Nz(DCount("[champ1]", "Nom Produit"), 0) +
Nz(DCount("[champ4]", "Nom Produit"), 0)
If Nbr > 0 Then
'Ajoute le Nouveau produits Issus du 1er enreg de
la table s'il n'est pas vide
Str_Sql1 = "INSERT INTO Produits ( [Libellé
Produit], [Code Gestion], [Code Commercial], [Code actif], [Code
Segment] ) "
Str_Sql1 = Str_Sql1 + "SELECT
IIf(Trim(nz([Champ1],''))='',[champ4],[champ1]) AS Expr1, '" & Nom_Table
& "' AS Expr2, IIf(Trim(nz([Champ1],''))='',[champ4],[champ1]) AS Expr3,
True AS act, 2 AS Coll "
Str_Sql1 = Str_Sql1 + "FROM [Nom Produit]"

DoCmd.RunSQL Str_Sql1
Else
' Ajoute par défaut le nom de la feuille xls comme
nom de produit
Str_Sql1 = "INSERT INTO Produits ( [Libellé
Produit], [Code Gestion], [Code Commercial], [Code actif], [Code
Segment] ) "
Str_Sql1 = Str_Sql1 & "SELECT '" & Nom_Table & "'
AS Expr1, '" & Nom_Table & "' AS Expr2, '" & Nom_Table & "' AS Expr3,
True AS act, 2 AS Coll "
DoCmd.RunSQL Str_Sql1
End If

' Vide Nv_Prod
DoCmd.OpenQuery "Vide Nv_Prod", acViewNormal, acEdit
' Remplis Nv_Prod avec les éléments de la table
produits importés
Str_Sql2 = "INSERT INTO nv_prod ( Champ1, Champ2,
Champ3, Champ4 ) "
Str_Sql2 = Str_Sql2 & "SELECT [" & Nom_Table &
"].Champ1, [" & Nom_Table & "].Champ2, [" & Nom_Table & "].Champ3, [" &
Nom_Table & "].Champ4 "
Str_Sql2 = Str_Sql2 & "FROM [" & Nom_Table & "]"
DoCmd.RunSQL Str_Sql2
' efface 4 premiers enregistrement de la table Nv_Prod
DoCmd.OpenQuery "efface 4 premiers", acViewNormal, acEdit
' Efface enreg sans RO RC Precisions
DoCmd.OpenQuery "Efface enreg sans RO RC Precisions",
acViewNormal, acEdit
' Ajout actes
DoCmd.OpenQuery "Ajout actes", acViewNormal, acEdit
' ajout produit
DoCmd.OpenQuery "ajout produit", acViewNormal, acEdit
'Debug.Print Nom_Table
End If
End If
Next
GoTo Fin
Traite_erreur:
If Err.Number = 7874 Then
Resume Next
Else
MsgBox "Erreur N° " & Err.Number & " " & Err.Description
End If
Fin:
DoCmd.SetWarnings True
Set db = Nothing
End Function
Sub Import_contenu_repertoire(Dossier As String)
Dim rep, Nom_Tbl As String
'obtient le premier fichier ou répertoire qui est dans "c:"
rep = Dir(Dossier & "*.xls", vbDirectory)
'boucle tant que le répertoire n'a pas été entièrement parcouru
On Error GoTo Erreur
Do While (rep <> "")
'teste si c'est un fichier ou un répertoire
If (GetAttr(Dossier & rep) And vbDirectory) = vbDirectory Then
'MsgBox "Répertoire " & rep
Else
Nom_Tbl = Left(rep, Len(rep) - 4)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9,
Nom_Tbl, Dossier & rep, False ', rep & "!"
DoCmd.RunSQL "ALTER TABLE [" & Nom_Tbl & "] ADD COLUMN [Numéro]
COUNTER"
Decoupe Nom_Tbl
End If
Suite:
'passe à l'élément suivant
rep = Dir
Loop
GoTo Fin
Erreur:
DoCmd.RunSQL "INSERT INTO [Erreur import xls] ( [Nom Fichier],
[Code erreur] ) SELECT '" & Dossier & rep & "' AS Fichier, " &
Err.Number & " AS Erreur" ', '" & Err.Description & "' AS MesErr"
Resume Suite
Fin:
End Sub
Sub main()
'Import d'un fichier excel seul
ImportationGlobale "\SrvaccessTableaux68 l1.xls"
'Import de tous les fichiers d'un répértoire
Import_contenu_repertoire "\SrvaccessTableausud"


End Sub
Function Efface_table_Import()
'Pour faire le ménage !!!
Dim Tdf As TableDef
Dim db As Database
Dim Rst As DAO.Recordset
Dim Nom_Table As String
Set db = CurrentDb
On Error GoTo Traite_erreur
DoCmd.SetWarnings False
For Each Tdf In db.TableDefs
If InStr(1, Tdf.Name, "_") > 0 And InStr(1, Tdf.Name, "$") = 0 Then
If Tdf.Name <> "Nv_Prod" And Tdf.Name <> "Erreur Import
Xls" Then
Nom_Table = Tdf.Name
DoCmd.DeleteObject acTable, Nom_Table
End If
End If
Next
GoTo Fin
Traite_erreur:
If Err.Number = 7874 Then
Resume Next
Else
MsgBox "Erreur N° " & Err.Number & " " & Err.Description
End If
Fin:
DoCmd.SetWarnings True
Set db = Nothing
End Function

Private Sub test2()

Dim db As DAO.Database
Dim Rst_data As DAO.Recordset

Set db = CurrentDb
Set Rst_data = db.OpenRecordset("select [Champs1], [Champs2] from
tarequete;")
If Not Rst_data.EOF Then
Me.Monchamp1 = Rst_data![Champ1]
Me.monchamp2 = Rst_data![Champ2]
End If
Rst_data.Close
Set db = Nothing
End Sub

@+

Bonjour,

Merci pour le code, malheureusement, je ne suis pas un utilisateur assez
avancé que pour pouvoir le modifier.
Mais si j'ai bien compris, il y a une conversion XML vers Excel (XLS) puis
une importation?
Si c'est le cas je devrais éviter cette voie au regard de la longueur de
texte de certains enregistrement qui seront tronqués par Excel.

Je connais la structure des Champs dans les tables destinées à recevoir
l'importation, je pensais au regard du petit menu d'importation, qu'il y
avait une commande "IMPORT XML" simple dans Access 2007.
L'exécution de cette commande ne donne rien, ou plus vraissemblablement je
ne la comprend pas.


Connaissez vous le logiciel:
BESIDE Data Conversion Software
Import Wizard v9.1.1a (Released 17-Sep-2007)?
Y arait-il une solution avec ce soft?

Je continue mes recherches.

Merci

Bonjour,

Je souhaite importer le contenu d'un grand nombre de petits fichier XML dans
access.
La structure des fichier est toujours +/-identique.
Idéalement pour limiter les données le fichier XML devrait se répartir sur
deux tables pour limiter l'encombrement.

Avez-vous déja travaillé sur ce type de code? Si oui quelques références
seraient bienvenues.

Merci de vos avis
Salut,

J'ai tout un module sur ce sujet mais va falloir mettre les mains dans
le cambouis car c'était du trés spécifique par moment.
Si ça t'interesse ...
Option Compare Database
Option Explicit

Function Decoupe(Nom_Table As String)
Dim db As DAO.Database
Dim Tbl_Def As DAO.TableDef
Dim Str_Source As String
Dim I, J, Nbr_Prod, Nbr_Champ As Integer
Set db = CurrentDb
DoCmd.SetWarnings False
Set Tbl_Def = db.TableDefs(Nom_Table)
Nbr_Prod = Int(Tbl_Def.Fields.Count / 5)
Nbr_Champ = 4
For I = 1 To Nbr_Prod
Str_Source = "SELECT [" & Nom_Table & "].Numéro, "
For J = 1 To Nbr_Champ
Str_Source = Str_Source & "[" & Nom_Table & "].F" & J +
((I - 1) * 5) & " AS Champ" & J & ", "
Next J
Str_Source = Left(Str_Source, Len(Str_Source) - 2) & " INTO
[" & Nom_Table & "_" & I & "]"
Str_Source = Str_Source & " FROM [" & Nom_Table & "];"
DoCmd.RunSQL Str_Source
Str_Source = "delete nz([Champ1],'') AS Expr1,
nz([Champ2],'') AS Expr2, nz([Champ3],'') AS Expr3, nz([Champ4],'') AS
Expr4 "
Str_Source = Str_Source & "FROM [" & Nom_Table & "_" & I & "] "
Str_Source = Str_Source & "WHERE
(((Trim(nz([Champ1],'')))='')) and (((Trim(nz([Champ2],'')))='')) and
(((Trim(nz([Champ3],'')))='')) and (((Trim(nz([Champ4],'')))=''));"
DoCmd.RunSQL Str_Source
Next I
DoCmd.DeleteObject acTable, Nom_Table
Set db = Nothing
End Function

Function test()

Decoupe "68 L132"

End Function

Sub ImportationGlobale(Classeur As String)
Dim appXl As Excel.Application
Dim intNbFeuille As Integer
Dim intIndex As Integer
Dim avarTabFeuille() As Variant
Dim WorkSheet As Excel.WorkSheet
Dim Tdf As TableDef
Dim Nom_Tbl As String
DoCmd.SetWarnings False
Set appXl = CreateObject("Excel.Application")
intNbFeuille = 1
On Error Resume Next
'OUVRE LE FICHIER .XLS ET TROUVE LERS DIFFERENTES FEUILLES
With appXl
.Workbooks.Open Classeur
ReDim avarTabFeuille(.Worksheets.Count)
For Each WorkSheet In .Worksheets
avarTabFeuille(intNbFeuille) = WorkSheet.Name
intNbFeuille = intNbFeuille + 1
Next
.Quit
End With
Set appXl = Nothing
On Error GoTo Erreur
'CREE UNE TABLE LINKEE POUR CHACUNES DES FEUILLES TROUVEES
For intIndex = 1 To UBound(avarTabFeuille)
Nom_Tbl = avarTabFeuille(intIndex)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9,
avarTabFeuille(intIndex), Classeur, False, avarTabFeuille(intIndex) & "!"
DoCmd.RunSQL "ALTER TABLE [" & Nom_Tbl & "] ADD COLUMN [Numéro]
COUNTER"
Decoupe Nom_Tbl
Next
DoCmd.SetWarnings True
Exit Sub
Erreur:
DoCmd.RunSQL "INSERT INTO [Erreur import xls] ( [Nom Fichier],
[Code erreur],[Description] ) values ( '" & Nom_Tbl & "' , " &
Err.Number & " , '" & Replace(Err.Description, "'", Chr$(32)) & "' )"
Resume Next

End Sub

Function ajoute_produit()
'Import des données depuis les tables linkées vers les tables sources
Dim Tdf As TableDef
Dim db As Database
Dim Rst As DAO.Recordset
Dim Str_Sql1, Str_Sql2, Nom_Table As String
Dim Nbr As Integer
Set db = CurrentDb
On Error GoTo Traite_erreur
DoCmd.SetWarnings False
For Each Tdf In db.TableDefs
If InStr(1, Tdf.Name, "_") > 0 And InStr(1, Tdf.Name, "$") = 0 Then
If Tdf.Name <> "Nv_Prod" Then
Nom_Table = Tdf.Name
Str_Sql1 = "SELECT TOP 1, [" & Nom_Table & "].Champ1,
[" & Nom_Table & "].Champ4 FROM [" & Nom_Table & "] where [" & Nom_Table
& "].Champ1 <>null or [" & Nom_Table & "].Champ4 <> null "
DoCmd.DeleteObject acQuery, "Nom Produit"
db.CreateQueryDef "Nom Produit", Str_Sql1
Nbr = Nz(DCount("[champ1]", "Nom Produit"), 0) +
Nz(DCount("[champ4]", "Nom Produit"), 0)
If Nbr > 0 Then
'Ajoute le Nouveau produits Issus du 1er enreg de
la table s'il n'est pas vide
Str_Sql1 = "INSERT INTO Produits ( [Libellé
Produit], [Code Gestion], [Code Commercial], [Code actif], [Code
Segment] ) "
Str_Sql1 = Str_Sql1 + "SELECT
IIf(Trim(nz([Champ1],''))='',[champ4],[champ1]) AS Expr1, '" & Nom_Table
& "' AS Expr2, IIf(Trim(nz([Champ1],''))='',[champ4],[champ1]) AS Expr3,
True AS act, 2 AS Coll "
Str_Sql1 = Str_Sql1 + "FROM [Nom Produit]"

DoCmd.RunSQL Str_Sql1
Else
' Ajoute par défaut le nom de la feuille xls comme
nom de produit
Str_Sql1 = "INSERT INTO Produits ( [Libellé
Produit], [Code Gestion], [Code Commercial], [Code actif], [Code
Segment] ) "
Str_Sql1 = Str_Sql1 & "SELECT '" & Nom_Table & "'
AS Expr1, '" & Nom_Table & "' AS Expr2, '" & Nom_Table & "' AS Expr3,
True AS act, 2 AS Coll "
DoCmd.RunSQL Str_Sql1
End If

' Vide Nv_Prod
DoCmd.OpenQuery "Vide Nv_Prod", acViewNormal, acEdit
' Remplis Nv_Prod avec les éléments de la table
produits importés
Str_Sql2 = "INSERT INTO nv_prod ( Champ1, Champ2,
Champ3, Champ4 ) "
Str_Sql2 = Str_Sql2 & "SELECT [" & Nom_Table &
"].Champ1, [" & Nom_Table & "].Champ2, [" & Nom_Table & "].Champ3, [" &
Nom_Table & "].Champ4 "
Str_Sql2 = Str_Sql2 & "FROM [" & Nom_Table & "]"
DoCmd.RunSQL Str_Sql2
' efface 4 premiers enregistrement de la table Nv_Prod
DoCmd.OpenQuery "efface 4 premiers", acViewNormal, acEdit
' Efface enreg sans RO RC Precisions
DoCmd.OpenQuery "Efface enreg sans RO RC Precisions",
acViewNormal, acEdit
' Ajout actes
DoCmd.OpenQuery "Ajout actes", acViewNormal, acEdit
' ajout produit
DoCmd.OpenQuery "ajout produit", acViewNormal, acEdit
'Debug.Print Nom_Table
End If
End If
Next
GoTo Fin
Traite_erreur:
If Err.Number = 7874 Then
Resume Next
Else
MsgBox "Erreur N° " & Err.Number & " " & Err.Description
End If
Fin:
DoCmd.SetWarnings True
Set db = Nothing
End Function
Sub Import_contenu_repertoire(Dossier As String)
Dim rep, Nom_Tbl As String
'obtient le premier fichier ou répertoire qui est dans "c:"
rep = Dir(Dossier & "*.xls", vbDirectory)
'boucle tant que le répertoire n'a pas été entièrement parcouru
On Error GoTo Erreur
Do While (rep <> "")
'teste si c'est un fichier ou un répertoire
If (GetAttr(Dossier & rep) And vbDirectory) = vbDirectory Then
'MsgBox "Répertoire " & rep
Else
Nom_Tbl = Left(rep, Len(rep) - 4)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9,
Nom_Tbl, Dossier & rep, False ', rep & "!"
DoCmd.RunSQL "ALTER TABLE [" & Nom_Tbl & "] ADD COLUMN [Numéro]
COUNTER"
Decoupe Nom_Tbl
End If
Suite:
'passe à l'élément suivant
rep = Dir
Loop
GoTo Fin
Erreur:
DoCmd.RunSQL "INSERT INTO [Erreur import xls] ( [Nom Fichier],
[Code erreur] ) SELECT '" & Dossier & rep & "' AS Fichier, " &
Err.Number & " AS Erreur" ', '" & Err.Description & "' AS MesErr"
Resume Suite
Fin:
End Sub
Sub main()
'Import d'un fichier excel seul
ImportationGlobale "\SrvaccessTableaux68 l1.xls"
'Import de tous les fichiers d'un répértoire
Import_contenu_repertoire "\SrvaccessTableausud"


End Sub
Function Efface_table_Import()
'Pour faire le ménage !!!
Dim Tdf As TableDef
Dim db As Database
Dim Rst As DAO.Recordset
Dim Nom_Table As String
Set db = CurrentDb
On Error GoTo Traite_erreur
DoCmd.SetWarnings False
For Each Tdf In db.TableDefs
If InStr(1, Tdf.Name, "_") > 0 And InStr(1, Tdf.Name, "$") = 0 Then
If Tdf.Name <> "Nv_Prod" And Tdf.Name <> "Erreur Import
Xls" Then
Nom_Table = Tdf.Name
DoCmd.DeleteObject acTable, Nom_Table
End If
End If
Next
GoTo Fin
Traite_erreur:
If Err.Number = 7874 Then
Resume Next
Else
MsgBox "Erreur N° " & Err.Number & " " & Err.Description
End If
Fin:
DoCmd.SetWarnings True
Set db = Nothing
End Function

Private Sub test2()

Dim db As DAO.Database
Dim Rst_data As DAO.Recordset

Set db = CurrentDb
Set Rst_data = db.OpenRecordset("select [Champs1], [Champs2] from
tarequete;")
If Not Rst_data.EOF Then
Me.Monchamp1 = Rst_data![Champ1]
Me.monchamp2 = Rst_data![Champ2]
End If
Rst_data.Close
Set db = Nothing
End Sub

@+

RE

Autant pour moi , ce module permet d'importer effectivement des feuilles
excel sous forme de tables liées. Puis de les découper et de répartir
les infos qu'elles contiennent dans diverses tables.
Rien a voir avec le formal XML :-(
Mes excuses ...
@+

Sans faire appel à une rédaction longue j'ai trouvé un soft capable de
générer les tables et liaisons
Exult xml_to_mdb
il existe aussi une solution gratuite
XML-2-MDB 1.1 qui souffre d'un problème de codage des caractères accentués.

Bonjour,

Merci pour le code, malheureusement, je ne suis pas un utilisateur assez
avancé que pour pouvoir le modifier.
Mais si j'ai bien compris, il y a une conversion XML vers Excel (XLS) puis
une importation?
Si c'est le cas je devrais éviter cette voie au regard de la longueur de
texte de certains enregistrement qui seront tronqués par Excel.

Je connais la structure des Champs dans les tables destinées à recevoir
l'importation, je pensais au regard du petit menu d'importation, qu'il y
avait une commande "IMPORT XML" simple dans Access 2007.
L'exécution de cette commande ne donne rien, ou plus vraissemblablement je
ne la comprend pas.


Connaissez vous le logiciel:
BESIDE Data Conversion Software
Import Wizard v9.1.1a (Released 17-Sep-2007)?
Y arait-il une solution avec ce soft?

Je continue mes recherches.

Merci

Bonjour,

Je souhaite importer le contenu d'un grand nombre de petits fichier XML dans
access.
La structure des fichier est toujours +/-identique.
Idéalement pour limiter les données le fichier XML devrait se répartir sur
deux tables pour limiter l'encombrement.

Avez-vous déja travaillé sur ce type de code? Si oui quelques références
seraient bienvenues.

Merci de vos avis
Salut,

J'ai tout un module sur ce sujet mais va falloir mettre les mains dans
le cambouis car c'était du trés spécifique par moment.
Si ça t'interesse ...
Option Compare Database
Option Explicit

Function Decoupe(Nom_Table As String)
Dim db As DAO.Database
Dim Tbl_Def As DAO.TableDef
Dim Str_Source As String
Dim I, J, Nbr_Prod, Nbr_Champ As Integer
Set db = CurrentDb
DoCmd.SetWarnings False
Set Tbl_Def = db.TableDefs(Nom_Table)
Nbr_Prod = Int(Tbl_Def.Fields.Count / 5)
Nbr_Champ = 4
For I = 1 To Nbr_Prod
Str_Source = "SELECT [" & Nom_Table & "].Numéro, "
For J = 1 To Nbr_Champ
Str_Source = Str_Source & "[" & Nom_Table & "].F" & J +
((I - 1) * 5) & " AS Champ" & J & ", "
Next J
Str_Source = Left(Str_Source, Len(Str_Source) - 2) & " INTO
[" & Nom_Table & "_" & I & "]"
Str_Source = Str_Source & " FROM [" & Nom_Table & "];"
DoCmd.RunSQL Str_Source
Str_Source = "delete nz([Champ1],'') AS Expr1,
nz([Champ2],'') AS Expr2, nz([Champ3],'') AS Expr3, nz([Champ4],'') AS
Expr4 "
Str_Source = Str_Source & "FROM [" & Nom_Table & "_" & I & "] "
Str_Source = Str_Source & "WHERE
(((Trim(nz([Champ1],'')))='')) and (((Trim(nz([Champ2],'')))='')) and
(((Trim(nz([Champ3],'')))='')) and (((Trim(nz([Champ4],'')))=''));"
DoCmd.RunSQL Str_Source
Next I
DoCmd.DeleteObject acTable, Nom_Table
Set db = Nothing
End Function

Function test()

Decoupe "68 L132"

End Function

Sub ImportationGlobale(Classeur As String)
Dim appXl As Excel.Application
Dim intNbFeuille As Integer
Dim intIndex As Integer
Dim avarTabFeuille() As Variant
Dim WorkSheet As Excel.WorkSheet
Dim Tdf As TableDef
Dim Nom_Tbl As String
DoCmd.SetWarnings False
Set appXl = CreateObject("Excel.Application")
intNbFeuille = 1
On Error Resume Next
'OUVRE LE FICHIER .XLS ET TROUVE LERS DIFFERENTES FEUILLES
With appXl
.Workbooks.Open Classeur
ReDim avarTabFeuille(.Worksheets.Count)
For Each WorkSheet In .Worksheets
avarTabFeuille(intNbFeuille) = WorkSheet.Name
intNbFeuille = intNbFeuille + 1
Next
.Quit
End With
Set appXl = Nothing
On Error GoTo Erreur
'CREE UNE TABLE LINKEE POUR CHACUNES DES FEUILLES TROUVEES
For intIndex = 1 To UBound(avarTabFeuille)
Nom_Tbl = avarTabFeuille(intIndex)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9,
avarTabFeuille(intIndex), Classeur, False, avarTabFeuille(intIndex) & "!"
DoCmd.RunSQL "ALTER TABLE [" & Nom_Tbl & "] ADD COLUMN [Numéro]
COUNTER"
Decoupe Nom_Tbl
Next
DoCmd.SetWarnings True
Exit Sub
Erreur:
DoCmd.RunSQL "INSERT INTO [Erreur import xls] ( [Nom Fichier],
[Code erreur],[Description] ) values ( '" & Nom_Tbl & "' , " &
Err.Number & " , '" & Replace(Err.Description, "'", Chr$(32)) & "' )"
Resume Next

End Sub

Function ajoute_produit()
'Import des données depuis les tables linkées vers les tables sources
Dim Tdf As TableDef
Dim db As Database
Dim Rst As DAO.Recordset
Dim Str_Sql1, Str_Sql2, Nom_Table As String
Dim Nbr As Integer
Set db = CurrentDb
On Error GoTo Traite_erreur
DoCmd.SetWarnings False
For Each Tdf In db.TableDefs
If InStr(1, Tdf.Name, "_") > 0 And InStr(1, Tdf.Name, "$") = 0 Then
If Tdf.Name <> "Nv_Prod" Then
Nom_Table = Tdf.Name
Str_Sql1 = "SELECT TOP 1, [" & Nom_Table & "].Champ1,
[" & Nom_Table & "].Champ4 FROM [" & Nom_Table & "] where [" & Nom_Table
& "].Champ1 <>null or [" & Nom_Table & "].Champ4 <> null "
DoCmd.DeleteObject acQuery, "Nom Produit"
db.CreateQueryDef "Nom Produit", Str_Sql1
Nbr = Nz(DCount("[champ1]", "Nom Produit"), 0) +
Nz(DCount("[champ4]", "Nom Produit"), 0)
If Nbr > 0 Then
'Ajoute le Nouveau produits Issus du 1er enreg de
la table s'il n'est pas vide
Str_Sql1 = "INSERT INTO Produits ( [Libellé
Produit], [Code Gestion], [Code Commercial], [Code actif], [Code
Segment] ) "
Str_Sql1 = Str_Sql1 + "SELECT
IIf(Trim(nz([Champ1],''))='',[champ4],[champ1]) AS Expr1, '" & Nom_Table
& "' AS Expr2, IIf(Trim(nz([Champ1],''))='',[champ4],[champ1]) AS Expr3,
True AS act, 2 AS Coll "
Str_Sql1 = Str_Sql1 + "FROM [Nom Produit]"

DoCmd.RunSQL Str_Sql1
Else
' Ajoute par défaut le nom de la feuille xls comme
nom de produit
Str_Sql1 = "INSERT INTO Produits ( [Libellé
Produit], [Code Gestion], [Code Commercial], [Code actif], [Code
Segment] ) "
Str_Sql1 = Str_Sql1 & "SELECT '" & Nom_Table & "'
AS Expr1, '" & Nom_Table & "' AS Expr2, '" & Nom_Table & "' AS Expr3,
True AS act, 2 AS Coll "
DoCmd.RunSQL Str_Sql1
End If

' Vide Nv_Prod
DoCmd.OpenQuery "Vide Nv_Prod", acViewNormal, acEdit
' Remplis Nv_Prod avec les éléments de la table
produits importés
Str_Sql2 = "INSERT INTO nv_prod ( Champ1, Champ2,
Champ3, Champ4 ) "
Str_Sql2 = Str_Sql2 & "SELECT [" & Nom_Table &
"].Champ1, [" & Nom_Table & "].Champ2, [" & Nom_Table & "].Champ3, [" &
Nom_Table & "].Champ4 "
Str_Sql2 = Str_Sql2 & "FROM [" & Nom_Table & "]"
DoCmd.RunSQL Str_Sql2
' efface 4 premiers enregistrement de la table Nv_Prod
DoCmd.OpenQuery "efface 4 premiers", acViewNormal, acEdit
' Efface enreg sans RO RC Precisions
DoCmd.OpenQuery "Efface enreg sans RO RC Precisions",
acViewNormal, acEdit
' Ajout actes
DoCmd.OpenQuery "Ajout actes", acViewNormal, acEdit
' ajout produit
DoCmd.OpenQuery "ajout produit", acViewNormal, acEdit
'Debug.Print Nom_Table
End If
End If
Next
GoTo Fin
Traite_erreur:
If Err.Number = 7874 Then
Resume Next
Else
MsgBox "Erreur N° " & Err.Number & " " & Err.Description
End If
Fin:
DoCmd.SetWarnings True
Set db = Nothing
End Function
Sub Import_contenu_repertoire(Dossier As String)
Dim rep, Nom_Tbl As String
'obtient le premier fichier ou répertoire qui est dans "c:"
rep = Dir(Dossier & "*.xls", vbDirectory)
'boucle tant que le répertoire n'a pas été entièrement parcouru
On Error GoTo Erreur
Do While (rep <> "")
'teste si c'est un fichier ou un répertoire
If (GetAttr(Dossier & rep) And vbDirectory) = vbDirectory Then
'MsgBox "Répertoire " & rep
Else
Nom_Tbl = Left(rep, Len(rep) - 4)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9,
Nom_Tbl, Dossier & rep, False ', rep & "!"
DoCmd.RunSQL "ALTER TABLE [" & Nom_Tbl & "] ADD COLUMN [Numéro]
COUNTER"
Decoupe Nom_Tbl
End If
Suite:
'passe à l'élément suivant
rep = Dir
Loop
GoTo Fin
Erreur:
DoCmd.RunSQL "INSERT INTO [Erreur import xls] ( [Nom Fichier],
[Code erreur] ) SELECT '" & Dossier & rep & "' AS Fichier, " &
Err.Number & " AS Erreur" ', '" & Err.Description & "' AS MesErr"
Resume Suite
Fin:
End Sub
Sub main()
'Import d'un fichier excel seul
ImportationGlobale "\SrvaccessTableaux68 l1.xls"
'Import de tous les fichiers d'un répértoire
Import_contenu_repertoire "\SrvaccessTableausud"


End Sub
Function Efface_table_Import()
'Pour faire le ménage !!!
Dim Tdf As TableDef
Dim db As Database
Dim Rst As DAO.Recordset
Dim Nom_Table As String
Set db = CurrentDb
On Error GoTo Traite_erreur
DoCmd.SetWarnings False
For Each Tdf In db.TableDefs
If InStr(1, Tdf.Name, "_") > 0 And InStr(1, Tdf.Name, "$") = 0 Then
If Tdf.Name <> "Nv_Prod" And Tdf.Name <> "Erreur Import
Xls" Then
Nom_Table = Tdf.Name
DoCmd.DeleteObject acTable, Nom_Table
End If
End If
Next
GoTo Fin
Traite_erreur:
If Err.Number = 7874 Then
Resume Next
Else
MsgBox "Erreur N° " & Err.Number & " " & Err.Description
End If
Fin:
DoCmd.SetWarnings True
Set db = Nothing
End Function

Private Sub test2()

Dim db As DAO.Database
Dim Rst_data As DAO.Recordset

Set db = CurrentDb
Set Rst_data = db.OpenRecordset("select [Champs1], [Champs2] from
tarequete;")
If Not Rst_data.EOF Then
Me.Monchamp1 = Rst_data![Champ1]
Me.monchamp2 = Rst_data![Champ2]
End If
Rst_data.Close
Set db = Nothing
End Sub

@+

RE

Salut,

A titre info, Microsoft propose un outil pour lire des fichiers XML :
http://download.microsoft.com/download/c/7/5/c75d4b79-35ad-4ae1-acbe-9ba7 aa44d1c2/xmlsdk.msi

Début Novembre l'année dernière j'ai essayé en vain d e m'y frotter,
(voir newsgroup microsoft.public.fr.xml) et comme ensuite j'ai eu une
formation .Net qui inclut des outils intégrés je n'ai guèr e insisté.

C'est vrai que ça pourrait être intéressant de voir si je m'en sortirais
mieux maintenant, si je trouve un moment.
___________________________________
RAF a écrit, le 15/12/2007 21:42 :

Bonjour,

Je souhaite importer le contenu d'un grand nombre de petits fichier XML dans
access.
La structure des fichier est toujours +/-identique.
Idéalement pour limiter les données le fichier XML devrait se répartir sur
deux tables pour limiter l'encombrement.

Avez-vous déja travaillé sur ce type de code? Si oui quelques références
seraient bienvenues.

Merci de vos avis