XL 2021 Calendrier des marées info

Option Explicit
Sub ParVentEtMaré()

Dim city, url As String, VILLES()    As ville, conn As Object
 ' Créer une connexion ADODB
    Set conn = CreateADODBConnection(ThisWorkbook.FullName)
    For Each city In RetournVille(conn)

   ' Construire l'URL de la page web
    url = "https://horaire-maree.fr/maree/" & city & "/"
    If CheckURL(url, CStr(city)) And city <> "" Then
        RetorunVilleMatin CStr(city), VILLES, Now, GetHTMLDocument(url)
        RetorunVilleAprès CStr(city), Now, VILLES
        
        ' Insérer les données de marées
        ProcessAndInsertTideData conn, VILLES
    End If
 Next
    ' Fermer la connexion ADODB
    conn.Close
    Set conn = Nothing
 
  
End Sub
Sub RetorunVilleMatin(v As String, TbVille() As ville, D As String, htmlDoc As Object)

 Dim NB As Integer, Champ As Integer, tb, tb2, i As Integer, T, A
 tb = Split(htmlDoc.getElementById("i_donnesJour").getElementsByTagName("table")(0).innerhtml, "<TD class=""blueoffice whitetxt"">")
  For i = 1 To UBound(tb)
  ReDim Preserve TbVille(NB)
 If TypeName(TbVille(NB)) = "Nothing" Then Set TbVille(NB) = New ville
   TbVille(NB).ville = v: TbVille(NB).MyDate = Format(D, "yyyy-mm-dd")
    tb2 = Split(tb(i), "<STRONG>")
  
        For Each T In tb2
        
        Debug.Print T
           A = Split(Replace(Replace(Replace(Replace(T, "</STRONG>", ""), "<BR>", ";"), "<TD>", ""), "</TD>", "") & ";", ";")
           Select Case Champ
            Case 1: If A(0) <> "" Then TbVille(NB).Matin_Coeff = CStr(A(0))
            Case 2: If A(0) <> "" Then TbVille(NB).Matin_Basse_mere = CDate(Replace(A(0), "h", ":")): TbVille(NB).Matin_Basse_mere_Niveau_Zéro = Val(Replace(A(1), ",", "."))
            Case 3: If A(0) <> "" Then TbVille(NB).Matin_Pleine_mere = CDate(Replace(A(0), "h", ":")): TbVille(NB).Matin_Pleine_mere_Niveau_Zéro = Val(Replace(A(1), ",", "."))
            Case 4: If A(0) <> "" Then TbVille(NB).Après_midi_Coeff = CStr(A(0))
            Case 5: If A(0) <> "" Then TbVille(NB).Après_midi_Basse_mere = CDate(Replace(A(0), "h", ":")): TbVille(NB).Après_midi_Basse_mere_Niveau_Zéro = Val(Replace(A(1), ",", "."))
            Case 6: If A(0) <> "" Then TbVille(NB).Après_midi_Pleine_mere = CDate(Replace(A(0), "h", ":")): TbVille(NB).Après_midi_Pleine_mere_Niveau_Zéro = Val(Replace(A(1), ",", "."))
           End Select
           Champ = Champ + 1
        Next
        
  Next

End Sub
Function RetournVille(Cn As Object) As String()
With Cn.Execute("Select * from[VILLES$]")
    If .EOF Then RetournVille = Array("")
    RetournVille = Split(.getstring, vbCr)
