Créer et analyser un document xml en mémoire

Version imprimable

Voir 40 message(s) de cette discussion en une page

Bonjour a tous
je souhaiterait créer un xmldom en mémoire puis l'analyser

pour cela j'ai un code complet issu de la propriété xlRangeValueXMLSpreadsheet d'un rangemais je sais pas insérer le code complet
Code:

1 2 3 4 5 6 7 8 9 Sub essai() Dim ExtraitXML As String ExtraitXML = Sheets(1).Range("b3").MergeArea.Cells(1).Value(xlRangeValueXMLSpreadsheet) Debug.Print ExtraitXML Set xmlDoc = CreateObject("Microsoft.XMLDOM") 'comment insérer ici ExtraitXML End Sub

Bonjour
j'ai bien essayé de créer le root puis intégrer le code mais ca me supprime tout les "<" ou ">"

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub essai1()
Dim objDom As Object
   Dim objRootElem As Object
   Dim objMemberElem As Object
   Dim objMemberRel As Object
   Dim objMemberName As Object
    Dim ExtraitXML As String, innerH$, W#, H#, WRAPP As Boolean, backcol, aligH$, aligV$
 
    ExtraitXML = Sheets(1).Range("b3").Value(xlRangeValueXMLSpreadsheet)    'xlRangeValueMSPersistXML  '
    texte = Replace("<Styles>" & Split(ExtraitXML, "<Styles>")(1), Chr(34), " ")
 
 
   Set objDom = CreateObject("MSXML2.DOMDocument")
 
   ' Creates root element
   Set objRootElem = objDom.createElement("first")
   objDom.appendChild objRootElem
   objRootElem.Text = texte
 
End sub

j'ai essayé aussi la propriété "objDom .xml" mais elle est que en lecture seule c'est balo!!

11/09/2017, 11h50
Jean-Philippe André

Salut Patrick,

pour t'eviter un monologue, peux-tu nous dire quelle est ta question technique stp ?
11/09/2017, 16h05
patricktoulon

re

BonjourJean- Philippe-André
la question technique est simple

je ne veux pas créer les nœuds un par un j'ai déjà un code tout prêt que je veux insérer dans l'Object

un peu comme avec le l'object htmldocument ( .body.innerhtml="blablabla")
ce code est récupérer par
exemple

Code:

msgbox range("A1").value(xlRangeValueXMLSpreadsheet)

je veux mettre ce code dans l'object pour le parser et en récupérer certaines données
depuis hier je l'ai fait avec les librairie de traitement de chaine de caractères mais tu t'en doute c'est un calvaire mais j'y suis arrivé mais je préfèrerais travailler avec les nodes c'est plus propre

hier je l'ai fait en enregistrant dans un fichier .xml avec open for input as freefile
puis un load sur le fichier
mais j'en ai un paquet de cellules a examiner ca m'a paru pas envisageable même si ca fonctionne

OK, mais je n'ai toujours pas reussi a trouve ta question.

J'ai bien

Code:

Msgbox range("A1").value(xlRangeValueXMLSpreadsheet)

qui me renvoie une structure xml

Que cherches tu exactement a faire ?

TU peux passer par un fichier xml intermediaire si ca te chante
Code:

