Bonjour a tous

comme je me suis aperçu que le sujet revenait souvent ces derniers temps j'ai repris mon(" grille to html " dans une autre contribution)et je l'ai complètement repensé et surtout amélioré

alors voila
1 ere fonction "RangE_tO_HTML"

je l'ai complètement réécrite et je l'ai affuble d'une fonction supplémentaire ce qui n'était pas le cas dans ma précédente contribution

2 fonction "BYSPAN"
en effet j'ai créé la fonction "BYSPAN" qui permet de gérer les caractères différent dans une même cellule( fontsize,fontname,fontcolor,etc.....)

3 fonction "bordures"
elle aussi je l'ai complétement repensé
elle intègre le code CSS pour les bordures de cellules
bien évidement elle gère mieux le type et toutes les propriétés des bordures (plus de choix de style ,etc....)

4 fonction "CSs_outline"
la fonction CSs_outline qui permet de séparer le code css du code html et redonner au balises HTML une lisibilité plus propre
et dans le cadre de l'utilisation de la sub mail on a la possibilité d'ajouter le texte dans le body du document


5 la sub "sending_mail_CDO"
et enfin la sub "sending_mail_CDO" qui permet d'envoyer la plage percidé en paramètre a un ou plusieurs destinataires
a vous bien évidement de modifier les paramètres (serveur smtp, émetteur , destinataire ,titre du sujet, texte avant la grille, après la grille ,etc....) les possibilité n'ont presque pas de limite

allons y !:
fonction "RangE_tO_HTML"
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
Function RangE_tO_HTML(plage)
    Dim dicorange, codehtml, matable, elem, ligne As Long, i As Long, e As Long, cel As Range, aligne As String, valigne As String
    Set dicorange = CreateObject("Scripting.Dictionary")
    With CreateObject("htmlfile")
        For i = 1 To plage.Rows.Count
            codehtml = codehtml & "<TR class= ligne" & i & ">"
            For e = 1 To plage.Columns.Count
                If Not dicorange.exists(plage.Cells(i, e).MergeArea.Address) Then
                    dicorange(plage.Cells(i, e).MergeArea.Address) = ""
                    If Not IsNull(plage.Cells(i, e).Font.Color) Or plage.Cells(i, e).Font.Name = "" Then
                        codehtml = codehtml & "<TD" & " id= " & plage.Cells(i, e).MergeArea.Address & ">" & plage.Cells(i, e).Value & "</TD>"
                    Else
                        codehtml = codehtml & "<TD" & " id= " & plage.Cells(i, e).MergeArea.Address & ">" & BYSPAN(plage.Cells(i, e).Cells(1)) & "</TD>"
                    End If
                End If
            Next
            codehtml = codehtml & vbCrLf & "</TR>" & vbCrLf
        Next
        .body.innerhtml = "<table>" & vbCrLf & Replace(codehtml, "></TD>", ">&nbsp;</TD>") & vbCrLf & "</table>" & vbCrLf & "<html>"
        Set matable = .getelementsbytagname("table")(0)
        matable.cellpadding = 0: matable.cellspacing = 0:
        'matable.Style.Bordercollapse = "collapse"
        matable.Style.letterspacing = 1
        For Each elem In .all
            Select Case elem.tagname
            Case "TD"
                elem.colspan = Range(elem.ID).Columns.Count
                elem.rowspan = Range(elem.ID).Rows.Count
                With elem.Style
                    Set cel = Range(elem.ID).Cells(1)
                    .backgroundcolor = coul_XL_to_coul_HTMLX(Range(elem.ID).Interior.Color)
                    aligne = cel.HorizontalAlignment
                    .TextAlign = Switch(aligne = -4131, "Left", aligne = -4152, "Right", aligne = -4108, "Center", aligne = 1, "Left")
                    valigne = Range(elem.ID).VerticalAlignment
                    .verticalAlign = Switch(valigne = -4160, "top", valigne = -4107, "bottom", valigne = -4108, "middle")
                    .Width = cel.Width * 96 / 72
                    .Height = cel.Height * 96 / 72
                    If elem.Children.Length = 0 Then
                        .Color = coul_XL_to_coul_HTMLX(cel.Font.Color)
                        .FontWeight = IIf(cel.Font.Bold, "Bold", "normal")
                        .fontFamily = cel.Font.Name
                        .FontStyle = IIf(cel.Font.Italic = True, "italic", "normal")
                        .FontSize = cel.Font.Size - 1 & "pt"
                    End If
                    bordures elem, plage    ' mise en place des bordures
                End With
            Case "SPAN"
                Debug.Print elem.classname
                elem.Style.FontStyle = IIf(InStr(LCase(elem.classname), "italique") > 0, "italic", "normal")
                elem.Style.Color = coul_XL_to_coul_HTMLX(Split(elem.classname, "_")(0))
                elem.Style.fontFamily = Split(elem.classname, "_*")(1)
                elem.Style.FontSize = IIf(InStr(elem.classname, "fsise") > 1, Right(elem.classname, 2) & "pt", "")
                elem.Style.FontWeight = IIf(InStr(elem.classname, "Gras") > 0, "bold", "normal")
                elem.classname = ""
            End Select
        Next
        RangE_tO_HTML = .body.innerhtml
    End With