End With
End Function
'Sub RetorunVilleAprès(city As String, D As String, VS() As ville)
'Dim tideTable As Object, htmlDoc As Object
'  ' Récupérer le document HTML
'    Set htmlDoc = GetHTMLDocument("https://horaire-maree.fr/maree/" & city & "/")
'
'    ' Trouver la table de marées par ID
'    Set tideTable = htmlDoc.getElementById("i_donnesLongue").getElementsByTagName("table")(0)
'
'    ' Extraire les données de marées
'    Set tideData = ExtractTideData(tideTable)
'    For i = 1 To tideData.count
'        ReDim Preserve VS(i)
'
'        If TypeName(VS(i)) = "Nothing" Then Set VS(i) = New ville
'         VS(i).ville = city
'         VS(i).MyDate = Format((CDate(D) + i), "yyyy-mm-dd")
'
'        If Trim("" & tideData(i)(2)) <> "" Then VS(i).Matin_Coeff = tideData(i)(2)
'        If Trim("" & tideData(i)(3)) <> "" Then
'            VS(i).Matin_Basse_mere = Replace(Left(tideData(i)(3), 5), "h", ":")
'            VS(i).Matin_Basse_mere_Niveau_Zéro = Val(Replace(Split(tideData(i)(3), Left(tideData(i)(3), 5))(1), ",", "."))
'        End If
'        If Trim("" & tideData(i)(4)) <> "" Then
'            VS(i).Matin_Pleine_mere = Replace(Left(tideData(i)(4), 5), "h", ":")
'            VS(i).Matin_Basse_mere_Niveau_Zéro = Val(Replace(Split(tideData(i)(4), Left(tideData(i)(4), 5))(1), ",", "."))
'        End If
'        If Trim("" & tideData(i)(5)) <> "" Then VS(i).Après_midi_Coeff = tideData(i)(5)
'        If Trim("" & tideData(i)(6)) <> "" Then
'            VS(i).Après_midi_Basse_mere = Replace(Left(tideData(i)(6), 5), "h", ":")
'            VS(i).Après_midi_Basse_mere_Niveau_Zéro = Val(Replace(Split(tideData(i)(6), Left(tideData(i)(6), 5))(1), ",", "."))
'        End If
'        If Trim("" & tideData(i)(7)) <> "" Then
'            VS(i).Après_midi_Pleine_mere = Replace(Left(tideData(i)(7), 5), "h", ":")
'            VS(i).Après_midi_Pleine_mere_Niveau_Zéro = Val(Replace(Split(tideData(i)(7), Left(tideData(i)(7), 5))(1), ",", "."))
'        End If
'
'    Next
'
'End Sub
Sub RetorunVilleAprès(city As String, D As String, VS() As ville)
    Dim tideTable As Object, htmlDoc As Object, rows As Object
    Dim i As Integer
    ' Récupérer le document HTML
    Set htmlDoc = GetHTMLDocument("https://horaire-maree.fr/maree/" & city & "/")
    
    ' Trouver la table de marées par ID
    Set tideTable = htmlDoc.getElementById("i_donnesLongue").getElementsByTagName("table")(0)
    Set rows = tideTable.getElementsByTagName("tr")

    ' Boucle pour parcourir toutes les lignes de données (ignorer les premières lignes de titres)
    For i = 1 To rows.Length - 2
        ReDim Preserve VS(i) ' Utilisation de i directement
        If TypeName(VS(i)) = "Nothing" Then Set VS(i) = New ville
        
        ' Extraire les cellules de chaque ligne
        Dim cells As Object
        Set cells = rows(i + 1).getElementsByTagName("td") ' i+1 pour ignorer la première ligne de titres
        
        ' Assurez-vous que la ligne contient des données (c'est-à-dire qu'elle a le bon nombre de colonnes)
        If cells.Length = 7 Then
            VS(i).ville = city
            VS(i).MyDate = Format((CDate(D) + i), "yyyy-mm-dd")
            
            If Trim("" & cells(1).innerText) <> "" Then VS(i).Matin_Coeff = cells(1).innerText
            If Trim("" & cells(2).innerText) <> "" Then
                VS(i).Matin_Basse_mere = Replace(Left(cells(2).innerText, 5), "h", ":")
                VS(i).Matin_Basse_mere_Niveau_Zéro = Val(Replace(Split(cells(2).innerText, Left(cells(2).innerText, 5))(1), ",", "."))
            End If
            If Trim("" & cells(3).innerText) <> "" Then
                VS(i).Matin_Pleine_mere = Replace(Left(cells(3).innerText, 5), "h", ":")
                VS(i).Matin_Pleine_mere_Niveau_Zéro = Val(Replace(Split(cells(3).innerText, Left(cells(3).innerText, 5))(1), ",", "."))
            End If
            If Trim("" & cells(4).innerText) <> "" Then VS(i).Après_midi_Coeff = cells(4).innerText
            If Trim("" & cells(5).innerText) <> "" Then
                VS(i).Après_midi_Basse_mere = Replace(Left(cells(5).innerText, 5), "h", ":")
                VS(i).Après_midi_Basse_mere_Niveau_Zéro = Val(Replace(Split(cells(5).innerText, Left(cells(5).innerText, 5))(1), ",", "."))
            End If
            If Trim("" & cells(6).innerText) <> "" Then
                VS(i).Après_midi_Pleine_mere = Replace(Left(cells(6).innerText, 5), "h", ":")
                VS(i).Après_midi_Pleine_mere_Niveau_Zéro = Val(Replace(Split(cells(6).innerText, Left(cells(6).innerText, 5))(1), ",", "."))
            End If
        End If
    Next i
End Sub

