'***************************************************
'ebauche patricktoulon '/2022
' createhtml code table en string
Const TD As String = "<TD id='"
Const TR As String = "<TR id=>"
Sub test()
Dim tim
tim = Timer
CreateStringHtmlCodeByString [c4:i13]
MsgBox Format(Timer - tim, "#0.000 Sec") & " pour obtenir le codehtml"
End Sub
Function CreateStringHtmlCodeByString(rng As Range)
Dim cel As Range
For lig = 1 To rng.Rows.Count
code = code & Replace(TR, "id=", "id='Ligne" & rng.Rows(lig).Row & "'") & vbCrLf
For c = 1 To rng.Columns.Count
Set cel = rng.Rows(lig).Cells(c).MergeArea: addr = cel.Address(0, 0)
If InStr(1, code, addr) = 0 Then
code = code & Replace(TD, "id='", "id='" & Trim(addr) & "'")
If cel.Columns.Count > 1 Then code = code & "colSpan= " & cel.Columns.Count & " "
If cel.Rows.Count > 1 Then code = code & " rowSpan= " & cel.Rows.Count & " "
code = code & " style="""
code = code & "width:" & Replace(cel.Width, ",", ".") & "pt;"
code = code & "height:" & Replace(cel.Height / 1.5, ",", ".") & "pt;"
If cel.Cells(1).Font.Size <> 11 Then code = code & "font-size:" & Replace(cel.Font.Size - 1, ",", ".") & "pt;"
If cel.Cells(1).Font.Name <> "Calibri" Then code = code & "font-family:" & cel.Font.Name & ";"
'///////////////////////////////////////////////////////////////////////////////////////////
'cette partie me genere un desordre si je l'active
'On Error Resume Next 'le backgraound (Attention!!! 'displayformat(version sup à 2007)
'cir = xlToHtmlColor(cel.Cells(1).DisplayFormat.Interior.Color)
'If Err.Number > 0 Then Err.Clear: cir = xlToHtmlColor(cel.Cells(1).Interior.Color)
'On Error GoTo 0
'If cir <> "#FFFFFF" Then code = code & "background-color:" & cir & ";"
'//////////////////////////////////////////////////////////////////////////////////////////
'celle là est bonne mais ne pends pas en charge les (TS)
cir = xlToHtmlColor(cel.Cells(1).Interior.Color)
If cir <> "#FFFFFF" Then code = code & "background-color:" & cir & ";"
'et je pige pas pourquoi
'**************************************************************************
'l'epaisseur des bordures
'bordure weigth ; dans l'ordre (top right bottom left)
tp = cel.Borders(8).Weight: tp = IIf(tp > 1, tp - 1, tp) & "px "
r = cel.Borders(10).Weight: r = IIf(r > 1, r - 1, r) & "px "
bt = cel.Borders(9).Weight: bt = IIf(bt > 1, bt - 1, bt) & "px "
lt = cel.Borders(7).Weight: lt = IIf(lt > 1, lt - 1, lt) & "px;"
Dim Cl As Range, celr As Range, celB As Range
Set celr = cel.Offset(, 1).Resize(cel.Rows.Count)
For Each Cl In celr.Cells
If (Cl.Borders(7).Color <> cel.Borders(10).Color) Then r = "0px "
Next
Set celB = cel.Offset(1).Resize(cel.Columns.Count)
For Each Cl In celB.Cells
If (Cl.Borders(8).Color <> cel.Borders(9).Color) Then bt = "0px "
Next
code = code & "border-width:" & tp & r & bt & lt
'**************************************************************************
'bordure couleur ; dans l'ordre (top right bottom left)
code = code & "border-color:" & _
xlTohtmlBorderColor(cel.Borders(8)) & " " & xlTohtmlBorderColor(cel.Borders(10)) & " " & _
xlTohtmlBorderColor(cel.Borders(9)) & " " & xlTohtmlBorderColor(cel.Borders(7)) & ";"
'bordure style ; dans l'ordre (top right bottom left)
code = code & "border-style:" & _
ConvertBorderStyle(cel.Borders(8)) & " " & ConvertBorderStyle(cel.Borders(10)) & " " & _
ConvertBorderStyle(cel.Borders(9)) & " " & ConvertBorderStyle(cel.Borders(7)) & ";"
ha = cel.Cells(1).HorizontalAlignment
If ha = xlCenter Then code = code & "text-align:center;"
If ha = xlRight Then code = code & "text-align:right;"
If IsNull(ha) Then code = code & "text-align:left;"
va = cel.Cells(1).HorizontalAlignment
If va = xlCenter Then code = code & "valign:middle;"
If va = xlRight Then code = code & "valign:bottom;"
If IsNull(va) Then code = code & "valign:top;"
code = code & """>"
'ici on met le innerhtml
code = code & "<font style='margin-top:0;'> " & cel(1) & "</font>"
code = code & "</TD>" & vbCrLf
End If
Next c
code = code & "</TR>" & vbCrLf
Next lig
code = Replace(code, "-4138", "1")
styletable = "style=""BORDER-COLLAPSE: cghghgollapse; TABLE-LAYOUT: fixed;" & _
"font-size:10pt;font-family:calibri;Max-width:" & Replace(rng.Width, ",", ".") & "pt;" & _
"max-height:" & rng.Height / 1.5 & "pt;"""
code = "<table " & styletable & ">" & code & "</table>"
Fhtml = ThisWorkbook.Path & "\TestEnString.htm"
X = FreeFile: Open Fhtml For Output As #X: Print #X, code: Close #X
CreateStringHtmlCodeByString = code
End Function
Function xlTohtmlBorderColor(bs As Border)
'collection fonction perso
'fonction Color XL to HTMLCOLOR ---> By Patricktoulon (2016)
Dim str0 As String, strf As String, couleur As String
couleur = bs.Color
If bs.LineStyle = xlNone Then couleur = RGB(220, 220, 220)
str0 = Right("000000" & Hex(couleur), 6): strf = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
xlTohtmlBorderColor = "#" & strf & ""
End Function
Function xlToHtmlColor(couleur)
'collection fonction perso
'fonction Color XL to HTMLCOLOR ---> By Patricktoulon (2016)
Dim str0 As String, strf As String
str0 = Right("000000" & Hex(couleur), 6): strf = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
xlToHtmlColor = "#" & strf & ""
End Function
Function ConvertBorderStyle(b As Border)
'Fonction de convertion du style de bordure
'Patricktoulon (2016)
'xlContinuous= 1 / 'xlDash= -4115 / 'xlDashDot= 4 / 'xlDashDotDot= 5 / 'xlDot= -4118 / 'xlDouble= -4119 / 'xlLineStyleNone= -4142 / 'xlSlantDashDot = 13
Dim bds
bs = b.LineStyle
bds = Switch(bs = xlNone, "solid", bs = xlLineStyleNone, "solid", bs = xlContinuous, "solid", bs = xlDot, "dotted", bs = xlDash, "dashed", _
bs = xlDashDot, "dashed", bs = xlDouble, "double", bs = xlDashDotDot, "dashed", bs = xlSlantDashDot, "dashed")
ConvertBorderStyle = bds
End Function
'****************************************************************************************************
Sub testqq()
MsgBox htmltexte([c9])
End Sub
Function htmltexte(cel As Range)
Debug.Print cel(1).Value(11)
'Fonction de récupération du code html du texte formaté dans la cellule
'Version sans htmldocument (STRING)
'Patricktoulon (2016)
Dim cde$, elem, t
cde = Replace(Replace(cel.Value(11), "ss:", ""), "html:", "")
t = Split(cde, "<Cell ")
If UBound(t) > 0 Then
cde = Replace(cde, Split(t(0), "<Font")(0), "")
cde = Split(cde, "</Data")(0)
htmltexte = cde
Else
htmltexte = cel.Value
End If
End Function
