Modification de fichiers XML en boucle VBA

Bonjour,

J'ai un répertoire contenant de nombreux fichiers .xml et je cherche une boucle simple en VBA pour aller modifier un champs unique dans chaque fichier xml.

par exemple je voudrais changer la ligne crs:GrainAmount="13" par crs:GrainAmount="0"
Est-ce possible ?

Merci d'avance pour vos idées !

bonjour,

une proposition. Comme cela altère des fichiers sans possibilité de revenir en arrière, sois sûr d'avoir une bonne sauvegarde avant d'exécuter la macro

Sub aargh()
    chemin = "d:\downloads\" '<- à adapter
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fol = fso.GetFolder(chemin)
    If fol.Files.Count = 0 Then
        MsgBox "pas de fichier", vbExclamation
    Else
        For Each fn In fol.Files 
            If fn.Name Like "*.xml" Then
                Set ts = fso.OpenTextFile(fn)
                r = ts.readall
                r = Replace(r, "crs:GrainAmount=""13""", "crs:GrainAmount=""0""", vbTextCompare)
                ts.Close
                Set ts = fso.OpenTextFile(fn, 2)
                ts.write r
                ts.Close
            End If
        Next fn
    End If
End Sub

Je vais tester ça, un grand merci !

juste une petite question pratique : je peux mettre r = Replace(r, "crs:GrainAmount=""*""", "crs:GrainAmount=""0""", vbTextCompare) afin de couvrir toutes les valeurs possibles ?

Merci

bonjour,

une version adaptée à ta nouvelle demande

Sub aargh()
    chemin = "d:\downloads\testxml\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fol = fso.GetFolder(chemin)
    If fol.Files.Count = 0 Then
        MsgBox "pas de fichier", vbExclamation
    Else
        For Each fn In fol.Files
            If fn.Name Like "*.xml" Then
                Set ts = fso.OpenTextFile(fn)
                r = ts.readall
'remplace ce qui se trouve entre crs:GrainAmount=" et " par 0
                r = remplacetexte(r, "crs:GrainAmount=""", Chr(34), "0")
                ts.Close
                Set ts = fso.OpenTextFile(fn, 2)
                ts.write r
                ts.Close
            End If
        Next fn
    End If
End Sub

Function remplacetexte(texte, del1, del2, nouveautexte)
    'remplace toutes les occurrences d'un texte se trouvant entre les délimiteurs del1 et del2 par le nouveau texte
    r = texte
    s = 0
    Do
        s = InStr(s + 1, r, del1)
        If s > 0 Then
            s1 = InStr(s + Len(del1), r, del2)
            r = Left(r, s + Len(del1) - 1) & nouveautexte & Mid(r, s1)
            Debug.Print r
        End If
    Loop While s > 0
    remplacetexte = r
End Function

C’est parfait !

Un grand merci à toi, j’avais vu cette syntaxe mais cela datait.

Bonne soirée !

Pascal