Dim Lignes() As String, LignesCond() As String
Sub NettXML()
Dim FamMAT As String, AdrXML As String, AdrXMLTrait As String
Dim BoolIFROC As Boolean, BoolMAT As Boolean, BoolCons As Boolean
Dim LigXML As String, i As Long
Dim fs, f1, f2
ReDim Lignes(1 To 1) 'Tableau des lignes XML à conserver
ReDim LignesCond(1 To 1) 'Tableau des lignes XML à conserver sous condition
FamMAT = "fam1" 'Famille pour laquelle le XML est supprimé
AdrXML = "C:\temp\essai.xml" 'Adresse du fichier à traiter
AdrXMLTrait = "C:\temp\essai2.xml" 'Adresse du fichier traité
BoolIFROC = False
BoolMAT = False
BoolCons = False
Set fs = CreateObject("Scripting.FileSystemObject")
Set f1 = fs.OpenTextFile(AdrXML, 1, False, -2)
Do Until f1.AtEndOfStream
LigXML = f1.ReadLine
If UCase(LigXML) = "<IFROC>" Then BoolIFROC = True
If UCase(LigXML) = "</IFROC>" Then BoolIFROC = False
If UCase(LigXML) Like "<MAT>*</MAT>" Then BoolMAT = True
If Not BoolIFROC And Not BoolMAT Then
If BoolCons Then
Call AjoutCond
If Lignes(1) <> "" Then ReDim Preserve Lignes(1 To UBound(Lignes) + 1)
Lignes(UBound(Lignes)) = LigXML
End If
ReDim LignesCond(1 To 1)
BoolCons = False
ElseIf BoolIFROC And Not BoolMAT Then
If LignesCond(1) <> "" Then ReDim Preserve LignesCond(1 To UBound(LignesCond) + 1)
LignesCond(UBound(LignesCond)) = LigXML
ElseIf BoolIFROC And BoolMAT Then
If LigXML Like "*" & FamMAT & "*" Then
BoolCons = False
Else
If LignesCond(1) <> "" Then ReDim Preserve LignesCond(1 To UBound(LignesCond) + 1)
LignesCond(UBound(LignesCond)) = LigXML
BoolCons = True
End If
BoolMAT = False
End If
Loop
f1.Close
Set f2 = fs.CreateTextFile(AdrXMLTrait, True)
For i = LBound(Lignes) To UBound(Lignes)
f2.WriteLine Lignes(i)
Next i
f2.Close
Set f1 = Nothing
Set f2 = Nothing
Set fs = Nothing
End Sub
Sub AjoutCond()
Dim i As Long
For i = LBound(LignesCond) To UBound(LignesCond)
If Lignes(1) <> "" Then ReDim Preserve Lignes(1 To UBound(Lignes) + 1)
Lignes(UBound(Lignes)) = LignesCond(i)
Next i
End Sub