Sub ExtraireHtmlDatas()
' Les compteurs de boucles et d'items de tableaux
Dim j As Integer, i As Integer, k As Integer, L As Integer
Dim nbRecettes As Integer, nbIngrédients As Integer, nbProcédés As Integer
Dim msg As String ' message d'erreur ou final
'
' le document html en cours de traitement dans la boucle
Dim HFileName As Variant ' son nom (laisser en variant)
Dim HDoc As HTMLDocument ' son objet document
Dim HTables ' ses tables
Dim HTable As HTMLTable ' une table en cours de traitement
Dim HParas As Object ' les paragraphes de procédés
'
' les tableaux en mémoire qui contiendront les données
Dim Fichiers() As String ' la liste des fichiers
Dim Recettes() ' la liste des infos recette
Dim Ingrédients() ' la liste des ingrédients
Dim Procédés() ' la liste des procédés
Dim PLignes() As String ' la liste des lignes d'un procédé
'
' obtenir la liste des fichiers du répertoire
Fichiers = GetFichiers()
For Each HFileName In Fichiers
'
' Chargement du doc html
Set HDoc = GetHtmlDoc(ThisWorkbook.Path & "\php2\" & HFileName, "iso-8859-1")
'
' Récupération des HTables html
Set HTables = HDoc.getElementsByTagName("table")
'
'
Set HTable = HTables(0)
nbRecettes = nbRecettes + 1
ReDim Preserve Recettes(1 To 9, 1 To nbRecettes)
'
' formater l'identifiant de recette à partir du nom de fichier
Recettes(1, nbRecettes) = Replace(Replace(HFileName, ".html", ""), "recettefiche", "")
' récupération du nom de recette
Recettes(2, nbRecettes) = Trim(HTable.Rows(0).Cells(0).innerText)
' formater le coût par portion
Recettes(3, nbRecettes) = Trim(Replace(HTable.Rows(1).Cells(0).innerText, "Coût par portion :", ""))
' Récupération de la table Bilan nutritionnel
Set HTable = HTable.Rows(3).Cells(0).getElementsByTagName("Table")(0)
' Récupération des valeurs de la table
Recettes(4, nbRecettes) = Trim(Split(HTable.Rows(0).Cells(0).innerText, ":")(1)) ' Energie
Recettes(5, nbRecettes) = Trim(Split(HTable.Rows(1).Cells(0).innerText, ":")(1)) ' Glucides
Recettes(6, nbRecettes) = Trim(Split(HTable.Rows(2).Cells(0).innerText, ":")(1)) ' Protéines
Recettes(7, nbRecettes) = Trim(Split(HTable.Rows(0).Cells(1).innerText, ":")(1)) ' Lipides
Recettes(8, nbRecettes) = Trim(Split(HTable.Rows(1).Cells(1).innerText, ":")(1)) ' Sodium
Recettes(9, nbRecettes) = Trim(Split(HTable.Rows(2).Cells(1).innerText, ":")(1)) ' Rapport P/L
'
' Ingrédients
Set HTable = HTables(0).Rows(4).getElementsByTagName("Table")(0)
k = HTable.Rows.Length
For j = 1 To k - 1
nbIngrédients = nbIngrédients + 1
ReDim Preserve Ingrédients(1 To 4, 1 To nbIngrédients)
' Identifiant recette
Ingrédients(1, nbIngrédients) = Recettes(1, nbRecettes)
' Récupération de l'ingrédient
Ingrédients(2, nbIngrédients) = Trim(HTable.Rows(j).Cells(0).innerText)
' Récupération de la quantité
Ingrédients(3, nbIngrédients) = Val(Trim(HTable.Rows(j).Cells(1).innerText))
' Récupération de l'unité
Ingrédients(4, nbIngrédients) = Trim(HTable.Rows(j).Cells(2).innerText)
Next
'
' Procédés
Set HParas = HTables(0).Rows(5).Cells(0).getElementsByTagName("P")
k = HParas.Length
j = 0
'
' Parcourir les paragraphes html
For i = 1 To k - 1
' Eclater en lignes suivant l'existence de points ou non
PLignes = Split(Trim(Replace(HParas(i).innerText, "U.H.T", "UHT")), ".")
'
' Parcourir le tableau des lignes
' pour les ajouter au procédé si elles ne sont pas vides.
' chaque ligne reçoit un index d'étape de 1 au nombre de lignes du procédé.
j = 0 ' index du procédé pour la recette
For L = 0 To UBound(PLignes) - 1
If Len(Trim(PLignes(L))) > 0 Then
PLignes(L) = Replace(PLignes(L), vbCrLf, "")
j = j + 1
nbProcédés = nbProcédés + 1
ReDim Preserve Procédés(1 To 3, 1 To nbProcédés)
Procédés(1, nbProcédés) = Recettes(1, nbRecettes) 'identifiant recettes
Procédés(2, nbProcédés) = j ' index d'étape
Procédés(3, nbProcédés) = PLignes(L) ' texte de la ligne
End If
Next
Next
Set HParas = Nothing
Set HTable = Nothing
Set HTables = Nothing
Next
Set HDoc = Nothing
msg = "1 - Recettes : "
If CréerTableau("Recettes", Application.Transpose(Recettes)) Then
msg = msg & UBound(Recettes, 2) & " ligne(s) créée(s). "
Else
msg = msg & "echec de la création "
End If
msg = msg & vbCrLf & "2 - Ingrédients : "
If CréerTableau("Ingrédients", Application.Transpose(Ingrédients)) Then
msg = msg & UBound(Ingrédients, 2) & " ligne(s) créee(s). "
Else
msg = msg & "echec de la création "
End If
msg = msg & vbCrLf & "3 - Procédés : "
If CréerTableau("Procédés", Application.Transpose(Procédés)) Then
msg = msg & UBound(Procédés, 2) & " ligne(s) créee(s). "
Else
msg = msg & "echec de la création "
End If
MsgBox msg, vbInformation, "Création des tableaux"
End Sub
Function CréerTableau(ByVal Nom As String, datas As Variant) As Boolean
Dim ws As Worksheet
Dim nbLig As Long 'compteur de lignes de procédés
With ThisWorkbook
'
' Récupération ou création de la feuille
On Error Resume Next
Set ws = .Sheets(Nom)
If ws Is Nothing Then
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = Nom
Else
ws.Range("A1").CurrentRegion.Delete xlShiftUp
End If
End With
On Error GoTo FIN
With ws
Select Case LCase(Nom)
Case "recettes"
.Cells(1, 1).Resize(, 9).Value = Array("Id", "Titre", "Coût", "Energie", "Glucides", "Protéines", "Lipides", "Sodium", "Rapport P/L")
Case "ingrédients"
.Cells(1, 1).Resize(, 4).Value = Array("Id Recette", "Ingrédient", "Quantité", "UG")
Case "procédés"
.Cells(1, 1).Resize(, 3).Value = Array("Id Recette", "Etape", "Description")
End Select
.Cells(2, 1).Resize(UBound(datas, 1), UBound(datas, 2)) = datas
.ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1, 1).CurrentRegion, xllistobjecthasheaders:=xlYes).Name = "T_" & Nom
CréerTableau = True
End With
FIN:
End Function
