POUR LES WEBMASTERS CURIEUX DE LA POSITION DE LEUR SITE SUR GOOGLE
Weado
Messages postés119Date d'inscriptionmercredi 19 juin 2002StatutMembreDernière intervention21 avril 2009
-
8 mai 2003 à 01:06
cs_mogador
Messages postés33Date d'inscriptionmercredi 18 octobre 2000StatutMembreDernière intervention 4 janvier 2010
-
22 avril 2008 à 17:39
Cette discussion concerne un article du site. Pour la consulter dans son contexte d'origine, cliquez sur le lien ci-dessous.
'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 = ""
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
'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, " ", "+")
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
cs_mogador
Messages postés33Date d'inscriptionmercredi 18 octobre 2000StatutMembreDernière intervention 4 janvier 2010 17 avril 2008 à 19:46
bonjour,merci pour la source est parfait: comment faire pour ajouter msn est yahoo ...
salutations
Doudou_Dimitri
Messages postés16Date d'inscriptionmardi 25 avril 2006StatutMembreDernière intervention 1 novembre 2007 13 sept. 2007 à 13:41
Je suis impacien de la voir termine. tien moi au courant de son avancement stp ca serait gentil. ;)
hypnotiseur
Messages postés9Date d'inscriptionmercredi 1 janvier 2003StatutMembreDernière intervention17 juillet 2006 1 août 2005 à 11:12
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
cs_ido
Messages postés30Date d'inscriptionjeudi 21 novembre 2002StatutMembreDernière intervention 9 juin 2004 11 mai 2003 à 10:34
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 :þ
ronanry
Messages postés190Date d'inscriptionlundi 25 novembre 2002StatutMembreDernière intervention22 décembre 2009 8 mai 2003 à 08:05
c bien joli tt ca...mais tu pourrais pas mettre l'executable...parce que moi je voudrais bien savoir ma position sur google...mais j'ai pas vb6 :'(
cs_PaTaTe
Messages postés2126Date d'inscriptionmercredi 21 août 2002StatutContributeurDernière intervention19 février 20212 8 mai 2003 à 07:38
t un pti malin avec tes commentaires qui veulent rien dire (dans le sens constructif du therme)
Weado
Messages postés119Date d'inscriptionmercredi 19 juin 2002StatutMembreDernière intervention21 avril 2009 8 mai 2003 à 01:06
La curiosité ne s'avert pas être toujours un vilain défaut jeune disciple, les vilains sont ceux qui nous empêchent d'être curieux
22 avril 2008 à 17:39
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
17 avril 2008 à 19:46
salutations
13 sept. 2007 à 13:41
1 août 2005 à 11:12
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
11 mai 2003 à 10:34
8 mai 2003 à 08:05
8 mai 2003 à 07:38
8 mai 2003 à 01:06