Création de sitemap pour google sitemaps

Télécharger le projet
Commenter

Description

Google fournit les statistiques d'accès des internautes ainsi que les classements des pages de notre site en fonctions des résultats des recherches. A l'adresse https://www.google.com/webmasters/sitemaps
Dans les fonctionnalitées proposées par google,il est possible de classer les pages de notre site entre pour l'affichage des résultats. Pour cela, google à besoin du sitemap.
Sitemap que vous créer cette application.

Source / Exemple : 


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 projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.