Cette macro réalise un import de données XML dans un document writer.
Le dossier (https://forum.openoffice.org/fr/ci-join ... 030253.zip) contient deux documents odt avec les fichiers XML qui vont avec. Le code de la macro publié à la fin, est également dans le fichier xml_import.txt et fonctionne avec les documents cités précedemment.
Pour tester la macro, il faut placer ces documents odt et XML dans un dossier et indiquer le chemin vers ce dossier dans la macro. Il faut modifier à cet effet la ligne Dossier="C:\macro\" de la macro.
On peut lancer la macro grâce à l'EDI d'Openoffice ou lancer la macro en ligne de commande avec comme paramètre le nom du fichier XML et le nom du document odt.
Ex : "C:\Program Files\OpenOffice.org 2.2\program\swriter.exe" "macro:///Standard.xml_import.Main("bordereau.odt","bordereau.xml")"
(la macro est dans la bibliothèque standard et s'appelle xml_import)
Pour l'instant la macro ouvre le document odt et importe les données XML dedans mais elle peut également ouvrir le document odt en mode caché et l'imprimer automatiquement, certaines lignes doivent être décommentées, cela est spécifié dans la macro.
Voilà en quelques mots comment ça marche : pour récupérer par exemple la valeur de l'attribut nom du noeud Client <Client nom="truc"> on écrit un champ de données : {*Client/nom*} dans le document odt. Cela fonctionne quels que soient les noeuds parents du noeud.
Pour récupérer des données XML de tous les noeuds de même nom, il faut écrire les champs de données dans les commentaires du document (Menu : Fichier/Propriétés/onglet Description). Dans ces champs de données, il faut spécifier comment l'importation doit s'effectuer dans le tableau(dans certaines cellules ...). Ceci est précisé dans le fichier lisez-moi.odt
La macro ne peut récupérer que des valeurs d'attributs mais il ne doit pas être difficile de récupérer les données textuelles entre les balises.
Encore un grand merci à tous ceux qui ont répondu à mes questions sur ce forum et ont permis que je réalise cette macro !!!
Code : Tout sélectionner
'Sources :
'Programmation OpenOffice.org Macros OOoBASIC et API, éditions Eyrolles
'Pdf d'Andrew Pitonyak : http://www.pitonyak.org/AndrewMacro.odt et
'http://fr.openoffice.org/Documentation/Guides/Andrew5.pdf (version française moins récente)
'Forum OpenOffice.org : http://www.forum-openoffice.org/forum/
'Variables doivent être déclarées :
option explicit
private MonDoc As Object
private TabloValeurAttr(0) As String
private UBoundNew As Double
private oXml As Object
private ValeurAttr As String
private MonoEnreg
private NbTabloInit
'A la place de lancer cette macro en ligne de commande :
Sub EnvoieDonnesMain
Main("bordereau.odt","bordereau.xml")
Main("uti.odt","uti.xml")
End Sub
Sub Main(oUrl As String, BaseXml As String)
Dim oAdr As String, FichierXml As String, UrlXml As String
Dim oSFA As Object, oInpStream As Object, oDB As Object
Dim propFich(0) As New com.sun.star.beans.PropertyValue
Dim Dossier As String
'Dossier dans lequel les documents .odt et les fichiers .xml sont présents :
Dossier="C:\macro\"
oAdr=ConvertToURL(Dossier+oUrl)
'Pour l'impression(par défaut sur l'imprimante PDFCreator), ces lignes doivent être décommentées :
'propFich(0).Name = "Hidden"
'propFich(0).Value = true
MonDoc = StarDesktop.LoadComponentFromURL(oAdr,"_blank",0,propFich())
FichierXml = Dossier+BaseXml
UrlXml = ConvertToURL( FichierXml )
oSFA = createUNOService ("com.sun.star.ucb.SimpleFileAccess")
oInpStream = oSFA.openFileRead(UrlXml)
oDB = createUnoService("com.sun.star.xml.dom.DocumentBuilder")
oXml = oDB.parse(oInpStream)
oInpStream.closeInput
Recherche
RecupTexteDescri
'Pour l'impression, décommentez ces deux lignes :
'Impression
'attenteFin
'MonDoc.close(True)
End Sub
'Dans le document, recherche de tous les éléments de type {* ... *}
Sub Recherche
Dim vOpenSearch, vCloseSearch 'Ouvre et ferme les délimiteurs
Dim vOpenFound, vCloseFound 'Ouvre et ferme les objets trouvés
Dim Attrs As String
' Création d'un descripteur depuis le document où la recherche est effectuée
vOpenSearch = MonDoc.createSearchDescriptor()
vCloseSearch = MonDoc.createSearchDescriptor()
' Indique le texte à chercher.
vOpenSearch.SearchString = "{*"
vCloseSearch.SearchString = "*}"
' Trouve le délimiteur ouvrant
vOpenFound = MonDoc.findFirst(vOpenSearch)
Do While Not IsNull(vOpenFound)
'Recherche le délimiteur fermant le plus proche du début
vCloseFound = MonDoc.findNext( vOpenFound.End, vCloseSearch)
If IsNull(vCloseFound) Then
Print "Un {* mais pas de *}"
Exit Do
Else
' Sélection du texte entre les délimiteurs
vOpenFound.gotoRange(vCloseFound, True)
Attrs=vOpenFound.getString()
Decoupe(Attrs)
'Mono-enregistrement : on remplace le texte trouvé par la valeur de l'attribut correspondant
if MonoEnreg=1 then
vOpenFound.setString(ValeurAttr)
End if
'On continue la recherche
vOpenFound = MonDoc.findNext( vOpenFound.End, vOpenSearch)
End If
Loop
End Sub
'Récupération du texte dans Fichier/Propriétés/description du document
Sub RecupTexteDescri
Dim mesInfos As Object
Dim TousChamps As String, resu() As String, NbZoneMax As String
Dim x As Integer
mesInfos=MonDoc.documentInfo
TousChamps=mesInfos.Description
'Attention : dans l'état des choses, il ne peut y avoir que 20 zones au plus de champs {* ... *} définis.
NbZoneMax=20
resu=Split(TousChamps," ",NbZoneMax)
for x = LBound(resu) to Ubound(resu)
Decoupe(resu(x))
next
End Sub
'Découpe de l'élément {* .../... *} suivant le slash
Sub Decoupe(Attrs as String)
Dim Cible As String, resu() As String, noeud As String, attr As String
Dim x As Integer
Cible=Attrs
resu=Split(Cible,"/",2)
for x = LBound(resu) to UBound(resu)
noeud=resu(0)
attr=resu(1)
next
noeud=join(split(noeud, "{*"), "")
attr=join(split(attr, "*}"), "")
TestsTypeNoeudAttr(noeud,attr,Cible)
End Sub
'Tests de l'élément avant le slash(noeud) et après le slash(attr). L'ensemble : Cible
'Ces tests nous indiquent comment traiter chaque champ {* *}
Sub TestsTypeNoeudAttr(noeud As String,attr As String, Cible As String)
Dim TestEtNoeud,TestEtAttr,TestParteses As Integer
Dim TxtMettre As String, noeud2 As String
Dim resu0() As String, resu1() As String, resu2() As String, lereste As String, resu21() As String
Dim NomTableau As String, NomCellule As String, InfoCell As String
Dim i As Integer, j As Integer, k As Integer
'Renvoie 0 si l'élément & n'est pas trouvé autrement renvoie la position de l'élément :
TestEtNoeud=Instr(noeud,"&")
TestEtAttr=Instr(attr,"&")
'De la même façon ...
TestParteses=Instr(attr,"(")
'dans le cas d'un mono-enregistrement :
if TestEtAttr=0 then
MonoEnreg=1
Dom(noeud,attr,"","")
End if
'concerne l'écriture d'un attribut ou d'un texte suivant la valeur (="O") d'un autre attribut
if TestParteses<>0 then
'Découpe en deux parties suivant (
resu0=Split(attr,"(",2)
for i = LBound(resu0) to UBound(resu0)
attr=resu0(0)
TxtMettre=resu0(1)
next i
'Supprime )
TxtMettre=join(split(TxtMettre, ")"), "")
End if
'dans le cas où l'on s'intéresse à deux noeuds
if TestEtNoeud<>0 then
resu1=Split(noeud,"&",2)
for i = LBound(resu1) to UBound(resu1)
noeud=resu1(0)
noeud2=resu1(1)
next i
Dom(noeud,attr,noeud2,TxtMettre)
End if
'dans le cas d'un multi-enregistrement dans un tableau :
if TestEtAttr<>0 Then
MonoEnreg=0
resu2=Split(attr,"&",2)
for j = LBound(resu2) to UBound(resu2)
attr=resu2(0)
lereste=resu2(1)
next j
resu21=Split(lereste,"_",2)
for k = LBound(resu21) to UBound(resu21)
NomTableau=resu21(0)
InfoCell=resu21(1)
next k
Dom(noeud,attr,noeud2,TxtMettre,NomTableau,InfoCell)
'Remplissage du tableau pour un attribut seulement
'Autrement on remplit le tableau avec tous les attributs de même noeud
if attr<>"tous" then
TestTablo(NomTableau,InfoCell)
End if
End if
End Sub
'Recherche de la valeur des attributs correspondant dans le fichier XML grâce au mode DOM
'Enregistrement de ceux-ci dans une variable(mono-enregistrement) ou un tableau.
Sub Dom(noeud As String, attr As String,noeud2 As String,TxtMettre As String, Optional NomTableau As String, Optional InfoCell As Integer)
Dim UBoundNew
Dim TestArob As String, NoeudMettre As String, TestSup As String
Dim oNodeSet As Object, oNodeSet2 As Object
Dim oTag As Object, TsAttr As Object
Dim NbreAttr As Integer
Dim NbreNoeud As Long, i As Long, j As Long
Dim UnAttr As String, EleMettre As String
'Ecriture d'un élément selon la valeur d'un (autre) attribut
'2 cas : élément = un texte
' élément = la valeur d'un attribut (ce cas se distingue par l'@)
TestArob=Instr(TxtMettre,"@")
if TestArob=1 then
NoeudMettre=join(split(TxtMettre, "@"), "")
End if
'Ecrire un élément le nombre de fois qu'un noeud est présent
TestSup=Instr(TxtMettre,"<")
if TestSup=1 then
EleMettre=join(split(TxtMettre, "<"), "")
End if
'Recherche du/des noeud(s) correspondant
oNodeSet = oXml.getElementsByTagName(noeud)
'Remplissage ligne par ligne d'un tableau
'Chaque colonne : un attribut
if attr="tous" then
oTag = oNodeSet.item(0)
NbreNoeud=oNodeSet.length
AgranditTablo(NomTableau,NbreNoeud)
TsAttr=oTag.getAttributes()
NbreAttr=TsAttr.length
ReDim TabloValeurAttr(NbreAttr)
for i = 0 to oNodeSet.length-1
for j=0 to NbreAttr-1
oTag = oNodeSet.item(i)
TsAttr=oTag.getAttributes()
UnAttr=TsAttr.item(j).getNodeValue()
TabloValeurAttr(j)=UnAttr
next j
RemplitTabloSimple(NomTableau,InfoCell,i)
next i
End if
if attr<>"tous" then
'1 noeud=mono-enregistrement
if oNodeSet.length=1 then
ValeurAttr=oNodeSet.item(0).getAttribute(attr)
'plusieurs noeuds : multi-enregistrement
'Enregistrement dans un tableau de variables.
else
ReDim TabloValeurAttr(0)
for i = 0 to oNodeSet.length-1
if TxtMettre="" then
oTag = oNodeSet.item(i)
ValeurAttr=oTag.getAttribute(attr)
TabloValeurAttr(UBoundNew) = ValeurAttr
else
'enregistrement de l'élément dans tous les indices du tableau
if TestSup=1 then
TabloValeurAttr(UBoundNew) = EleMettre
End if
'enregistrement d'un élément(texte ou valeur d'un attribut) si la valeur d'un attribut vaut O
if oNodeSet.item(i).getAttribute(attr)="O" then
if NoeudMettre="" then
TabloValeurAttr(UBoundNew) = TxtMettre
else
TabloValeurAttr(UBoundNew) = oNodeSet.item(i).getAttribute(NoeudMettre)
End if
End if
End if
'Redimensionnement du tableau
UBoundNew=UBound(TabloValeurAttr())+1
ReDim Preserve TabloValeurAttr(UBoundNew)
next i
End if
End if
'Enregistrement des éléments XML pour deux noeuds XML
if noeud2<>"" then
oNodeSet2 = oXml.getElementsByTagName(noeud2)
if oNodeSet2.length>1 then
for i = 0 to oNodeSet2.length-1
if TxtMettre="" then
oTag = oNodeSet2.item(i)
ValeurAttr=oTag.getAttribute(attr)
TabloValeurAttr(UBoundNew) = ValeurAttr
else
if oNodeSet2.item(i).getAttribute(attr)="O" then
if NoeudMettre="" then
TabloValeurAttr(UBoundNew) = TxtMettre
else
TabloValeurAttr(UBoundNew) = oNodeSet2.item(i).getAttribute(NoeudMettre)
End if
End if
End if
UBoundNew=UBound(TabloValeurAttr())+1
ReDim Preserve TabloValeurAttr(UBoundNew)
next i
End if
End if
End Sub
'Pour l'écriture ligne par ligne dans un tableau
'Création de lignes suivant le nombre de noeuds et de lignes du tableau déjà existants
Sub AgranditTablo(NomTableau As String, nbLignes As Integer)
dim maTable As Object, lesLignes As Object
maTable=MonDoc.TextTables.getByName(NomTableau)
lesLignes=maTable.rows
if lesLignes.count<nbLignes+1 then
lesLignes.insertByIndex(1,nbLignes-lesLignes.count+1)
End if
End Sub
'Ecriture ligne par ligne dans un tableau
Sub RemplitTabloSimple(NomTableau As String,InfoCell As Integer, z As Integer)
Dim y As Long, maTable As Object, lesLignes As Object
Dim maCellule As Object
maTable=MonDoc.TextTables.getByName(NomTableau)
lesLignes=maTable.rows
for y=0 to UBound(TabloValeurAttr)-1
maCellule=maTable.getCellByPosition(y,z+InfoCell)
maCellule.String=TabloValeurAttr(y)
next y
End Sub
'On teste la variable "NomCellule" pour connaître le cas dans lequel on se situe
Sub TestTablo(NomTableau As String, NomCellule As String)
Dim NomCellule1 As String, NomCellule2 As String
Dim Test2pts As Integer, Testtiret As Integer
Dim maTable As Object, lesLignes As Object
maTable=MonDoc.TextTables.getByName(NomTableau)
lesLignes=maTable.rows
Test2pts=Instr(NomCellule,":")
if Test2pts=0 then
Tablo1Cel(NomCellule,maTable)
Else
Testtiret=Instr(NomCellule,"-")
if Testtiret=0 then
TabloZone(NomCellule,maTable)
Else
Tablo2Col(NomCellule,maTable)
End if
End If
End Sub
'Ecriture dans une cellule :
Sub Tablo1Cel(NomCellule As String,maTable As Object)
Dim monCurseur As Object, maCellule As Object
Dim y As Long, TestTiretW As Integer, resu1() As String, j As Long, cursCell As Object
Dim Indice As Long
'Définition de la cellule
maCellule = maTable.GetCellByName(NomCellule)
'Positionnement du curseur de cellule :
monCurseur=maCellule.createTextCursor
'Ecriture des données du tableau de variables separées par une espace dans la cellule adéquate
for y=LBound(TabloValeurAttr) to UBound(TabloValeurAttr)
'on n'insère les données du tableau que si elles ne sont pas nulles
'(autrement trop d'espace entre les données non nulles)
if TabloValeurAttr(y)<>"" then
if y=LBound(TabloValeurAttr) then
maCellule.String=TabloValeurAttr(y)
else
maCellule.insertString(monCurseur," "+TabloValeurAttr(y),false)
End if
End if
next y
End Sub
'Ecriture dans une zone de cellule :
Sub TabloZone(NomCellule As String,maTable As Object)
Dim celluleDebut As String, NomCellules() As String
Dim nbLignes As Integer, nbColonnes As Integer
Dim i As Long, y As Long, z As Long, Indice As Long
Dim cursCell As Object
Dim TestTiretW As Integer
Dim maCellule As Object
NomCellules=Split(NomCellule,":",3)
for i = LBound(NomCellules) to UBound(NomCellules)
celluleDebut=NomCellules(0)
nbLignes=NomCellules(1)
nbColonnes=NomCellules(2)
next i
cursCell=maTable.createCursorByCellName(celluleDebut)
for y=0 to nbColonnes-1
for z=0 to nbLignes-1
maCellule=maTable.getCellByName(cursCell.RangeName)
if UBound(TabloValeurAttr)>=(nbLignes*y+z) then
Indice=nbLignes*y+z
'Ecriture en Wingdings
TestTiretW=Instr(TabloValeurAttr(nbLignes*y+z),"-w")
if TestTiretW<>0 then
Wingdings(Indice,maTable,cursCell)
End if
'mettre les données de la cellule en gras ou écrire dans la cellule :
GrasEcrire(Indice,maCellule,cursCell)
Else
'Toutes les données du tableau ont été écrites, on sort de la routine.
Exit Sub
End if
if z<>nbLignes-1 then
cursCell.goDown(1,false)
end if
next z
cursCell.goUp(nbLignes-1,false)
cursCell.goRight(1,false)
next y
End Sub
'Ecriture dans deux colonnes :
Sub Tablo2Col(NomCellule As String, maTable As Object)
Dim celluleDebut1 As String, celluleDebut2 As String
Dim nbLignes As Integer, nbreValeurMax As Integer
Dim decoupage1() As String, decoupage2() As String, lereste As String
Dim i As Integer, y As Integer, j As Integer, z As Integer
Dim TestTiretW As Integer
Dim cursCell As Object,cursCell2 As Object
Dim Indice As Integer
Dim maCellule As Object
decoupage1=Split(NomCellule,":",2)
for i = LBound(decoupage1) to UBound(decoupage1)
celluleDebut1=decoupage1(0)
lereste=decoupage1(1)
next i
decoupage2=Split(lereste,"-",2)
for i = LBound(decoupage2) to UBound(decoupage2)
nbLignes=decoupage2(0)
celluleDebut2=decoupage2(1)
next i
nbreValeurMax=nbLignes*2
if nbreValeurMax<UBound(TabloValeurAttr) then
CreationTablo(nbreValeurMax)
End if
cursCell=maTable.createCursorByCellName(celluleDebut1)
for y=0 to nbLignes-1
maCellule=maTable.getCellByName(cursCell.RangeName)
if UBound(TabloValeurAttr)>=y then
Indice=y
'Ecriture en Wingdings
TestTiretW=Instr(TabloValeurAttr(y),"-w")
if TestTiretW<>0 then
Wingdings(Indice,maTable,cursCell)
End if
'mettre les données de la cellule en gras ou écrire dans la cellule :
GrasEcrire(Indice,maCellule,cursCell)
Else
Exit Sub
End If
'écriture dans la deuxième colonne
if y=nbLignes-1 and UBound(TabloValeurAttr)>(y) then
cursCell2=maTable.createCursorByCellName(celluleDebut2)
for z=0 to nbLignes-1
maCellule=maTable.getCellByName(cursCell2.RangeName)
if UBound(TabloValeurAttr)>(y+z) then
Indice=y+z+1
TestTiretW=Instr(TabloValeurAttr(y+z+1),"-w")
if TestTiretW<>0 then
Wingdings(Indice,maTable,cursCell2)
End if
GrasEcrire(Indice,maCellule,cursCell2)
Else
Exit Sub
End If
cursCell2.goDown(1,false)
next z
End if
cursCell.goDown(1,false)
next y
End Sub
'Positionne le curseur de la cellule d'un tableau "en police" Wingdings
Sub Wingdings(Indice As Long, maTable As Object,cursCell As Object)
Dim j As Long
Dim resu1() As String
Dim cursCellMnt As Object
resu1=Split(TabloValeurAttr(Indice),"-",2)
for j = LBound(resu1) to UBound(resu1)
TabloValeurAttr(Indice)=resu1(0)
next j
cursCellMnt=maTable.createCursorByCellName(cursCell.RangeName)
cursCellMnt.CharFontName="Wingdings"
End Sub
'Positionne le curseur de la cellule d'un tableau "en gras" ou laisse le formatage tel quel et écrit dans la cellule
Sub GrasEcrire(Indice As Long, maCellule As Object,cursCell As Object)
Dim cursCellMnt As Object
Dim monCurseur As Object
if TabloValeurAttr(Indice)="%gras" then
cursCell.CharWeight=com.sun.star.awt.FontWeight.BOLD
End if
if TabloValeurAttr(Indice)<>"%gras" then
monCurseur=maCellule.createTextCursor
maCellule.insertString(monCurseur,TabloValeurAttr(Indice),false)
End if
End Sub
'Impression sur l'imprimante PDFCreator
Sub Impression
Dim mPrintopts1(), x as Variant
Dim mPrintopts2(0) As New com.sun.star.beans.PropertyValue
Dim mPrinter(0) As New com.sun.star.beans.PropertyValue
mPrinter(0).Name = "Name"
mPrinter(0).value = "PDFCreator"
MonDoc.Printer = mPrinter()
MonDoc.Print(mPrintopts1())
End Sub
'On attend que l'impression soit terminée avant de fermer le document odt.
Sub attenteFin
Dim infosImprimante As Variant, recommencer As Boolean, x As Long
Do
wait(100)
infosImprimante = MonDoc.Printer
for x = 0 to UBound(infosImprimante)
if infosImprimante(x).Name = "IsBusy" then
recommencer = infosImprimante(x).Value
end if
next
Loop Until not recommencer
End Sub