1 2 3 4 5 6 7 8 9 10 11 12 Sub patrick() Dim strXML As String strXML = Range("A1").Value(xlRangeValueXMLSpreadsheet) Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim oFile As Object Set oFile = fso.CreateTextFile("C:\temp\patrick.xml") oFile.WriteLine strXML oFile.Close Set fso = Nothing Set oFile = Nothing End Sub
Mais encore une fois je n'ai toujours pas compris ce qui motive ton post d'origine :(

OK peut etre que la tu va comprendre

je veux le même résultat que le code qui suit

sans passer par la creation d'un fichier solide ".xml"

mais avec ceci si quelque chose comme ca

Code:

1
2
set docXML=CreateObject("MSXML2.DOMDocument"
'docXML.xml=range("A1").value(xlRangeValueXMLSpreadsheet)

pour le moment je le fait comme ceci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub testtextstyle()
Set doc = CreateObject("htmlfile")
Debug.Print text_stylé([B3], doc)
End Sub
Function text_stylé(cel, doc)
    With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    ExtraitXML = Replace(cel.Value(xlRangeValueXMLSpreadsheet), "ss:Data", "Data")
    texte = Split(Split(Replace(ExtraitXML, "html:", ""), "<Data")(1), "</Data")(0)
    texte = Replace(texte, Split(texte, ">")(0) & ">", "")
    If IsDate(cel.Value) Then texte = cel.Text    'Format(cel.Text, "dd/mm/yyyy")
    fcolor = Split(ExtraitXML, "ss:FontName="""): i = 1
    If Not IsNull(cel.Font.Color) And cel.Font.Color <> 0 Then i = 2
    fontcolor = Split(Split(fcolor(i), "ss:Color=""")(1), Chr(34))(0)
    font_size = Split(Split(fcolor(UBound(fcolor)), "ss:Size=""")(1), Chr(34))(0)
    font_name = Split(fcolor(UBound(fcolor)), Chr(34))(0)
      Set fonte = doc.createelement("FONT")
    With fonte: .Style.Color = fontcolor: .Style.FontSize = font_size * ppx: .face = font_name: .innerhtml = texte
        Set Fonts = .getelementsbytagname("FONT")
        For i = 0 To Fonts.Length - 1
            If Fonts(i).Size <> "" Then Fonts(i).Style.FontSize = Fonts(i).Size * ppx: Fonts(i).Size = ""
        Next
    End With
    text_stylé = fonte.outerhtml
End Function

en gros je veux insérer le code directement dans l'object pour faire la même chose

en espérant avoir été plus clair ;)

11/09/2017, 16h54
Jean-Philippe André

Ok,

j'aurais aime aider, mais vu que tu cherches a reinventer la roue, je passe mon tour =]
11/09/2017, 16h59
patricktoulon

re

je cherche pas a réinventer la roue

je veut simplement savoir si cela est possible

si oui ok
si non tant pis
voila tout

Bonjour Patrick,

Code:

1
2
3
4
5
with creatobject("MSXML2.DOMDocument")
    If Not .LoadXML(range("A1").value(xlRangeValueXMLSpreadsheet)) Then
        Err.Raise .parseError.ErrorCode, , .parseError.reason
    End If
End with

re

bon ben voila
".loadxml"
avec gestion d'erreur en plus

merci robert;)

c'est quand même plus simple pour récupérer des données

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub test()
    Set docxml = CreateObject("MSXML2.DOMDocument")
    'Debug.Print Range("b3").Value(xlRangeValueXMLSpreadsheet)
        With docxml
        '.LoadXML (Replace(Range("B3:c4").Value(xlRangeValueXMLSpreadsheet), "ss:Data", "Data"))' ca marche aussi sans gestion d'erreur
        If Not .LoadXML(Replace(Range("B3:c4").Value(xlRangeValueXMLSpreadsheet), "ss:Data", "Data")) Then err.Raise .parseError.ErrorCode, , .parseError.reason
 
        ' innerhtml de la cellule
        Set onode = docxml.SelectSingleNode("/Workbook/Worksheet/Table/Row/Cell/Data")
        Debug.Print onode.BaseName & " " & Trim(Replace(onode.XML, Split(onode.XML, ">")(0) & ">", ""))
        'MsgBox docxml.XML
    End With
End Sub

j'aurrais besoins de toi robert si tu veux bien
pour récupéer non pas les node text mais les attributs ca je sais pas faire en XML
exemple ce qui est en rouge

Code:

1
2
<Border ss:Position="Right" ss:LineStyle="Dash" ss:Weight="2"
     ss:Color="#00B050"/>

