[Writer] Import de données XML

Vos meilleures macros et portions de code sont publiées dans cette section.
Aucun support sur une question de programmation ici !

Modérateur : Vilains modOOs

Règles du forum
Aucune question dans cette section !
Celle-ci rassemble les meilleures macros et portions de code. Vous pouvez en revanche commenter ou argumenter le code exposé. Vous pouvez même remercier l'auteur (cela fait toujours plaisir) en indiquant par exemple dans quel cadre ou contexte vous en avez eu l'utilité.
Si vous avez à poster quelque chose, faites-le depuis la section Macros et API et demandez à un modérateur de l'y déplacer.
anouka
Membre OOrganisé
Membre OOrganisé
Messages : 53
Inscription : 24 avr. 2007 14:49

[Writer] Import de données XML

Message par anouka »

Import de données XML dans un ODT

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