Pour les webmasters curieux de la position de leur site sur google

Soyez le premier à donner votre avis sur cette source.

Vue 3 478 fois - Téléchargée 252 fois

Description

En fait, la source est loin d'être fini, je met la la 1ere version fonctionnelle que j'ai... le but n'étant pas de fournir une appli fini mais plutot un point depart pour chacun.

A quoi ça sert ?
C'est simple, on tape l'url d'un site, un ou plusieurs mot clef et le programme va lancer la requette sur google.
A chaque lien rencontré il va vérifier qu'il ne s'agit pas du site présisé plus haut et compté le nombre de lien parcourus.

Au final, il indique en quel position et en quelle page se trouve le site demandé avec le mot clef qui va bien...

C'est tres con, ça sert a rien sauf a assouvir ma curiosité naturelle mais bon :þ

Codes Sources

A voir également

Ajouter un commentaire Commentaires
Messages postés
33
Date d'inscription
mercredi 18 octobre 2000
Statut
Membre
Dernière intervention
4 janvier 2010

bonjour,


il est vraimet un exelent code, trés interessant .
j'au essayé de faire la meme chose pour msn est est yahoo, mais je recoi pas de resultat pourriez vous svp m'indiqué l'erreur:

'le ¤ ets la page a afficher
Const URL = "http://search.msn.com/results.aspx?first=¤1&FORM=PERE¤&q="
Public chtml
Public fini As Integer
Dim a As Integer
Dim nb As Integer

Private Sub Command1_Click()
nb = 0
cpt = 0
a = 1
Label2.Caption = "compte..."
List1.Clear
chtml = ""
Text1.Text = ""

For i = 1 To Text3.Text 'nb de page

cpt = 0


Load Winsock1(a)

Winsock1(a).RemoteHost = "msn.com"
Winsock1(a).RemotePort = 80
Winsock1(a).Connect



On Error Resume Next
If a = 1 Then Unload Winsock1(2) Else Unload Winsock1(1)

On Error GoTo 0



Do While fini <> a
DoEvents
Loop

If a 1 Then a 2 Else a = 1

chtml = Text1.Text
Do
pos = InStr(1, UCase(chtml), UCase("Page en cache"))
vari = Left(chtml, pos)
chtml = Right(chtml, Len(chtml) - pos)
If pos = 0 Then Exit Do
If InStr(1, UCase(vari), UCase(Combo1.Text)) Then
'c bon
cpt = cpt + 1
ok = True
Exit Do
Else
cpt = cpt + 1
End If

Loop
If ok = True Then Exit For
nb = nb + 1

Label2.Caption = "Page : " & nb

chtml = ""
Text1.Text = ""
Next i

If ok = True Then
Dim posi As Integer
If nb >= 10 Then
posi = (nb + cpt)
Else
posi = (nb + cpt + 1)
End If
Label2.Caption = "postion : " & posi & Chr(13) + Chr(10) & "Page : " & i
Else
Label2.Caption = "Non trouvé"
End If

On Error Resume Next
Unload Winsock1(2)
Unload Winsock1(1)
On Error GoTo 0
End Sub




Private Sub Form_Load()
Combo1.AddItem "essaouira.com"
End Sub