Bonjour Patrick,

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub test()
    Set docxml = CreateObject("MSXML2.DOMDocument")
        With docxml
        If Not .LoadXML(Replace(Range("B1:c10").Value(xlRangeValueXMLSpreadsheet), "ss:Data", "Data")) Then Err.Raise .parseError.ErrorCode, , .parseError.reason
         Set Attrs = docxml.SelectSingleNode("/Workbook/Worksheet/Table").Attributes
        For Each Lignes In docxml.SelectSingleNode("/Workbook/Worksheet/Table").ChildNodes
            For Each colonnes In Lignes.ChildNodes
                Debug.Print colonnes.Text
                For Each Att In colonnes.Attributes
                  Debug.Print Att.Text
                Next
            Next
        Next
        Debug.Print onode.BaseName & " " & Trim(Replace(onode.XML, Split(onode.XML, ">")(0) & ">", ""))
    End With
End Sub

Bonjour Patrick,

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Option Explicit
 
Public Sub Test()
Dim docxml As Variant
Dim Noeud As Variant
Dim Attribu As Variant
Dim Attributs() As String, i As Long
 
    Set docxml = CreateObject("MSXML2.DOMDocument")
    With docxml
        If Not .LoadXML(Replace(Range("B3:c4").Value(xlRangeValueXMLSpreadsheet), "ss:Data", "Data")) Then Err.Raise .parseError.ErrorCode, , .parseError.reason
        Set Noeud = .SelectSingleNode("/Workbook/Worksheet/Table")
        If Not Noeud Is Nothing Then
            For Each Attribu In Noeud.Attributes
                ReDim Preserve Attributs(i)
                Attributs(i) = Attribu.BaseName & " := " & Attribu.Value 'Value ou Text, comme tu veux...
                i = i + 1
            Next
        End If
    End With
    MsgBox Join(Attributs, vbCrLf)
End Sub

EDIT : Un petit conseil @Patrick...
Lorsque tu travailles sur un objet de ce type, même si, in fine tu utiliseras CreateObject, commences par travailler avec la library concernée.
Ainsi, en cochant la référence XML 6.0 tu as accès à l'intellisence ET à l'aide VBA.
Aide VBA qui t'aurais apporté ceci :

Citation:

Property attributes As IXMLDOMNamedNodeMap
Lecture seule
Membre de MSXML2.DOMDocument
the collection of the node's attributes

Ensuite, en travaillant toujours avec cette library, tu développes ton code, en déclarant TOUTES les variables, par exemple :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Option Explicit
 
Public Sub test()
Dim docxml As New MSXML2.DOMDocument    'Nouveau doc Xml
Dim Noeud As IXMLDOMNode                'Node
Dim Attributs As IXMLDOMNamedNodeMap    'Collection
Dim A As IXMLDOMAttribute               'Pour boucler sur la collection
 
    With docxml
        If Not .LoadXML(Replace(Range("B3:c4").Value(xlRangeValueXMLSpreadsheet), "ss:Data", "Data")) Then Err.Raise .parseError.ErrorCode, , .parseError.reason
        Set Noeud = .SelectSingleNode("/Workbook/Worksheet/Table")
        If Not Noeud Is Nothing Then
            Set Attributs = Noeud.Attributes
            For Each A In Attributs
                Debug.Print A.BaseName & " := " & A.Value 'Value ou Text, comme tu veux...
            Next
        End If
    End With
End Sub

Et si, enfin, tu ne souhaites pas obliger l'utilisateur à cocher la référence, tu transformes le code comme je te l'ai livré en premier, avec des Variant.....

12/09/2017, 18h03
patricktoulon

re

re
Bonjour pijaku
c'est vrai en earlybinding j'aurais l'intelligence il est vrai que j'ai l'habitude inverse "latebinding"
je vais regarder la propriété "map"
merci
12/09/2017, 18h09
Invité
Pour compléter les remarques de pijaku, il m'arrive de faire ça
Code:

1 2 dim docxml as MSXML2.DOMDocument Set docxml = CreateObject("MSXML2.DOMDocument")
Ensuite pour la prod je décoche la référence et je mets as Object!

J'utilise surtout l'espion

re
bonjour robert

