' Module Mod_Horaire_Maree_fr
Option Explicit ' Force la déclaration explicite des variables
' Subroutine principale pour tester le fonctionnement
Sub test()
' Décommentez la ligne suivante pour rendre la feuille "villes" visible
' Sheets("villes").Visible = xlSheetVisible
' Appelle la fonction ParVentEtMaré avec le nom de la ville
ParVentEtMaré "LORIENT", "Lorient"
End Sub
' Subroutine pour obtenir les données de marées d'une ville donnée
Sub ParVentEtMaré(URL As String, Ville As String)
Dim VILLES() As Ville ' Déclare un tableau de type Ville
Dim conn As Object ' Déclare un objet pour la connexion ADODB
' Créer une connexion ADODB
Set conn = CreateADODBConnection(ThisWorkbook.FullName)
' Formater l'URL pour accéder aux données de marées
URL = "https://www.horaire-maree.fr/maree/" & AssainirURL(URL) & "/"
' Vérifie si l'URL est accessible et si la ville est valide
If CheckURL(URL, Trim("" & Ville)) Then
ReDim VILLES(0) ' Redimensionne le tableau pour contenir une ville
Set VILLES(0) = New Ville ' Crée une nouvelle instance de la classe Ville
' Récupère les données de marées pour la ville pour le jour actuel
RetorunVilleJour Trim("" & Ville), VILLES, Now, GetHTMLDocument(URL)
' Récupère les données de marées pour les jours suivants
RetorunVilleJourAprès Trim("" & Ville), VILLES, Now, GetHTMLDocument(URL)
' Insère les données de marées dans la base de données
ProcessAndInsertTideData conn, VILLES
End If
DoEvents ' Permet au système d'exécuter d'autres tâches
' Ferme la connexion ADODB
conn.Close
Set conn = Nothing ' Libère l'objet conn
ReDim VILLES(0) ' Redimensionne le tableau pour le nettoyer
Erase VILLES ' Efface le tableau
End Sub
' Subroutine pour retourner les données de marées pour un jour donné
Sub RetorunVilleJour(v As String, TbVille() As Ville, D As String, htmlDoc As Object)
Dim table As Object ' Déclare un objet pour le tableau HTML
Dim rows As Object ' Déclare un objet pour les lignes du tableau
Dim cells As Object ' Déclare un objet pour les cellules de la ligne
Dim row As Object ' Déclare un objet pour une ligne spécifique
Dim cell As Object ' Déclare un objet pour une cellule spécifique
Dim I As Integer ' Déclare un index pour les boucles
' Sélectionner le tableau à partir du document HTML
Set table = htmlDoc.getElementById("i_donnesJour").getElementsByTagName("table")(0)
Set rows = table.getElementsByTagName("tr")
' Initialise les valeurs de la première entrée dans le tableau des villes
TbVille(0).Ville = v
TbVille(0).MyDate = Format(D, "yyyy-mm-dd")
' Parcourt chaque ligne à partir de la 3ème ligne (les données commencent ici)
For I = 2 To rows.Length - 1
Set row = rows(I) ' Récupère la ligne actuelle
Set cells = row.getElementsByTagName("td") ' Récupère les cellules de la ligne
' Vérifie que la ligne contient les cellules attendues
If cells.Length >= 6 Then
' Matin Coeff
If cells(0).innertext <> "" Then
TbVille(0).Matin_Coeff = cells(0).innertext ' Récupère le coefficient du matin
End If
' Matin Basse Mer
If cells(1).innertext <> "" Then
' Récupère l'heure et le niveau de basse mer
TbVille(0).Matin_Basse_mere = CDate(Replace(Split(cells(1).innertext, vbCrLf)(0), "h", ":"))
TbVille(0).Matin_Basse_mere_Niveau_Zéro = Val(Replace(Split(cells(1).innertext, vbCrLf)(1), ",", "."))
End If
' Matin Pleine Mer
If cells(2).innertext <> "" Then
' Récupère l'heure et le niveau de pleine mer
TbVille(0).Matin_Pleine_mere = CDate(Replace(Split(cells(2).innertext, vbCrLf)(0), "h", ":"))
TbVille(0).Matin_Pleine_mere_Niveau_Zéro = Val(Replace(Split(cells(2).innertext, vbCrLf)(1), ",", "."))
End If
' Après-midi Coeff
If cells(3).innertext <> "" Then
TbVille(0).Après_midi_Coeff = cells(3).innertext ' Récupère le coefficient de l'après-midi
End If
' Après-midi Basse Mer
If cells(4).innertext <> "" Then
' Récupère l'heure et le niveau de basse mer pour l'après-midi
TbVille(0).Après_midi_Basse_mere = CDate(Replace(Split(cells(4).innertext, vbCrLf)(0), "h", ":"))
TbVille(0).Après_midi_Basse_mere_Niveau_Zéro = Val(Replace(Split(cells(4).innertext, vbCrLf)(1), ",", "."))
End If
' Après-midi Pleine Mer
If cells(5).innertext <> "" Then
' Récupère l'heure et le niveau de pleine mer pour l'après-midi
TbVille(0).Après_midi_Pleine_mere = CDate(Replace(Split(cells(5).innertext, vbCrLf)(0), "h", ":"))
TbVille(0).Après_midi_Pleine_mere_Niveau_Zéro = Val(Replace(Split(cells(5).innertext, vbCrLf)(1), ",", "."))
End If
End If
' Détermine le sens des marées pour le matin et l'après-midi
TbVille(0).Matin_Sens_Marrées = IIf(TbVille(0).Matin_Basse_mere < TbVille(0).Matin_Pleine_mere, "Marée Montante", "Marée Descendante")
TbVille(0).Après_midi_Sens_Marrées = IIf(TbVille(0).Après_midi_Basse_mere < TbVille(0).Après_midi_Pleine_mere, "Marée Montante", "Marée Descendante")
Next I
End Sub
' Fonction pour retourner les données de la feuille VILLES
Function RetournVille()
RetournVille = ThisWorkbook.Sheets("VILLES").ListObjects("VILLES").DataBodyRange.Value
End Function
' Subroutine pour retourner les données de marées pour les jours suivants
Sub RetorunVilleJourAprès(v As String, TbVille() As Ville, D As Date, htmlDoc As Object)
Dim table As Object ' Déclare un objet pour le tableau HTML
Dim rows As Object ' Déclare un objet pour les lignes du tableau
Dim cells As Object ' Déclare un objet pour les cellules de la ligne
Dim row As Object ' Déclare un objet pour une ligne spécifique
Dim cell As Object ' Déclare un objet pour une cellule spécifique
Dim I As Integer ' Déclare un index pour les boucles
' Sélectionner le tableau à partir du document HTML
Set table = htmlDoc.getElementById("i_donnesLongue").getElementsByTagName("table")(0)
Set rows = table.getElementsByTagName("tr")
' Parcourt chaque ligne à partir de la 3ème ligne (les données commencent ici)
For I = 2 To rows.Length - 1
D = D + 1 ' Incrémente la date pour le jour suivant
ReDim Preserve TbVille(UBound(TbVille) + 1) ' Redimensionne le tableau pour ajouter une ville
Set TbVille(UBound(TbVille)) = New Ville ' Crée une nouvelle instance de la classe Ville
TbVille(UBound(TbVille)).Ville = v
TbVille(UBound(TbVille)).MyDate = Format(D, "yyyy-mm-dd") ' Définit la date de la ville
Set row = rows(I) ' Récupère la ligne actuelle
Set cells = row.getElementsByTagName("td") ' Récupère les cellules de la ligne
' Vérifie que la ligne contient les cellules attendues
If cells.Length >= 6 Then
' Matin Coeff
If cells(1).innertext <> "" Then
TbVille(UBound(TbVille)).Matin_Coeff = cells(0).innertext ' Récupère le coefficient du matin
End If
' Matin Basse Mer
If cells(1).innertext <> "" Then
' Récupère l'heure et le niveau de basse mer
TbVille(UBound(TbVille)).Matin_Basse_mere = CDate(Replace(Split(cells(1).innertext, vbCrLf)(0), "h", ":"))
TbVille(UBound(TbVille)).Matin_Basse_mere_Niveau_Zéro = Val(Replace(Split(cells(1).innertext, vbCrLf)(1), ",", "."))
End If
' Matin Pleine Mer
If cells(2).innertext <> "" Then
' Récupère l'heure et le niveau de pleine mer
TbVille(UBound(TbVille)).Matin_Pleine_mere = CDate(Replace(Split(cells(2).innertext, vbCrLf)(0), "h", ":"))
TbVille(UBound(TbVille)).Matin_Pleine_mere_Niveau_Zéro = Val(Replace(Split(cells(2).innertext, vbCrLf)(1), ",", "."))
End If
' Après-midi Coeff
If cells(3).innertext <> "" Then
TbVille(UBound(TbVille)).Après_midi_Coeff = cells(3).innertext ' Récupère le coefficient de l'après-midi
End If
' Après-midi Basse Mer
If cells(4).innertext <> "" Then
' Récupère l'heure et le niveau de basse mer pour l'après-midi
TbVille(UBound(TbVille)).Après_midi_Basse_mere = CDate(Replace(Split(cells(4).innertext, vbCrLf)(0), "h", ":"))
TbVille(UBound(TbVille)).Après_midi_Basse_mere_Niveau_Zéro = Val(Replace(Split(cells(4).innertext, vbCrLf)(1), ",", "."))
End If
' Après-midi Pleine Mer
If cells(5).innertext <> "" Then
' Récupère l'heure et le niveau de pleine mer pour l'après-midi
TbVille(UBound(TbVille)).Après_midi_Pleine_mere = CDate(Replace(Split(cells(5).innertext, vbCrLf)(0), "h", ":"))
TbVille(UBound(TbVille)).Après_midi_Pleine_mere_Niveau_Zéro = Val(Replace(Split(cells(5).innertext, vbCrLf)(1), ",", "."))
End If
End If
' Détermine le sens des marées pour le matin et l'après-midi
TbVille(UBound(TbVille)).Matin_Sens_Marrées = IIf(TbVille(UBound(TbVille)).Matin_Basse_mere < TbVille(UBound(TbVille)).Matin_Pleine_mere, "Marée Montante", "Marée Descendante")
TbVille(UBound(TbVille)).Après_midi_Sens_Marrées = IIf(TbVille(UBound(TbVille)).Après_midi_Basse_mere < TbVille(UBound(TbVille)).Après_midi_Pleine_mere, "Marée Montante", "Marée Descendante")
Next I
End Sub
Sub ProcessAndInsertTideData(conn As Object, VILLES() As Ville)
Dim v As Integer
Dim Sql As String
Dim rs As Object
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 ' 1 = adOpenKeyset, 3 = adLockOptimistic
If rs.EOF Then rs.AddNew ' Insérer une nouvelle ligne si la date et la ville n'existent pas
' Assignation des valeurs aux champs du Recordset
rs.Fields("Ville").Value = "" & VILLES(v).Ville
rs.Fields("Date").Value = "" & VILLES(v).MyDate
rs.Fields("Matin Coeff").Value = IIf("" & VILLES(v).Matin_Coeff = "", Null, "" & VILLES(v).Matin_Coeff)
rs.Fields("Matin Basse mer").Value = IIf("" & VILLES(v).Matin_Basse_mere = "", Null, "" & VILLES(v).Matin_Basse_mere)
rs.Fields("Matin Basse mer Niveau Zéro").Value = IIf("" & VILLES(v).Matin_Basse_mere_Niveau_Zéro = "", Null, "" & VILLES(v).Matin_Basse_mere_Niveau_Zéro)
rs.Fields("Matin Pleine mer").Value = IIf("" & VILLES(v).Matin_Pleine_mere = "", Null, "" & VILLES(v).Matin_Pleine_mere)
rs.Fields("Matin Pleine mer Niveau Zéro").Value = IIf("" & VILLES(v).Matin_Pleine_mere_Niveau_Zéro = "", Null, "" & VILLES(v).Matin_Pleine_mere_Niveau_Zéro)
rs.Fields("Matin Sens Marrées").Value = IIf("" & VILLES(v).Matin_Sens_Marrées = "", Null, "" & VILLES(v).Matin_Sens_Marrées)
rs.Fields("Après-midi Coeff").Value = IIf("" & VILLES(v).Après_midi_Coeff = "", Null, "" & VILLES(v).Après_midi_Coeff)
rs.Fields("Après-midi Basse mer").Value = IIf("" & VILLES(v).Après_midi_Basse_mere = "", Null, "" & VILLES(v).Après_midi_Basse_mere)
rs.Fields("Après-midi Basse mer Niveau Zéro").Value = IIf("" & VILLES(v).Après_midi_Basse_mere_Niveau_Zéro = "", Null, "" & VILLES(v).Après_midi_Basse_mere_Niveau_Zéro)
rs.Fields("Après-midi Pleine mer").Value = IIf("" & VILLES(v).Après_midi_Pleine_mere = "", Null, "" & VILLES(v).Après_midi_Pleine_mere)
rs.Fields("Après-midi Pleine mer Niveau Zéro").Value = IIf("" & VILLES(v).Après_midi_Pleine_mere_Niveau_Zéro = "", Null, "" & VILLES(v).Après_midi_Pleine_mere_Niveau_Zéro)
rs.Fields("Après-midi Sens Marrées").Value = IIf("" & VILLES(v).Après_midi_Sens_Marrées = "", Null, "" & VILLES(v).Après_midi_Sens_Marrées)
rs.Update ' Met à jour le Recordset
Next v
End Sub
' Fonction pour vérifier l'accessibilité d'une URL
Function CheckURL(URL As String, Ville As String) As Boolean
Dim xml As Object ' Déclare un objet pour la requête XMLHTTP
Set xml = CreateObject("MSXML2.XMLHTTP") ' Crée une requête XMLHTTP
On Error Resume Next ' Ignore les erreurs
' Envoie une requête GET à l'URL
xml.Open "GET", URL, False
xml.send
' Vérifie si la réponse est un succès
If xml.Status = 200 Then
CheckURL = True ' L'URL est accessible
Else
CheckURL = False ' L'URL n'est pas accessible
End If
On Error GoTo 0 ' Réactive les erreurs
End Function
' Fonction pour assainir une URL (remplacer les espaces par des tirets)
Function AssainirURL(URL As String) As String
Dim res As String ' Déclare une variable pour le résultat
res = Trim(URL) ' Supprime les espaces autour de l'URL
res = Replace(res, " ", "-") ' Remplace les espaces par des tirets
AssainirURL = res ' Retourne l'URL assainie
End Function
' Fonction pour créer une connexion ADODB
Function CreateADODBConnection(dbPath As String) As Object
Dim conn As Object ' Déclare un objet pour la connexion
Set conn = CreateObject("ADODB.Connection") ' Crée une connexion ADODB
conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";Persist Security Info=False;" ' Chaîne de connexion
conn.Open ' Ouvre la connexion
Set CreateADODBConnection = conn ' Retourne l'objet de connexion
End Function
' Fonction pour obtenir le document HTML à partir d'une URL
Function GetHTMLDocument(URL As String) As Object
Dim xml As Object ' Déclare un objet pour la requête XMLHTTP
Set xml = CreateObject("MSXML2.XMLHTTP") ' Crée une requête XMLHTTP
' Envoie une requête GET à l'URL
xml.Open "GET", URL, False
xml.send
' Crée un document HTML et charge le contenu
Dim htmlDoc As Object
Set htmlDoc = CreateObject("htmlfile")
htmlDoc.body.innerHTML = xml.responseText ' Charge le texte de la réponse dans le document HTML
Set GetHTMLDocument = htmlDoc ' Retourne le document HTML
End Function
' Class pour définir une ville
Class Ville
Public Ville As String ' Nom de la ville
Public MyDate As String ' Date pour les marées
Public Matin_Coeff As String ' Coefficient de la marée du matin
Public Matin_Basse_mere As Date ' Heure de la basse mer du matin
Public Matin_Basse_mere_Niveau_Zéro As Double ' Niveau de la basse mer du matin
Public Matin_Pleine_mere As Date ' Heure de la pleine mer du matin
Public Matin_Pleine_mere_Niveau_Zéro As Double ' Niveau de la pleine mer du matin
Public Après_midi_Coeff As String ' Coefficient de la marée de l'après-midi
Public Après_midi_Basse_mere As Date ' Heure de la basse mer de l'après-midi
Public Après_midi_Basse_mere_Niveau_Zéro As Double ' Niveau de la basse mer de l'après-midi
Public Après_midi_Pleine_mere As Date ' Heure de la pleine mer de l'après-midi
Public Après_midi_Pleine_mere_Niveau_Zéro As Double ' Niveau de la pleine mer de l'après-midi
Public Matin_Sens_Marrées As String ' Sens de la marée du matin
Public Après_midi_Sens_Marrées As String ' Sens de la marée de l'après-midi
End Class
[:code]