Grille excel to html nouvelle version

**patricktoulon** · 05/04/2015, 00h07

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 : 663
Taille : 327,5 Ko

Nom : Capture.JPG
Affichages : 663
Taille : 327,5 Ko

**mercatog** · 06/04/2015, 00h59

Tu en rajoutes un petit peu Patrick. La brise à Toulon en est la cause?

Pour ta fonction borderweight, as tu vraiment besoin de passer par les constatntes nommées?

Ceci ne suffit pas?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Resultat = Array(1, 2, 3, 1)
valconst = Array(1, -4138, 4, 2)
BorderWeight = Application.Index(Resultat, Application.Match(Cote, valconst, 0))

Ou carrément une autre variante

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Function BorderWeight2(Cote)
 
If Cote < 0 Then Cote = 3
Resultat = Array(1, 1, 2, 3)
BorderWeight2 = Resultat(Cote - 1)
End Function

Ou

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Function BorderWeight3(Cote)
 
If Cote < 1 Then Cote = 3
BorderWeight3 = Application.Max(1, Cote - 1)
End Function

**patricktoulon** · 06/04/2015, 08h40

Bonjour Mercatog

je souhaitait utiliser les constante possible en css '"thin","medium","thick" un replace sur le "xl" aurait été parfait, c'est pour ca que je voulais le retour en constantes excel '"xlthin","xlmedium","xlthick"

**mercatog** · 06/04/2015, 17h01

Bonjour Le Toulonnais

Pour ce cas un switch suffit au lieu de ramer (une expression qui t'est trop chère)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Function borderweight(Cote) As String
 
borderweight = Switch(Cote = 1, "Thin", Cote = -4138, "Medium", Cote = 4, "Thin", Cote = 2, "Thick")
End Function

**patricktoulon** · 06/04/2015, 17h20

Re
je dois reconnaitre que celle la me plais beaucoup
je ne connaissais pas la fonction switch je l'adopte

pour que je comprenne bien la fonction switch prend la valeur après la virgule automatiquement c'est son rôle tout du moins ?

en tout c'est top Merci

**patricktoulon** · 06/04/2015, 17h55

bon finalement
les constantes CSS("thin,"medium","thick") sont supérieur de 1 point a leur homologue Excel alors je garde les unité en px mais avec switch

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Function borderweight(Cote) As String
borderweight = Switch(Cote <= 2, 1, Cote = -4138, 2, Cote = 4, 3)
End Function

Grille excel to html nouvelle version

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager