CRÉATION DE SITEMAP POUR GOOGLE SITEMAPS

Option Explicit
Dim map As String

Private Sub Command1_Click()
' Creer le fichier sitemap sur tout le répertoire courant
' En indiquant les valeurs de mise à jour et de priorité par défaut

Dim fichier As String
Dim repertoire As String
    repertoire = adresse
    fichier = Dir(repertoire)
    Do While fichier <> ""
        If fichier <> "." And fichier <> ".." Then
            If Not ((GetAttr(repertoire & fichier) And vbDirectory) = vbDirectory) Then
                map = map & sitemap(fichier, FileDateTime(repertoire & fichier), "weekly", "5")
            End If
        End If
        fichier = Dir
    Loop
    map = entete(map)
    Call caractereechappement(map)
    Call enregistrement(map)
End Sub


Private Sub Command2_Click()
' ajout le ou les fichiers dans la listes des fichiers à indéxer

Dim bool As Boolean
Dim i As Integer
Dim j As Integer
    For j = 0 To File1.ListCount - 1
        If File1.Selected(j) Then
            i = 0
            bool = True
            While i < List1.ListCount And bool
                If List1.List(i) = File1.List(j) Then
                    bool = False
                End If
                i = i + 1
            Wend
            If bool Then
                List1.AddItem File1.List(j)
                freq.AddItem "weekly"
                prio.AddItem "5"
                
            End If
        End If
    Next j
End Sub

Private Sub Command3_Click()
' supprime le ou les fichiers  de la liste de ceux à indéxer

Dim i As Integer
    For i = List1.ListCount - 1 To 0 Step -1
        If List1.Selected(i) Then
            List1.RemoveItem i
            freq.RemoveItem i
            prio.RemoveItem i
        End If
    Next i
    List1.Refresh
End Sub

Private Sub Command4_Click()
' crée le fichier sitemap selon les paramétres fournis

Dim repertoire As String
Dim i As Integer
    repertoire = adresse
    map = ""
    For i = 0 To List1.ListCount - 1
        map = map & sitemap(List1.List(i), FileDateTime(repertoire & List1.List(i)), freq.List(i), prio.List(i))
    Next i
    map = entete(map)
    Call caractereechappement(map)
    Call enregistrement(map)
End Sub

Private Sub Dir1_Change()
    File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive
    File1.Path = Dir1.Path
End Sub

Sub caractereechappement(ByRef map As String)
' remplace les caractères spéciaux principaux par leur valeur de caractéres déchappement
' google n'accépte les caractères spéciaux que dans ce format ou dans le format HTML

Dim i As Integer
    For i = 192 To 255
        map = Replace(map, Chr(i), "&#" & i & ";")
    Next i
End Sub

Sub enregistrement(map As String)
' demande ou enregistrer le fichier et l'enregistre

Dim canal As Byte
    boite.ShowSave
    canal = FreeFile
    If boite.FileName <> "" Then
        Open boite.FileName For Output As #canal
            Print #canal, map
        Close #canal
            Else: MsgBox "Opération annulée"
    End If
End Sub

Function sitemap(fichier As String, fichierdate As String, fichierfreq As String, fichierprio As String) As String
' met en forme les l'information d'un fichier pour l'enregistrement

    fichierdate = Format(fichierdate, "yyyy-mm-dd")
    sitemap = _
            "   <url>" & vbCrLf & _
            "      <loc>" & serveur & "/" & fichier & "</loc>" & vbCrLf & _
            "      <lastmod>" & fichierdate & "</lastmod>" & vbCrLf & _
            "      <changefreq>" & fichierfreq & "</changefreq>" & vbCrLf & _
            "      <priority>0." & fichierprio & "</priority>" & vbCrLf & _
            "   </url>" & vbCrLf
End Function

Function entete(map As String) As String
' ajoute les entêtes du fichier

    entete = "<?xml version='1.0' encoding='UTF-8'?>" & vbCrLf & _
             "<urlset xmlns=""http://www.google.com/schemas/sitemap/0.84""" & vbCrLf & _
             "xmlns:xsi = ""http://www.w3.org/2001/XMLSchema-instance""" & vbCrLf & _
             "xsi:schemaLocation = ""http://www.google.com/schemas/sitemap/0.84"">" & vbCrLf & _
             vbCrLf & map & vbCrLf & _
             "</urlset>"
End Function

Private Sub File1_DblClick()
' ajout le fichier selectionné à la liste avec les paramétres par défaut

    List1.AddItem File1.List(File1.ListIndex)
    freq.AddItem "weekly"
    prio.AddItem "5"
End Sub

Private Sub frequence_Click()
' met à jour les informations du fichier

    If IsNumeric(List1.ListIndex) And List1.ListCount <> 0 Then
        freq.List(List1.ListIndex) = frequence.Text
        prio.List(List1.ListIndex) = priorité.Item(0).Tag
    End If
End Sub

Private Sub List1_Click()
' recupére si elles sont présentes les informations du fichiers

    Frame1.Caption = "Paramètre de la page " & List1.Text
    frequence.Text = freq.List(List1.ListIndex)
    priorité.Item(prio.List(List1.ListIndex)).Value = True
    priorité.Item(0).Tag = prio.List(List1.ListIndex)
End Sub


Private Sub priorité_Click(index As Integer)
' met à jour les informations du fichier

    priorité.Item(0).Tag = index
    If IsNumeric(List1.ListIndex) And List1.ListCount <> 0 Then
        freq.List(List1.ListIndex) = frequence.Text
        prio.List(List1.ListIndex) = priorité.Item(0).Tag
    End If
End Sub

Function adresse()
' ajout le \ ou non à la fin du répertoire en fonction de si c'est un lecteur ou non

    If InStr(Len(File1.Path), File1.Path, "\") Then
        adresse = File1.Path
        Else
        adresse = File1.Path & "\"
    End If
End Function

Télécharger le zip