Sub test()
Dim BibNumber, TeamName, ClassName, BibNumber2, Leg, TeamMemberName, CourseName, CourseFamily
Dim DocXml, CourseData, RaceCourseData
Set DocXml = CreateObject("microsoft.xmldom")
Set CourseData = DocXml.appendChild(DocXml.createElement("CourseData"))
CourseData.setAttribute "xmlns", "'http://www.orienteering.org/datastandard/3.0' xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance'"
CourseData.setAttribute "iofVersion", "3.0"
CourseData.setAttribute "createTime", Format(Now, "yyyy-mm-dd""T""hh:nn:ss")
CourseData.setAttribute "creator", "Condes version 10.6.3"
Set levent = CourseData.appendChild(DocXml.createElement("event"))
Set lenam = levent.appendChild(DocXml.createElement("name"))
lenam.Text = "CFCO UNSS 2025 21/05/2025"
Set RaceCourseData = CourseData.appendChild(DocXml.createElement("RaceCourseData"))
x = 0
For lig = 2 To Feuil1.Cells(Rows.Count, 1).End(xlUp).Row
y = Feuil1.Cells(lig, 1)
If y <> x Then
Set cassign = RaceCourseData.appendChild(DocXml.createElement("TeamCourseAssignment"))
x = y
Else
Set BibNumber = cassign.appendChild(DocXml.createElement("BibNumber"))
BibNumber.Text = Feuil1.Cells(lig, 1).Value
Set TeamName = cassign.appendChild(DocXml.createElement("TeamName"))
TeamName.Text = Feuil1.Cells(lig, 2)
Set ClassName = cassign.appendChild(DocXml.createElement("ClassName"))
ClassName.Text = Feuil1.Cells(lig, 3)
Set Leg = cassign.appendChild(DocXml.createElement("Leg"))
Leg.Text = Feuil1.Cells(lig, 5)
Set TeamMemberName = cassign.appendChild(DocXml.createElement("TeamMemberName"))
TeamMemberName.Text = Feuil1.Cells(lig, 6)
Set CourseName = cassign.appendChild(DocXml.createElement("CourseName"))
CourseName.Text = Feuil1.Cells(lig, 7)
Set CourseFamily = cassign.appendChild(DocXml.createElement("CourseFamily"))
CourseFamily.Text = Feuil1.Cells(lig, 8)
End If
Next
SaveFormatDocToFileXL DocXml, Environ("userprofile") & "\Desktop\moncourxexml.xml"
End Sub
'fonction pour ecrire le fichier au format conforme
'fonction issue du creatorRibbonX
'inpose le format UTF-8 et indente le code
'Auteur patricktoulon
Public Sub SaveFormatDocToFileXL(ByVal doc, ByVal FileName As String)
Dim ReaderXml As Object, StreamFormaté As Object, WriterFormat As Object, elem
Set ReaderXml = CreateObject("MSXML2.SAXXMLReader.6.0")
Set StreamFormaté = CreateObject("ADODB.Stream")
Set WriterFormat = CreateObject("MSXML2.MXXMLWriter")
With StreamFormaté
.Open
.Type = 1 'adTypeBinary
With WriterFormat
.omitXMLDeclaration = False
'.standalone = True
.byteOrderMark = False 'If not set (even to False) then
'.encoding is ignored.
.Encoding = "utf-8" 'Even if .byteOrderMark = True
'UTF-8 never gets a BOM.
.indent = True
.output = StreamFormaté
With ReaderXml
Set .contentHandler = WriterFormat
Set .dtdHandler = WriterFormat
Set .errorHandler = WriterFormat
.putProperty "http://xml.org/sax/properties/lexical-handler", WriterFormat
'.putProperty "http://xml.org/sax/properties/declaration-handler", WriterFormat
.Parse doc
End With
End With
If Dir(FileName) <> "" Then Kill FileName
.SaveToFile FileName
.Close
End With
Set ReaderXml = Nothing
Set StreamFormaté = Nothing
Set WriterFormat = Nothing
End Sub