End Function
fonction "BYSPAN"
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
Function BYSPAN(cel)
    Dim couleur As String, sfont As String, foname As String, fsize As String, Lclass As String, Lclass2 As String, Lespan As String, e As Long
    couleur = cel.Characters(Start:=1, Length:=1).Font.Color
    sfont = Replace(cel.Characters(Start:=1, Length:=1).Font.FontStyle, " ", "_")
    foname = cel.Characters(Start:=1, Length:=1).Font.Name
    fsize = "0" & Round(cel.Characters(Start:=1, Length:=1).Font.Size) - 1
    Lclass = couleur & "_" & sfont & "_*" & foname & "_*fsise" & fsize
    Lespan = "<SPAN class= " & Replace(Lclass, " ", "") & " >" & Replace(cel.Characters(Start:=1, Length:=1).Text, " ", "<FONT>&nbsp;</FONT>")
    For e = 2 To Len(cel.Value)
        couleur = cel.Characters(Start:=e, Length:=1).Font.Color
        sfont = Replace(cel.Characters(Start:=e, Length:=1).Font.FontStyle, " ", "_")
        foname = cel.Characters(Start:=e, Length:=1).Font.Name
        fsize = "0" & Round(cel.Characters(Start:=e, Length:=1).Font.Size) - 1
        Lclass2 = couleur & "_" & sfont & "_*" & foname & "_*fsise" & fsize
        If Lclass2 = Lclass Then
            Lespan = Lespan & Replace(cel.Characters(Start:=e, Length:=1).Text, " ", "<FONT>&nbsp;</FONT>")
        Else
            Lespan = Lespan & "</SPAN><SPAN  class= " & Replace(Lclass2, " ", "") & " >" & cel.Characters(Start:=e, Length:=1).Text
            Lclass = Lclass2
        End If
    Next
    BYSPAN = Lespan & "</SPAN> "
