'*************************************************************************************
'* exportToXML2, IndenterXMLCode, exportToHTML
'* Auteur : patricktoulon sur https://excel-downloads.com/
'* Tous mes remerciements pour sa collaboration et échanges de lignes de code
'* Ajout à cette version 1.03 le 01/05/2025
'*************************************************************************************
Sub exportToHTML( _
hFileName As String, _
Optional hReplace As Integer = True, _
Optional WhithHeader As Boolean = False, _
Optional WithTotal As Boolean = False)
Dim vHeaders As Variant
Dim i As Long
Dim c As Long
Dim iNbrLig As Long
Dim iNbrCol As Integer
Dim vColumnValues As Variant
Dim table, TR, TD, TH, COLHTML, Tbody, COL
Dim CdeHTML As String
If pOTools.isFileExists(hFileName) Then
If hReplace <> -1 Then
Err.Raise _
ERROR_MESSAGE, _
ERROR_SOURCE, _
ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
End If
End If
Close
vColumnValues = getTableCells
iNbrLig = pDataBody.Rows.Count + 1
iNbrCol = pDataBody.Columns.Count
vHeaders = getHeaders()
With CreateObject("htmlfile")
Set table = .body.appendchild(.createelement("TABLE"))
table.setattribute "Tableau", CStr(pNameTS)
table.Style.bordercollapse = "collapse"
table.Style.TextAlign = "center"
For c = 0 To UBound(vHeaders)
Set COL = table.appendchild(.createelement("COL"))
COL.Style.Width = Round(pDataBody.Cells(1, c + 1).Width) & "pt"
Next
Set Tbody = table.appendchild(.createelement("TBODY"))
Set TR = Tbody.appendchild(.createelement("TR"))
If HasHeaderRow Then
If WhithHeader Then
For c = 0 To UBound(vHeaders)
Set TH = TR.appendchild(.createelement("TH"))
TH.innerhtml = CStr(vHeaders(c))
TH.Style.Border = "0.5pt solid black"
Next
End If
End If
For i = 2 To iNbrLig
Set TR = Tbody.appendchild(.createelement("TR"))
For c = 1 To iNbrCol
Set TD = TR.appendchild(.createelement("TD"))
TD.innerhtml = vColumnValues(i, c)
TD.Style.Border = "0.5pt solid black"
Next
Next
'-------------------------------------------------------
If HasTotalRow Then
If WithTotal Then
Set TR = Tbody.appendchild(.createelement("TR"))
TR.setattribute "Ligne_Total", ""
For c = 1 To iNbrCol
Set TD = TR.appendchild(.createelement("TD"))
TD.innerhtml = "<b>" & pDataTotalBody.Cells(c) & "</B>"
TD.Style.Border = "0.5pt solid black"
Next
End If
End If
'-------------------------------------------------------
'Debug.Print .body.innerhtml
Dim oStream
Set oStream = CreateObject("ADODB.Stream")
oStream.Charset = "utf-8"
oStream.Open
oStream.WriteText table.outerhtml
oStream.SaveToFile hFileName, 2
End With
End Sub
Sub exportToXML2(hFileName As String, Optional hReplace As Integer = True)
'Auteur :
Dim vHeaders As Variant
Dim i As Long
Dim c As Long
Dim iNbrLig As Long
Dim iNbrCol As Integer
Dim vColumnValues As Variant
Dim XmlDoc, Postprocc, ROOT, Record, elem, oStream
If pOTools.isFileExists(hFileName) Then
If hReplace <> -1 Then
Err.Raise _
ERROR_MESSAGE, _
ERROR_SOURCE, _
ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
End If
End If
Close
vColumnValues = getTableCells
iNbrLig = pDataBody.Rows.Count + 1
iNbrCol = pDataBody.Columns.Count
vHeaders = getHeaders()
Set XmlDoc = CreateObject("Microsoft.XMLDOM") 'CREATION D'UN DOMDOCUMENT XML
With XmlDoc
Set ROOT = .appendchild(.createelement(CStr(pNameTS))) 'CREATION DE L'ELEMENT ROOT
'creation et intégration du post processing
Set Postprocc = .createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""") 'creation de l'entete du processing
.InsertBefore Postprocc, .ChildNodes.Item(0) 'insertion parametre processing
'ajout des elements
For i = 2 To iNbrLig
Set Record = ROOT.appendchild(.createelement("RECORD_0" & i - 1))
For c = 1 To iNbrCol
Set elem = Record.appendchild(.createelement(pDataBody.Cells(1, c).Offset(-1)))
elem.Text = pDataBody.Cells(i - 1, c)
Next
Next
If HasTotalRow Then
Set Record = ROOT.appendchild(.createelement("TOTAL"))
For i = 1 To pDataTotalBody.Columns.Count
Set elem = Record.appendchild(.createelement("cell"))
elem.Text = pDataTotalBody.Cells(i).Value
Next
End If
Set oStream = CreateObject("ADODB.Stream")
oStream.Charset = "utf-8"
oStream.Open
oStream.WriteText IndenterXMLCode(XmlDoc.XML)
oStream.SaveToFile hFileName, 2
End With
End Sub
Sub exportToXML3( _
hFileName As String, _
Optional hReplace As Integer = True, _
Optional WhithHeader As Boolean = False, _
Optional WithTotal As Boolean = False)
' V1.06
'Auteur :
Dim vHeaders As Variant
Dim i As Long
Dim c As Long
Dim color1 As Long
Dim color2 As Long
Dim Fnam
Dim Fcolor
Dim XmlDoc, Postprocc, ROOT, Record, elem, oStream
Dim TableName, tableStyle, HeadCol, TableHeader, TableBody, properties, hasheader, ligne, cel, themecolor1, themecolor2, tss, fn, fc
If pOTools.isFileExists(hFileName) Then
If hReplace <> -1 Then
Err.Raise _
ERROR_MESSAGE, _
ERROR_SOURCE, _
ERROR_MSG & " : Le fichier " & hFileName & " existe déjà"
End If
End If
Close
Set tss = ThisWorkbook.TableStyles(pTable.tableStyle)
color1 = tss.TableStyleElements(xlRowStripe1).Interior.Color
color2 = tss.TableStyleElements(xlRowStripe2).Interior.Color
If color2 = 0 Then color2 = vbWhite
Fnam = ThisWorkbook.TableStyles(pTable.tableStyle).TableStyleElements(xlWholeTable).Font.Name
If IsNull(Fnam) Then Fnam = Cells(Rows.Count, Columns.Count).Offset(-10, -10).Resize(10).Font.Name
Fcolor = ThisWorkbook.TableStyles(pTable.tableStyle).TableStyleElements(xlWholeTable).Font.Name
If IsNull(Fcolor) Then Fcolor = Cells(Rows.Count, Columns.Count).Offset(-10, -10).Resize(10).Font.Color
vHeaders = getHeaders()
Set XmlDoc = CreateObject("Microsoft.XMLDOM") 'CREATION D'UN DOMDOCUMENT XML
With XmlDoc
Set ROOT = .appendchild(.createelement("table")) 'CREATION DE L'ELEMENT ROOT Tag(table)
Set properties = ROOT.appendchild(.createelement("properties")) 'creation d'une balise propertiesqui contiendra les propreties que l'on veux
'creation et intégration du post processing
Set Postprocc = .createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""") 'creation de l'entete du processing
.InsertBefore Postprocc, .ChildNodes.Item(0) 'insertion parametre processing
Set TableName = properties.appendchild(.createelement("Name")) 'balise table name contient le nom du listobject
TableName.Text = CStr(pNameTS)
Set tableStyle = properties.appendchild(.createelement("tablestyle")) 'balise tablestyle (contient le style du tableau
tableStyle.Text = CStr(pTable.tableStyle)
Set hasheader = properties.appendchild(.createelement("hasheader")) 'balise hasheader (contient 1 ou 0) selon si le tableau a un header ou pas
hasheader.Text = Abs(pTable.ShowHeaders)
Set themecolor1 = properties.appendchild(.createelement("themecolor1")) 'balise themecolor1 (contient la couleur 1 du style du tableau)
themecolor1.Text = color1
Set themecolor2 = properties.appendchild(.createelement("themecolor2")) 'balise themecolor2 (contient la couleur 2 du style du tableau)
themecolor2.Text = color2
Set fn = properties.appendchild(.createelement("Font_name")) 'balise themecolor2 (contient la couleur 2 du style du tableau)
fn.Text = Fnam
Set fc = properties.appendchild(.createelement("Font_Color")) 'balise themecolor2 (contient la couleur 2 du style du tableau)
fc.Text = Fcolor
'ecriture du header
If pTable.ShowHeaders Then ' si le tableau a un header
If WhithHeader Then
Set TableHeader = ROOT.appendchild(.createelement("headers")) 'creation de la balise header
'ajout des balises headcol correspontes au cellule du header du tableau
For i = LBound(vHeaders) To UBound(vHeaders)
Set HeadCol = TableHeader.appendchild(.createelement("headcol"))
HeadCol.Text = vHeaders(i)
HeadCol.setattribute "index", i + 1 'attribut index de colonne
HeadCol.setattribute "Width", pDataBody.Cells(1, i + 1).Width 'attribut largeur de colonne
HeadCol.setattribute "height", pDataBody.Cells(1, i + 1).Height 'attribut hauteur de cellule header
Next
End If
End If
'ecriture de la table(body)
Set TableBody = ROOT.appendchild(.createelement("tablebody"))
For i = 1 To pDataBody.Rows.Count
Set ligne = ROOT.appendchild(.createelement("row"))
ligne.setattribute "index", i
ligne.setattribute "height", pDataBody.Cells(1, i + 1).Height 'attribut hauteur de ligne
For c = 1 To pDataBody.Columns.Count
Set cel = ligne.appendchild(.createelement("cell"))
cel.Text = pDataBody.Cells(i, c)
cel.setattribute "bold", Abs(pDataBody.Cells(i, c).Font.Bold)
'on met les attributs Font(name et color) uniquement si elles sont différentes du général
If pDataBody.Cells(i, c).Font.Name <> Fnam Then cel.setattribute "FontName", pDataBody.Cells(i, c).Font.Name
If pDataBody.Cells(i, c).DisplayFormat.Font.Color <> Fcolor Then cel.setattribute "FontColor", pDataBody.Cells(i, c).DisplayFormat.Font.Color
Dim expectedColor As Long
expectedColor = IIf(i Mod 2 = 1, color1, color2)
If pDataBody.Cells(i, c).DisplayFormat.Interior.Color <> expectedColor Then
cel.setattribute "interiorcolor", pDataBody.Cells(i, c).Interior.Color
End If
Next
Next
If HasTotalRow Then
If WithTotal Then
Set ligne = ROOT.appendchild(.createelement("row"))
ligne.setattribute "ligne_Total", ""
ligne.setattribute "height", pDataTotalBody.Cells(1).Height 'attribut hauteur de ligne
For i = 1 To pDataTotalBody.Columns.Count
Set cel = ligne.appendchild(.createelement("cell"))
cel.Text = pDataTotalBody.Cells(i)
cel.setattribute "bold", 1
Next
End If
End If
'écriture du fichier
Set oStream = CreateObject("ADODB.Stream")
oStream.Charset = "utf-8"
oStream.Open
oStream.WriteText IndenterXMLCode(XmlDoc.XML)
oStream.SaveToFile hFileName, 2
End With
End Sub
'*************************************************************************************
'version 2 en memoire
'Fonction basique minimale pour indenter un code xml(issue de creatorribbonx (collection fonction perso ))
'* Auteur : patricktoulon sur https://excel-downloads.com/
'*************************************************************************************
Public Function IndenterXMLCode(ByVal vDomOrString As Variant) As String
Dim XMLWriter As Object ' MSXML2.MXXMLWriter
On Error GoTo QH
Set XMLWriter = CreateObject("MSXML2.MXXMLWriter")
XMLWriter.indent = True 'ajoute l'attribut indent
With CreateObject("MSXML2.SAXXMLReader")
Set .contentHandler = XMLWriter
.Parse vDomOrString
End With
IndenterXMLCode = Replace(Replace(XMLWriter.output, "UTF-16", "UTF-8"), "standalone=""no""", "")
Exit Function
QH:
End Function
'*************************************************************************
'* Ajout patricktoulon à propos des exports xml e html
'*************************************************************************