Bonjour a tous
il y a deux ou 3 ans je m'étais essayé a transformer une plage de cellules au format html
aujourd'hui nous avons la possibilité d'enregistrer le classeur, la feuille ou une plage de cellules avec le bouton enregistrer sous
cela dit le résultat bien que nickel n'est pas tout a fait conforme a l'original en Excel

les bordures ne sont pas tout a fait respectées et quelques autre petits détails
je vous propose aujourd'hui une fonction qui transforme une plage de cellules en code d'une table html et avec ce code soit créer un fichier soit pourquoi pas intégrer ce code dans le bodyhtml d'un message avec CDO par exemple

cette fonction offre 2 possibilité soit la plage avec le style soit sans le style (style épuré)
ce qu'il y a de special dans cette fonction c'est que je ne code pas une miette du style css et pourtant dans le code il y est
le style est inline ( a l'interieur de la balise de l'element TD)

je vous propose de regarder le résultat dans la capture d'écran et de pouvoir comparer par vous même la différence entre enregistre sous(html) en haut de l'image , ma version au milieu et la version excel en bas

la différence aussi c'est qu'avec ma version on est pas obligé d'enregistrer pour avoir le code html
bon voila je vous donne la fonction
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
Function grille_To_HTML(plage, Optional LsTyLe As Boolean = False) As String
    Set dicorange = CreateObject("Scripting.Dictionary")
    Set iedoc = CreateObject("htmlfile")
    codehtml = "<html>" & vbCrLf & "<table>" & vbCrLf & "<tr" & " classe= ligne1" & ">" & vbCrLf
    ligne = plage.Row
    coulnoborder = coul_XL_to_coul_HTMLX(15853019)
    For Each cel In plage.Cells
        If Not dicorange.exists(cel.MergeArea.Address) Then
            dicorange(cel.MergeArea.Address) = ""
            If cel.Row <> ligne Then ligne = cel.Row: codehtml = codehtml & vbCrLf & "</tr>" & vbCrLf & "<tr" & _
                                                               " classe= ligne" & cel.Row & ">" & vbCrLf
            codehtml = codehtml & "<td" & " id= " & cel.MergeArea.Address & ">" & cel.Value & "</td>" & vbCrLf
        End If
    Next
    With iedoc
        .write codehtml
        Set celhtml = .getelementsbytagname("td")
        Set matable = .getelementsbytagname("table")(0)
        With matable: .cellpadding = 0: .cellspacing = 0: End With
        For Each elem In celhtml
            elem.rowspan = Range(elem.ID).Rows.Count
            elem.colspan = Range(elem.ID).Columns.Count
            elem.Style.Width = Range(elem.ID).Width / (3 / 4)
            elem.Style.Height = Range(elem.ID).Height / (3 / 4)
            elem.Style.FontSize = Range(elem.ID).Font.Size * 1.3
            elem.Style.border = 1 & " solid " & coulnoborder
            If Range(elem.ID).HorizontalAlignment <> 1 Then elem.Style.TextAlign = "center"
 
            If LsTyLe = False Then
                matable.Style.border = 1 & " solid " & "gray"    'coulnoborder
            Else
                elem.Style.fontweight = IIf(Range(elem.ID).Font.Bold, "Bold", "normal")
                elem.Style.fontFamily = Range(elem.ID).Font.Name
                elem.Style.FontStyle = IIf(Range(elem.ID).Font.Italic = True, "italic", "normal")
                elem.Style.BackgroundColor = coul_XL_to_coul_HTMLX(Range(elem.ID).Interior.Color)
 
                SBrTop = IIf(Range(elem.ID).Borders(xlEdgeTop).LineStyle = 1, "solid", "dashed")
                SBrBottom = IIf(Range(elem.ID).Borders(xlEdgeBottom).LineStyle = 1, "solid", "dashed")
                SBrRight = IIf(Range(elem.ID).Borders(xlEdgeRight).LineStyle = 1, "solid", "dashed")
                SBrlLeft = IIf(Range(elem.ID).Borders(xlEdgeLeft).LineStyle = 1, "solid", "dashed")
 
                BrTop = borderweight(Range(elem.ID).Borders(xlEdgeTop).Weight)
                BrBottom = borderweight(Range(elem.ID).Borders(xlEdgeBottom).Weight)
                BrRight = borderweight(Range(elem.ID).Borders(xlEdgeRight).Weight)
                BrlLeft = borderweight(Range(elem.ID).Borders(xlEdgeLeft).Weight)
 
                If Range(elem.ID).Row = plage.Row And Range(elem.ID).Borders(xlEdgeTop).LineStyle <> xlNone Then elem.Style.BorderTop = BrTop & " " & SBrTop & " " & coul_XL_to_coul_HTMLX(Range(elem.ID).Borders(xlEdgeTop).Color)
                If Range(elem.ID).Column = plage.Column And Range(elem.ID).Borders(xlEdgeLeft).LineStyle <> xlNone Then elem.Style.Borderleft = BrlLeft & " " & SBrlLeft & " " & coul_XL_to_coul_HTMLX(Range(elem.ID).Borders(xlEdgeLeft).Color)
                If Range(elem.ID).Borders(xlEdgeBottom).LineStyle <> xlNone Then elem.Style.Borderbottom = BrBottom & " " & SBrBottom & " " & coul_XL_to_coul_HTMLX(Range(elem.ID).Borders(xlEdgeBottom).Color)
                If Range(elem.ID).Borders(xlEdgeRight).LineStyle <> xlNone Then elem.Style.Borderright = BrRight & " " & SBrRight & " " & coul_XL_to_coul_HTMLX(Range(elem.ID).Borders(xlEdgeRight).Color)
   End If
        Next
        grille_To_HTML = "<!DOCTYPE html>" & vbCrLf & "<html>" & vbCrLf & .body.innerhtml & vbCrLf & "</html>"
    End With