End Function
fonction bordures
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
Function bordures(elem, plage)
    Dim cel As Range, coté, e As Long, LsTyLe As String, Eptrait, StyleB, CouleurB
    Set cel = Range(elem.ID)
    coté = Array(, xlEdgeLeft, xlEdgeRight, xlEdgeTop, xlEdgeBottom)
    For e = 1 To UBound(coté)
        LsTyLe = Replace(cel.borders(coté(e)).LineStyle & cel.borders(coté(e)).Weight, "-", "")
        Eptrait = Switch(LsTyLe = 41182, 2, LsTyLe = 41152, 1, LsTyLe = 41154138, 2, LsTyLe = 44138, 3, LsTyLe = 12, 1, LsTyLe = 14138, 2, LsTyLe = 14, 3, LsTyLe = 41422, 1, LsTyLe = 41194, 3)
        StyleB = Switch(LsTyLe = 41182, "dotted", LsTyLe = 41152, "dotted", LsTyLe = 41154138, "dashed", LsTyLe = 44138, "dashed", LsTyLe = 12, "solid", LsTyLe = 14138, "solid", LsTyLe = 14, "solid", LsTyLe = 41422, "solid", LsTyLe = 41194, "double")
        CouleurB = IIf(cel.borders(coté(e)).LineStyle = xlNone, coul_XL_to_coul_HTMLX(15853019), coul_XL_to_coul_HTMLX(cel.borders(coté(e)).Color))
        If cel.borders(coté(e)).LineStyle = xlNone Then Eptrait = 1: StyleB = "solid"
        Select Case e
        Case 1
            If cel.Column = plage.Column Then elem.Style.Borderleft = Eptrait & "px " & StyleB & "  " & CouleurB
        Case 2
            elem.Style.Borderright = Eptrait & "px " & StyleB & "  " & CouleurB
        Case 3
            If cel.Row = plage.Row Then elem.Style.Bordertop = Eptrait & "px " & StyleB & "  " & CouleurB
        Case 4
            elem.Style.Borderbottom = Eptrait & "px " & StyleB & "  " & CouleurB
        End Select
    Next
