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
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
| Sub clearall2()
' on efface tout dans le webbrowser
With Sheets(2).WebBrowser1
.Activate
.Object.Navigate "about:blank"
Do: DoEvents: Loop While .ReadyState <> 4
.Refresh
End With
End Sub
Sub test2()
Dim code, TR, TD, ppx, IMG, SH, P
Set SH = Sheets(2) ' adapte ton sheets
code = ""
meta = "<meta charset=""utf-8"">" & vbCrLf & "<title>patrick editeur html </title>" & vbCrLf & "<meta http-equiv=""X-UA-Compatible"" content=""IE=edge"">" & vbCrLf
' un peu de style et de couleur avec ce temps pourri ne fait pas de mal
'css style
lestyle = "td{background-color:#BDBDBD;font-size:10px;BORDER-TOP: black 1px solid; HEIGHT: 80px; BORDER-RIGHT: black 1px solid; WIDTH: 170px; BORDER-BOTTOM: black 1px solid; BORDER-LEFT: black 1px solid;}" & vbCrLf
lestyle = lestyle & "IMG{margin-top:0px;left:60px;float:right;BORDER-TOP: red 1px solid; HEIGHT: 60px; BORDER-RIGHT: red 1px solid; WIDTH: 60px; BORDER-BOTTOM: red 1px solid; BORDER-LEFT: red 1px solid;}" & vbCrLf
lestyle = lestyle & ".titre{height:15px;font-size:15px;background-color:#04B4AE;color:white;font-weight: 900;font-family:algerian;}" & vbCrLf
lestyle = lestyle & ".jour{text-shadow: 2px 2px yellow;color:#FE642E;font-family:arial black;font-size:11px;}" & vbCrLf
lestyle = lestyle & ".condition{text-shadow: 0px 0px 5px black;color:white;font-family:algerian;font-size:20px;}" & vbCrLf
lestyle = lestyle & ".nuit{color:#FF00FF;font-family:algerian;font-size:20px;}" & vbCrLf
lestyle = lestyle & ".fondnuit{background-color:#3A5496;}"
lestyle = lestyle & ".meteo{text-shadow: 2px 2px black;color:yellow;font-family:arial black;font-size:11px;}" & vbCrLf
lestyle = lestyle & "*,p{margin-top:0px;}" & vbCrLf
' structure base
codedeb = "<!doctype html>" & vbCrLf & "<html>" & vbCrLf & "<head>" & vbCrLf & meta & vbCrLf & "<style>" & vbCrLf & lestyle & "</style>" & vbCrLf & "</head>" & vbCrLf & _
"<body>" & vbCrLf
codefin = "</body>" & vbCrLf & "</html>"
'creation de l'element html table en DOM
With CreateObject("htmlfile")
.body.innerhtml = "<table></table>" ' on met une balise table vide
Set Table = .getelementsbytagname("TABLE")(0)
Table.Style.Width = 170 * 7 & "px" ' on determine le width
For lig = 1 To SH.Cells(Rows.Count, 1).End(xlUp).Row ' boucle sur les ligne
If SH.Cells(lig, 1).Font.Bold Then 'si c'est en font bold alors c'est le nom de la ville
lig2 = lig + 1 ' on memorise l'index de ligne du premier jour de la semaine
fois = fois + 1 ' fois sera le nombre a multiplier par le height d'une cellule html pour le height de la table
Table.Style.Height = 80 * fois & "px"
Set TR = .createelement("TR") ' on créé donc la 1 ere ligne
Set TD = .createelement("TD") 'on créé la premiere cellule
TD.classname = "titre" 'comme c'est une ville on lui attribut la classe titre
TD.innertext = SH.Cells(lig, 1).Value ' on inscrit le nom de la ville
TD.colspan = 7 ' on merge toute les colonne
TR.appendchild (TD) ' on insert la cellule dans la ligne html
Table.appendchild (TR) 'on insert la ligne dans la table
Set TR = .createelement("TR") ' on créé une ligne suivante ce sera la 1 ere ligne 1 ville
Table.appendchild (TR) 'on insert la ligne dans la table
Else ' si c'est pas un titre alors on commence les jours
TR.classname = lig2 'on met la class a la ligne que l'on a memorisé précèdement
Set TD = .createelement("TD") ' on cré donc la cllule jour
' on lui met le texte dans des balise span avec class pour les distinguer avec le css
Set P = .createelement("P")
P.innerhtml = "<span class=""jour"">" & SH.Cells(lig, 1).Value & "</span>"
Set IMG = .createelement("IMG") ' on ajoute l'image
IMG.src = "Z:\METEO_2016\GIF_flipbooks\" & Cells(lig, 3).Text & "_Day.gif" 'on lui attribu son src avec le texte de la cellule + le jour ou nuit
'chez moi c'est IMG.src = ThisWorkbook.Path & "\" & Cells(lig, 3).Text & "_Day.gif" 'on lui attribu son src avec le texte de la cellule + le jour ou nuit
P.innerhtml = P.innerhtml & IMG.outerhtml
TD.appendchild (P)
Set P = .createelement("P")
P.innerhtml = "<span class=""condition"">" & SH.Cells(lig, 2).Value & "</span>"
TD.appendchild (P)
TD.innerhtml = TD.innerhtml & "<p></p>"
Set P = .createelement("P")
P.innerhtml = "<span class=""meteo"">" & Cells(lig, 3).Text & "</span>"
TD.appendchild (P)
'TD.innerhtml = "<span class=""jour"">" & SH.Cells(lig, 1).Value & "</span>" & "<br>" & "<span class=""condition"">" & SH.Cells(lig, 2).Value & "</span>" & _
'"<br>" & "<span class=""meteo"">" & Cells(lig, 3).Text & "</span>"
'Set IMG = .createelement("IMG") ' on ajoute l'image
'IMG.src = "Z:\METEO_2016\GIF_flipbooks\" & Cells(lig, 3).Text & "_Day.gif" 'on lui attribu son src avec le texte de la cellule + le jour ou nuit
'IMG.src = ThisWorkbook.Path & "\" & Cells(lig, 3).Text & "_Day.gif" 'on lui attribu son src avec le texte de la cellule + le jour ou nuit
'TD.appendchild (IMG) 'on insert l'image dans la cellule
TR.appendchild (TD) 'on insert la cellule créé avec toutze les données dans la ligne
End If
Next
'voila on a maintenant une table de x ligne sur 6 cellules
'on va maintenant ajouter la nuit pour le first day
Set mestr = .getelementsbytagname("TR") ' on collectionne toute les ligne html
For l = 0 To mestr.Length - 1 ' on boucle sur le nombre de ligne
If mestr(l).classname <> "" Then ' si la ligne a une class (index de ligne memorisée)
ligne = mestr(l).classname ' on determine l'index
Set TD = .createelement("TD") ' on créé la cellule nuit (7 emecellule de la ligne )
TD.classname = "fondnuit" ' on lui attribut une classe pour la distinguer dans le css
' on lui met les données toujour pareil dans des span avec class pour le css
Set P = .createelement("P")
P.innerhtml = "<span class=""nuit"">NUIT </span> " & "<span class=""jour"">" & SH.Cells(ligne, 1).Value & "</span>"
Set IMG = .createelement("IMG") ' on ajoute l'image
IMG.src = "Z:\METEO_2016\GIF_flipbooks\" & SH.Cells(ligne, 5).Text & "_Night.gif" 'on lui attribu son src (nuit)
' chez moi c'est IMG.src = ThisWorkbook.Path & "\" & SH.Cells(ligne, 5).Text & "_Night.gif"
P.appendchild (IMG)
TD.appendchild (P)
Set P = .createelement("P")
P.innerhtml = "<span class=""condition"">" & SH.Cells(ligne, 4).Value & "</span>"
TD.appendchild (P)
Set P = .createelement("P")
P.innerhtml = "<span class=""meteo"">" & SH.Cells(ligne, 5).Value & "</span>"
TD.appendchild (P)
Debug.Print "valeur cellule =" & SH.Cells(ligne, 5).Text & " fichier= " & Dir(ThisWorkbook.Path & "\" & Cells(lig2, 5).Text & "_Night.gif")
' apartir de la on a le choix soit on met la cellule nuit en fin de ligne soit apres le first day
'en fin de ligne
'mestr(l).appendchild (TD)' si tu veux la nuit en fin de ligne debloque cette ligne et bloque la suivante
' apres le first day
mestr(l).InsertBefore TD, mestr(l).ChildNodes(1)
End If
Next
' voila on a maintenant le code html complet de la table on construit donc le code complet pour le webbrowser
code = codedeb & .body.innerhtml & vbCrLf & codefin
End With
' il nous reste plus qu'a l'injecter dans le htmldocument du webbrowser
With Sheets(2).WebBrowser1
.Activate
.Object.Navigate "about:blank"
Do: DoEvents: Loop While .ReadyState <> 4
.Refresh
.Object.Document.write code
.Refresh
'Debug.Print code
End With
propos = "chisissez le format d'enregistrement fichier" & vbCrLf
propos = propos & "tapez 1 pour le format HTML" & vbCrLf
propos = propos & "tapez 2 pour le format TXT" & vbCrLf
propos = propos & "tapez 0 ou annuler pour annuler"
myvalue = Application.InputBox(propos, "enregistrement fichier ", "", Type:=1)
If StrPtr(myvalue) = 0 Or myvalue = 0 Then Exit Sub
extention = Array("", ".HTML", ".TXT")
'fichier = Environ("UserProfile") & "\Desktop\" & "SQL metéo " & Environ("UserName") & Format(Date, " dd-mm-yyyy") & extention(myvalue)
fichier = "C:\Users\" & Environ("UserName") & "\Desktop\" & "SQL metéo " & Environ("UserName") & Format(Date, " dd-mm-yyyy") & extention(myvalue)
x = FreeFile
Open fichier For Output As #x
Print #x, code
Close #x
End Sub
'voila c'est magic!!!!! |