End Function
Sub createfichier3(chemin, texte)
    Dim intFic As Integer
    intFic = FreeFile
    Open chemin For Output As intFic
        Print #intFic, texte
    Close intFic
End Sub
Function borderweight(cote)
    Nameconst = Array("xlHairline", "xlMedium", "xlThick", "xlThin")
    valconst = Array(1, -4138, 4, 2)
    retour = Application.Index(Nameconst, Application.Match(cote, valconst, 0))
      Select Case retour
    Case "xlHairline": borderweight = 1    '"thin"
    Case "xlMedium": borderweight = 2    '"Medium"
    Case "xlThin": borderweight = 1    '"thin"
    Case "xlThick": borderweight = 3    '"thick"
    End Select
End Function
 
Function coul_XL_to_coul_HTMLX(couleur)
    Dim str0 As String, str As String
    'If couleur = 16777215 Then couleur = vbWhite
    str0 = Right("000000" & Hex(couleur), 6)
    str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
    coul_XL_to_coul_HTMLX = "#" & str & ""
End Function
et 4 exemples de comment s'en servir : le nom des subs parle de lui même

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
Sub récupere_codehtml_de_la_plage_sans_style()
    Dim plage As Range
    Set plage = Range("A1:H9")
    MsgBox grille_To_HTML(plage)
End Sub
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
Sub récupere_codehtml_de_la_plage_avec_style()
    Dim plage As Range
    Set plage = Range("A1:H9")
    MsgBox grille_To_HTML(plage, True)
End Sub
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
 
Sub ExCel_to_fichier_sans_style()
    Dim plage As Range, chemin As String
    Set plage = Range("A1:H9")
    chemin = "C:\Users\" & Environ("UserName") & "\Desktop\" & Replace(plage.Address, ":", "-") & " sans style " & ".html"
    createfichier3 chemin, grille_To_HTML(plage)
End Sub
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
Sub ExCel_to_fichier_avec_style()
    Dim plage As Range, chemin As String
    Set plage = Range("A1:H9")
    'MsgBox grille_To_HTML(plage)
    chemin = "C:\Users\" & Environ("UserName") & "\Desktop\" & Replace(plage.Address, ":", "-") & " Avec  style " & ".html"
    createfichier3 chemin, grille_To_HTML(plage, True)
End Sub
remercîments a Davido et Gnain pour m'avoir aiguillé sur la fonction Borderweight

et maintenant la capture d'écran
rappelez vous!
enhaut =enregistrer sous (html unique)
milieu=ma version
en bas excel
Nom : Capture.JPG Affichages : 667 Taille : 327,5 Ko