End Function
edit visiblement le post est trop long en fin voila
6 la fonction css_outline
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
Public Function CSs_outline(code, Optional codeht, Optional codestyle)
    Dim iedoc, dicostyle, css, elem, a, i, codehtml, lestyle
    Set iedoc = CreateObject("htmlfile")
    Set dicostyle = CreateObject("Scripting.Dictionary")
    codehtml = code
    With iedoc
        .body.innerhtml = code
        For Each elem In .all
            If InStr(elem.outerhtml, "style=") > 0 Then css = Split(Split(elem.outerhtml, "style=""")(1), Chr(34))(0)
            If Not dicostyle.exists(css) Then
                a = a + 1
                dicostyle(css) = "Style" & a
            End If
            codehtml = Replace(codehtml, "style=""" & css, "class= " & dicostyle(css))
            Debug.Print Replace(elem.outerhtml, "style=""" & css, "class= " & dicostyle(css))
        Next
        codehtml = Replace(codehtml, """", "")
        For Each elem In dicostyle
            lestyle = lestyle & vbCrLf & "." & dicostyle(elem) & "{" & Replace(elem, ";", ";" & vbCrLf & "    ") & vbCrLf & "}" & vbCrLf
        Next
        codestyle = "<style>" & lestyle & "</style>"
        codeht = codehtml
        CSs_outline = "<!DOCTYPE HTML>" & vbCrLf & "<html>" & vbCrLf & "<head>" & vbCrLf & codestyle & vbCrLf & codeht & vbCrLf & "</head>" & vbCrLf & "<body>"
    End With
End Function
7 J OUBLIAIS LA FONCTION COULEUR HTML
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
Public 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
maintenant quelques exemple d'utilisation

créer un fichier html sans séparer le code css du code html
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
Sub createfich_HTML_css_inline()
    Dim intFic As Integer, plage As Range, texte As String, chemin As String
    Set plage = Range("A1:d5")
    chemin = "C:\Users\" & Environ("UserName") & "\Desktop\" & Replace(plage.Address, ":", "-") & ".html"
    texte = "<!DOCTYPE HTML>" & vbCrLf & "<HTML>" & vbCrLf & "<BODY>" & RangE_tO_HTML(plage) & vbCrLf & "</BODY>" & "<HTML>"
    intFic = FreeFile
    Open chemin For Output As intFic
    Print #intFic, texte
    Close intFic
    'Debug.Print texte
End Sub
créer un fichier html en séparant le code css du code html
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
Sub createfich_HTML_css_outline()
    Dim intFic As Integer, plage As Range, chemin As String, texte As String, code As String
    Set plage = Range("A1:d5")
    chemin = "C:\Users\" & Environ("UserName") & "\Desktop\" & Replace(plage.Address, ":", "-") & ".html"
    texte = RangE_tO_HTML(plage)
    code = CSs_outline(texte)
    intFic = FreeFile
    Open chemin For Output As intFic
    Print #intFic, code
    Close intFic
End Sub
récupérer le style css ou le code html de la plage
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
 
Sub recupcode_css_html()
'recup le code css et html séparéSet plage = Range("A1:d5")
    Dim code As String, plage As Range, codehtml As String, codestyle As String
    Set plage = Range("A1:d5")
    code = RangE_tO_HTML(plage)
    CSs_outline code, codehtml, codestyle
    MsgBox codehtml    ' donne le code html de la table correspondant a la plage sans le style
    MsgBox codestyle    ' donne le code style css  de la table correspondant a la plage
 
End Sub
et enfin le mail
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
 
Option Explicit
Sub sending_mail_CDO()
    Dim iMsg As Object, iConf As Object, Flds As Object, serveur, destinataire, emetteur, sujet, code, codehtml, codestyle, plage
    Dim debtexte, fintexte, pagefooter, message
    debtexte = "Bonjour voici le tableau que vous m'avez demandé; il represente le récapitulatif du mois  du mois; "
    fintexte = " Vous souhaitant bonne reception ;je reste a votre disposition pour de plus amples renseignements;"
    pagefooter = "mon entreprise;Cordialement;;moi@live.com"
 
    serveur = "smtp.orange.fr"
    destinataire = "l'autre@hotmail.fr"
    emetteur = "moi@live.com"
    sujet = "essaie de mail "
 
    'récupération du code html correspondant a la plage
    Set plage = Range("A1:d5")
    code = RangE_tO_HTML(plage)    'on créé le code avec le style inline(dans les balises html)
    CSs_outline code, codehtml, codestyle    ' on separe le code html du code CSS
    message = "<!DOCTYPE HTML>" & vbCrLf & "<HTML>" & vbCrLf & "<head>" & vbCrLf & codestyle & "</head>" & vbCrLf & "</BODY>"
    message = message & Replace(debtexte, ";", "<BR>")
    message = message & codehtml & vbCrLf & "<BR>"
    message = message & Replace(fintexte, ";", "<BR>")
    message = message & Replace(pagefooter, ";", "<BR>")
    message = message & "</BODY></HTML>"
    Set iMsg = CreateObject("cdo.message")
    Set iConf = CreateObject("cdo.configuration")
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        'remplacez "serveur" par le nom de serveur smtp de votre FAI si vous utilisez pas la variable serveur
        'http://outlook.developpez.com/faq/index.php?page=Configuration#Paras_FAI
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = serveur
        .Update
    End With
    With iMsg
        Set .Configuration = iConf
        .To = destinataire
        .From = emetteur
        .Subject = sujet
        .HTMLBody = message
        ' .AddAttachment 'c:\mon dossier\monfichier.extention"
        .Send
    End With
    MsgBox "Le message a été envoyé"
End Sub
vous me direz a quoi ca sert sachant que l'on peut enregistrer une feuille un classeur , une sélection de cellules en HTML cette fonction existe
je vous répondrais avec ces 2 capture s
fait le avec Excel et avec ma méthode et comparez vous comprendrez
capture excel
Pièce jointe 180436


capture dans mon Outlook
Pièce jointe 180438

voila le résultat parle pour moi

vous avez plus qu'a mettre toutes ces fonctions dans un module et vous en servir
Bonne utilisation

qu'en pensez vous ??