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"
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
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>", "> </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 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
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> </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> </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
edit visiblement le post est trop long en fin voila
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
6 la fonction css_outline
7 J OUBLIAIS LA FONCTION COULEUR 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 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
maintenant quelques exemple d'utilisation
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
créer un fichier html sans séparer le code css du code html
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_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
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 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
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 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
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
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
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 Outlookqu'en pensez vous ??
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
Partager