GoogleFight v1.0.1Table des procédures 1 - FrmGoogleFight (FrmGoogleFight.frm) 1.1 - Private Function sRqGoogle$ 1.2 - Private Sub CmdFight_Click 1.3 - Private Sub ExtraireComptageGoogle 1.4 - Private Sub Form_Load 1.5 - Private Sub Navigateur1_DocumentComplete 1.6 - Private Sub Navigateur2_DocumentComplete 1.7 - Private Sub Txt1_KeyPress 1.8 - Private Sub Txt2_KeyPress FrmGoogleFight (FrmGoogleFight.frm) Option Explicit ' GoogleFight : Mon correcteur orthographique favori ! ' Comparer la fréquence de deux orthographes d'un mot sur Google ' www.vbfrance.com/code.aspx?ID=20641 ' Par Patrice Dargenton ' patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' www.vbfrance.com/listeauteur2.aspx?ID=1124 ' Documentation : LisezMoi.htm ' Version 1.1 du 03/04/2004 ' Conventions de nommage des variables : ' b pour Boolean (booléen vrai ou faux) ' i pour Integer : % ' l pour Long : & ' r pour nombre Réel : Single! ou Double# ' a pour Array (tableau) : () ' o pour Object (objet ou classe) ' m_ pour variable Membre de la classe ou de la feuille (Form) ' (mais pas pour les constantes) Private m_lNbOccurences1&, m_lNbOccurences2&, m_bEchap As Boolean Private Sub Form_Load() ' Exemple d'utilisation de GoogleFight : ' tester 2 orthographes différentes pour... GoogleFight ! Me.Txt1 = "GoogleFight" Me.Txt2 = "Google-Fight" End Sub Private Sub Txt1_KeyPress(KeyAscii As Integer) ' Traitement de la touche Entrée sur la zone de saisie n°1 If KeyAscii = vbKeyReturn Then Me.Txt2.SetFocus ' Traitement de la touche Echap sur la zone de saisie n°1 If KeyAscii = vbKeyEscape Then m_bEchap = True End Sub Private Sub Txt2_KeyPress(KeyAscii As Integer) ' Traitement de la touche Entrée sur la zone de saisie n°2 If KeyAscii = vbKeyReturn Then CmdFight_Click ' Traitement de la touche Echap sur la zone de saisie n°2 If KeyAscii = vbKeyEscape Then m_bEchap = True End Sub Private Sub CmdFight_Click() Me.CmdFight.Enabled = False ' Eviter la ré-entrance dans la fonction Me.LblInfo = "Recherche en cours..." Me.MousePointer = vbHourglass ' Les navigateurs sont d'abord masqués pour éviter la page blanche Me.Navigateur1.Visible = False Me.Navigateur2.Visible = False ' Reprendre les mots comme titre de chaque onglet Dim sMot1$, sMot2$ sMot1 = Me.Txt1.Text sMot2 = Me.Txt2.Text If sMot2 = sMot1 Then sMot2 = "" Me.SSTab.TabCaption(0) = sMot1 Me.SSTab.TabCaption(1) = sMot2 ' Lancer les recherches Const iCodePasEncoreLu% = -1 m_lNbOccurences1 = iCodePasEncoreLu m_lNbOccurences2 = iCodePasEncoreLu Dim sRq1$, sRq2$, bUnSeulMot As Boolean ' Faire des requêtes pour Google à partir des mots sRq1 = sRqGoogle(sMot1) sRq2 = sRqGoogle(sMot2) ' Lancer les deux recherches simultanément If sMot1 <> "" Then Me.Navigateur1.Navigate sRq1 Me.Navigateur1.Visible = True Else m_lNbOccurences1 = 0 bUnSeulMot = True End If If sMot2 <> "" Then Me.Navigateur2.Navigate sRq2 Me.Navigateur2.Visible = True Else m_lNbOccurences2 = 0 bUnSeulMot = True End If ' Attendre la fin du téléchargement des pages html dans les 2 navigateurs m_bEchap = False Me.Txt1.SetFocus ' Pour traiter éventuellement la touche Echap While (m_lNbOccurences1 = iCodePasEncoreLu Or _ m_lNbOccurences2 = iCodePasEncoreLu) And Not m_bEchap ' Laisser VB traiter les messages Windows (fin téléch., touche appuyée...) DoEvents Wend ' Affichage des résultats Me.MousePointer = vbDefault Dim lOccMax&, lOccMin&, rRatio!, sMax$, sMin$ lOccMax = m_lNbOccurences1: sMax = sMot1 lOccMin = m_lNbOccurences1: sMin = sMot1 If m_lNbOccurences2 > lOccMax Then lOccMax = m_lNbOccurences2: sMax = sMot2 If m_lNbOccurences2 < lOccMin Then lOccMin = m_lNbOccurences2: sMin = sMot2 Const sFormat$ = "### ### ### ##0" ' Ya pas encore 1000 milliards de pages sur le web ! If lOccMax > 0 Then If bUnSeulMot Then Me.LblInfo = "Résultat : " & Format(lOccMax, sFormat) & " pages pour " & sMax Else rRatio = (lOccMax - lOccMin) / lOccMax Me.LblInfo = "Vainqueur : " & sMax & " à " & _ Format(rRatio, "0.00%") & vbLf & _ Format(lOccMax, sFormat) & " pages pour " & sMax & " contre " & vbLf & _ Format(lOccMin, sFormat) & " pages pour " & sMin End If Else Me.LblInfo = "Aucune page ne contient ces mots !" End If m_lNbOccurences1 = -1 m_lNbOccurences2 = -1 If bUnSeulMot Then ' S'il n'y a qu'un mot, positionner sur l'onglet correspondant If sMot1 <> "" Then Me.SSTab.Tab = 0 If sMot2 <> "" Then Me.SSTab.Tab = 1 End If Me.CmdFight.Enabled = True End Sub Private Sub Navigateur1_DocumentComplete(ByVal pDisp As Object, URL As Variant) ExtraireComptageGoogle m_lNbOccurences1, Me.Navigateur1 End Sub Private Sub Navigateur2_DocumentComplete(ByVal pDisp As Object, URL As Variant) ExtraireComptageGoogle m_lNbOccurences2, Me.Navigateur2 End Sub Private Sub ExtraireComptageGoogle(lNbOccurences&, oNavigateur As Object) ' Rechercher la valeur du compteur dans la page renvoyée par Google Dim lCompteur& lCompteur = 0 Dim doc As IHTMLDocument2 On Error Resume Next Set doc = oNavigateur.Document ' Obtenir le document page web retournée If Err Then GoTo Fin If doc.Title = "Impossible de trouver le serveur" Then GoTo Fin On Error GoTo 0 Dim sTxt$, iPosG%, iPosD%, iNbCar% Dim Quote As IHTMLElement Set Quote = doc.body ' Obtenir le contenu du document sTxt = Quote.innerText ' Obtenir le contenu texte seul du document ' Rechercher la chaîne affichant le résultat du compteur Const sTxtEchec$ = "Aucune page ne contient" If InStr(sTxt, sTxtEchec) > 0 Then GoTo Fin Const sTxtCompteur1$ = "sur un total d'environ" Const sTxtCompteur2$ = "Résultats" Const sTxtCompteur3$ = "sur" iNbCar = Len(sTxtCompteur1) iPosG = InStr(sTxt, sTxtCompteur1) If iPosG = 0 Then ' Seconde tentative iNbCar = Len(sTxtCompteur2) iPosG = InStr(sTxt, sTxtCompteur2) If iPosG = 0 Then GoTo Fin iNbCar = Len(sTxtCompteur3) iPosG = InStr(iPosG, sTxt, sTxtCompteur3) End If If iPosG = 0 Then GoTo Fin Const sTxtCompteurFin$ = "pour" '"Recherche effectuée" iPosD = InStr(iPosG, sTxt, sTxtCompteurFin) If iPosD = 0 Then GoTo Fin Dim sCompteur$ iPosG = iPosG + iNbCar sCompteur = Mid$(sTxt, iPosG, iPosD - iPosG - 1) ' Traitement du séparateur de millier If InStr(sCompteur, ",") > 0 Then _ sCompteur = Replace(sCompteur, ",", "") If IsNumeric(sCompteur) Then lCompteur = Val(sCompteur) Fin: lNbOccurences = lCompteur ' Retourner le résultat à la fonction appelante End Sub Private Function sRqGoogle$(ByVal sExpression$) ' Construire une requête Google à partir d'un mot ou bien ' d'une expression à rechercher Const sGm$ = "%22" ' Guillemets html If InStr(sExpression, " ") Then ' Recherche d'une expression : remplacer les espaces par + ' et mettre des web-guillements : %22 sExpression = sGm & Replace(sExpression, " ", "+") & sGm End If sRqGoogle = "http://www.google.fr/search?q=" & sExpression & "&ie=UTF-8&oe=UTF-8&hl=fr" End Function