Sub ProcessAndInsertTideData(conn As Object, VILLES() As ville)
    Dim v As Integer
    Dim sql As String
    Dim Rs As Object
    Dim item As Variant

    For v = 0 To UBound(VILLES)
        
        
        ' Construire la requête SQL de sélection
        sql = "SELECT * FROM [Marées$] WHERE [Date]=#" & VILLES(v).MyDate & "# AND [Ville]='" & Replace(VILLES(v).ville, "'", "''") & "'"

        ' Créer un objet Recordset
        Set Rs = CreateObject("ADODB.Recordset")
        Rs.Open sql, conn, 1, 3
 
        If Rs.EOF Then Rs.AddNew ' Insérer une nouvelle ligne si la date et la ville n'existent pas
            
           If VILLES(v).ville <> "" Then Rs.Fields("Ville").Value = VILLES(v).ville
           If VILLES(v).MyDate <> "" Then Rs.Fields("Date").Value = VILLES(v).MyDate
            
             Rs.Fields("Matin Coeff").Value = VILLES(v).Matin_Coeff
            
           If VILLES(v).Matin_Basse_mere <> "" Then Rs.Fields("Matin Basse mer").Value = VILLES(v).Matin_Basse_mere
          Rs.Fields("Matin Basse mer Niveau Zéro").Value = VILLES(v).Matin_Basse_mere_Niveau_Zéro
            
           If VILLES(v).Matin_Pleine_mere <> "" Then Rs.Fields("Matin Pleine mer").Value = VILLES(v).Matin_Pleine_mere
       Rs.Fields("Matin Pleine mer Niveau Zéro").Value = VILLES(v).Matin_Pleine_mere_Niveau_Zéro
            
            
        Rs.Fields("Après-midi Coeff").Value = VILLES(v).Après_midi_Coeff
            
           If VILLES(v).Après_midi_Basse_mere <> "" Then Rs.Fields("Après-midi Basse mer").Value = VILLES(v).Après_midi_Basse_mere
        Rs.Fields("Après-midi Basse mer Niveau Zéro").Value = VILLES(v).Après_midi_Basse_mere_Niveau_Zéro
            
          If VILLES(v).Après_midi_Pleine_mere <> "" Then Rs.Fields("Après-midi Pleine mer").Value = VILLES(v).Après_midi_Pleine_mere
         Rs.Fields("Après-midi Basse mer Niveau Zéro") = VILLES(v).Après_midi_Pleine_mere_Niveau_Zéro
            Rs.Update


    Next
End Sub
Function CheckURL(url As String, ville As String) As Boolean

    Dim http As Object
    Dim statusCode As Integer
    Dim responseText As String
    
    ' Créer un objet ServerXMLHTTP
    Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    
    ' Envoyer une requête GET
   On Error GoTo Fin
    http.Open "GET", url, False
    http.setRequestHeader "User-Agent", "Mozilla/5.0" ' Ajouter un User-Agent
    http.send
  
    
    ' Obtenir le code de statut HTTP
  
    
    ' Obtenir le texte de la réponse

    responseText = LCase(http.responseText)
    CheckURL = InStr(responseText, LCase(ville))
Fin:
Err.Clear
 On Error GoTo 0
End Function
Function CreateADODBConnection(workbookPath As String) As Object
    Dim conn As Object
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & workbookPath & ";Extended Properties=""Excel 12.0;HDR=Yes"";"
    Set CreateADODBConnection = conn
End Function

Function GetHTMLDocument(url As String) As Object
    Dim http As Object
    Dim htmlDoc As Object

    ' Créer une nouvelle instance de MSXML2.XMLHTTP
    Set http = CreateObject("MSXML2.XMLHTTP")
    
    ' Envoyer une requête GET pour récupérer le contenu de la page
    http.Open "GET", url, False
    http.send
    
    ' Charger le contenu HTML dans un document
    Set htmlDoc = CreateObject("HTMLFile")
    htmlDoc.body.innerhtml = http.responseText
    
    Set GetHTMLDocument = htmlDoc
End Function


Function ExtractTideData(tideTable As Object) As Collection
    Dim rows As Object
    Dim row As Object
    Dim tideData As Collection
    Dim tideEntry As Collection
    Dim dateStr As String

    Set tideData = New Collection
    
    ' Parcourir chaque ligne de la table HTML
    Set rows = tideTable.getElementsByTagName("tr")
    For Each row In rows
        ' Obtenir la date à partir de la première cellule
        If row.getElementsByTagName("td").Length > 0 Then
            dateStr = row.getElementsByTagName("td")(0).innerText
            
            ' Vérifier si la date contient "août" (mois spécifié)
            If InStr(dateStr, "août") > 0 Then
                ' Créer une nouvelle entrée de marée
                Set tideEntry = New Collection
                tideEntry.Add Replace(dateStr, "Demain", "")
                tideEntry.Add row.getElementsByTagName("td")(1).innerText ' Matin Coeff
                tideEntry.Add row.getElementsByTagName("td")(2).innerText ' Matin Basse mer
                tideEntry.Add row.getElementsByTagName("td")(3).innerText ' Matin Pleine mer
                tideEntry.Add row.getElementsByTagName("td")(4).innerText ' Après-midi Coeff
                tideEntry.Add row.getElementsByTagName("td")(5).innerText ' Après-midi Basse mer
                tideEntry.Add row.getElementsByTagName("td")(6).innerText ' Après-midi Pleine mer
                tideData.Add tideEntry
            End If
        End If
    Next row
    
    Set ExtractTideData = tideData
End Function