Public Function ReplaceVB5(ByVal Expression As String, ByVal Trouver As String, ByVal Remplacement As String, Optional ByVal Start As Long 1, Optional ByVal Count As Long -1, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As String
'
' Tente de reproduire le plus fidèlement possible
' la fonction Replace de VB6
'
' Expression : La chaine à traiter
' Trouver : L'expression ou caractère à remplacer
' Remplacement : L'expression ou caractère de remplacement, peux être vide
' Start : Le caractère à partir duquel commencer le remplacement, défaut : 1, soit début de la chaine
' Count : Le nombre de remplacement à effectuer, défaut : -1, soit illimité
'
Dim iPos1 As Integer 'Position où commence "Trouver"
Dim iLngExp As Integer 'Longueur de "Expression"
Dim iLngTrv As Integer 'Longueur de "Trouver"
Dim iDnrPos1 As Integer 'Dernière position relevée

'Préparations et vérifications de limites
ReplaceVB5 = vbNullString
If ((LenB(Expression) = 0) Or ((LenB(Expression) / 2) > 32767)) Then
Err.Raise vbObjectError + 1, App.Title & ".ReplaceVB5", "Le paramètre [Expression] est vide ou dépasse 32767 caractères."
Exit Function
Else
iLngExp = Int(LenB(Expression) / 2)
End If
If ((LenB(Trouver) = 0) Or ((LenB(Trouver) / 2) > 32767)) Then
Err.Raise vbObjectError + 2, "ReplaceVB5", "Le paramètre [Trouver] est vide ou dépasse 32767 caractères."
Exit Function
Else
iLngTrv = Int(LenB(Trouver) / 2)
End If
'If ((LenB(Remplacement) = 0) Or ((LenB(Remplacement) / 2) > 32767)) Then
If ((LenB(Remplacement) / 2) > 32767) Then
'On permet que "Remplacement" soit vide
Err.Raise vbObjectError + 3, "ReplaceVB5", "Le paramètre [Remplacement] est vide ou dépasse 32767 caractères."
Exit Function
'Else
End If
If ((Start < 1) Or (Start > (iLngExp - 1))) Then
Err.Raise vbObjectError + 4, "ReplaceVB5", "La valeur du paramètre [Start] est sous 0 ou dépasse la longueur de [Expression]."
Exit Function
'Else
End If
If (Count > (iLngExp - 1)) Then
Err.Raise vbObjectError + 5, "ReplaceVB5", "La valeur du paramètre [Count] dépasse la longueur de [Expression]."
Else
If (Count < 0) Then
Count = iLngExp + 1 'Illimité
Else
If (Count 0) Then Count 1
End If
End If
If (Compare = vbDatabaseCompare) Then
Err.Raise vbObjectError + 6, "ReplaceVB5", "Database Compare non supporté..."
'Compare = vbBinaryCompare
Exit Function
'Else
End If

'Prendre le début si Start <> 1
If (Start > 1) Then
ReplaceVB5 = Left$(Expression, Start - 1)
'Else
End If

'Remplacement...
iDnrPos1 = Start
Do
iPos1 = InStr(iDnrPos1, Expression, Trouver, Compare)
If (iPos1 > 0) Then
ReplaceVB5 = ReplaceVB5 & Mid$(Expression, iDnrPos1, iPos1 - iDnrPos1)
ReplaceVB5 = ReplaceVB5 & Remplacement
iDnrPos1 = iPos1 + iLngTrv
Count = Count - 1
Else
ReplaceVB5 = ReplaceVB5 & Mid$(Expression, iDnrPos1, iLngExp - iDnrPos1 + 1)
iDnrPos1 = iLngExp + 1
End If
Loop Until ((iDnrPos1 > iLngExp) Or (Count <= 0))

'Ramasser les miettes si Count <> -1
If (iDnrPos1 <= iLngExp) Then
ReplaceVB5 = ReplaceVB5 & Mid$(Expression, iDnrPos1, iLngExp - iDnrPos1 + 1)
'Else
End If
End Function

Private Sub Winsock1_Connect(Index As Integer)

Dim CommandeHTTP As String
Dim URLPageWeb As String
fini = False
url2 = ReplaceVB5(URL, "¤", nb)
URLPageWeb = url2 & ReplaceVB5(Text2.Text, " ", "+")

List1.AddItem URLPageWeb
List1.ListIndex = List1.ListCount - 1

CommandeHTTP = "GET " & URLPageWeb & " HTTP/1.0" & vbCrLf & "Accept: */*" & vbCrLf & "Accept: text/html" & vbCrLf & vbCrLf
Winsock1(Index).SendData CommandeHTTP

' Dans le Winsock1_DataArrival mettez ce code :



End Sub

Private Sub Winsock1_ConnectionRequest(Index As Integer, ByVal requestID As Long)
Winsock1(Index).Accept requestID
End Sub

Private Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long)

On Error GoTo oups
Dim HTTPDonnees As String
Winsock1(Index).GetData HTTPDonnees, vbString
Text1.Text = Text1.Text & HTTPDonnees
If InStr(1, UCase(Text1.Text), UCase("</html>")) Then
oups:
fini = Index
Winsock1(Index).Close
Else

fini = 0
End If
End Sub
Messages postés
33
Date d'inscription
mercredi 18 octobre 2000
Statut
Membre
Dernière intervention
4 janvier 2010

bonjour,merci pour la source est parfait: comment faire pour ajouter msn est yahoo ...

salutations
Messages postés
16
Date d'inscription
mardi 25 avril 2006
Statut
Membre
Dernière intervention
1 novembre 2007

Je suis impacien de la voir termine. tien moi au courant de son avancement stp ca serait gentil. ;)
Messages postés
9
Date d'inscription
mercredi 1 janvier 2003
Statut
Membre
Dernière intervention
17 juillet 2006

je veux seulement te dire bravo,
he les gas en dis merci et bon courage, pas pourquoi tu dis ca ou ca, au moin il a fait l'effort de programmer un calculateur positionneur dans google.

Merci et bon courage
Messages postés
30
Date d'inscription
jeudi 21 novembre 2002
Statut
Membre
Dernière intervention
9 juin 2004

c'est fait en VB5 et y'a l'exe dans le zip... par contre, vu que j'utilise winsock, je garenti pas que l'exe marche partout... foutu versioning :þ
Afficher les 8 commentaires

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.