une derniere question avant de cloturer
est on obligé de boucler pou chopper x élément de même tag ?????

j'ai deux elements qui ont le chemin

Citation:

/Workbook/Styles/Style/Font")

chaque "font "est dans une balise"style" diffèrent autrement pour l'exemple
j'ai
le 1er pour les paramètre par défaut
le 2d pour les paramètres actuels
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 <Style ss:ID="Default" ss:Name="Normal"> <Alignment ss:Vertical="Bottom"/> <Borders/> <Font ss:FontName="Calibri" x:Family="Swiss" ss:Size="11" ss:Color="#000000"/> <Interior/> <NumberFormat/> <Protection/> </Style> <Style ss:ID="s64"> <Font ss:FontName="Aharoni" x:CharSet="177" ss:Size="16" ss:Color="#FF0000"/> <Interior/> </Style> </Styles>

12/09/2017, 18h41
pijaku

Ta réponse, Patrick, m'amène à penser, peut être à tort, que tu n'as pas tenu compte de mes conseils. Tout est dans l'aide VBA sur la library XML 6.0...
12/09/2017, 18h56
patricktoulon

1 pièce(s) jointe(s)

re

ho oui comme j'aimerais un peu d'aide ;)
Pièce jointe 311213

quand a l'aide comment dire heu .......

en gros la fenêtre des définition pour moi c'est mort et l'aide est tellement succincte que si j'avais un p... de moyen de faire sauter ce point d'interrogation dans ma barre je ne me priverais pas
*voila ou j'en suis :mouarf:
12/09/2017, 18h57
Invité

Oui et non, mais il faut savoir que l'id du style et dans le nodes enfant!
colonnes.Attributes

Patrick,

Il n'y a pas que le point d'interrogation qui t'apporte de l'aide.
Aide toi et VBA t'aideras petit padawan...

Avec ton niveau de connaissances, l'explorateur d'objet, dans lequel tu sélectionnes la bonne library, te donnes toutes les méthodes des objets choisis.

Ainsi, pour ta question, tu aurais trouvé :

Citation:

Function getElementsByTagName(tagName As String) As IXMLDOMNodeList
Membre de MSXML2.IXMLDOMElement
build a list of elements by name

ainsi que :

Citation:

Function getAttribute(name As String)
Membre de MSXML2.IXMLDOMElement
look up the string value of an attribute by name

et ainsi pondu tout seul le code :

Code:

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
Option Explicit
 
Public Sub test()
Dim docxml As New MSXML2.DOMDocument    'Nouveau doc Xml
Dim Noeuds As IXMLDOMNodeList           'Liste de noeuds de docxml
Dim E As IXMLDOMElement                 'Elément
Dim vIn As String                       'A chercher
Dim vOut As String                      'Valeur de retour
 
    With docxml
        If Not .LoadXML(Replace(Range("B3:c4").Value(xlRangeValueXMLSpreadsheet), "ss:Data", "Data")) Then Err.Raise .parseError.ErrorCode, , .parseError.reason
        'recherche tous les noeuds appelés font
        Set Noeuds = .getElementsByTagName("Font")
        'Nom de l'attribut à chercher
        vIn = "ss:FontName"
        If Not Noeuds Is Nothing Then
            'boucle sur les noeuds appelés "Font"
            For Each E In Noeuds
                'retourne leur attribut nommé ss:FontName
                vOut = E.getAttribute(vIn)
                Debug.Print vOut
            Next
        End If
    End With
    Set docxml = Nothing
    Set Noeuds = Nothing
End Sub

13/09/2017, 10h58
patricktoulon

re

Bonjour pijaku

Bonjour Pijaku

je te jure sur ce que j'ai de plus cher au monde que j'avais essayé ".getattribute" et "getelementsbytagname"c'est exactement le même principe qu'en HTML
d'ailleurs autrefois sur des fichier Xml anciens je m'en servais
sur ces xml ca n'a rien donné je vais re tester peu être ai-je zapper quelque chose

Voir 40 message(s) de cette discussion en une page