Monitors all queries and lists last queries and top 10
File Name : keywordranking.hta
Requirement : IE6
Author : Jean-Luc Antoine
Submitted : 09/12/2003
Category : HTA
Remember : The file extension has to be *.HTA
将下面的代码保存为keyword.hta即可。保存时注意编码，推荐用utf8格式。
Const C_MaxList=20 '### Change this, predefined for TOP 20
Dim d,dw,a(),b(),f(),g(),i
Redim a(C_MaxList)
Redim b(C_MaxList)
For i=0 to C_MaxList-1
a(i)=0 'Nb d'occurences
b(i)="" 'Value
Next
Redim f(C_MaxList)
Redim g(C_MaxList)
For i=0 to C_MaxList-1
f(i)=0 'Nb d'occurences
g(i)="" 'Value
Next
Set d=CreateObject("Scripting.Dictionary") 'queries
d.CompareMode=1 'vbTextCompare
Set dw=CreateObject("Scripting.Dictionary") 'words
dw.CompareMode=1 'vbTextCompare
sub go(SE)
Dim s,x,sq,s2,sw
Select Case SE
Case 0
s=RegExpTest("pursuit\?query=.*?&", lycosfr.document.body.innerHTML,15)
Case 1
s=RegExpTest("pursuit\?query=.*?&", lycosde.document.body.innerHTML,15)
Case 2
s=RegExpTest("[^a-z]q=.*?&", fireballde.document.body.innerHTML,4)
Case 3
s=RegExpTest("\?qkw=.*?""", metacrawler.document.body.innerHTML,6)
Case 4
s=RegExpTest("return.cool\?query=.*?""", kanoodle.document.body.innerHTML,19)
Case 5
s=RegExpTest("/w.galaxy.com/b/q\?k.*?""", galaxy.document.body.innerHTML,21)
Case Else
msgbox "Unknown S.E. : " & SE
End Select
s="<pre>" & s & "</pre>"
sq=""
For x=0 to C_MaxList-1
If a(x)>0 Then sq="<tr style='background-color:#eeeeee;'><td>" & a(x) & "</td><td>" & b(x) & "</td></tr>" & sq
Next
sq="<table style='border:1px solid #222222;'><tr style='background-color:#dddddd;'><th>Total</th><th>" & Disp(5) & "</th></tr>" & sq & "</table>"
sw=""
For x=0 to C_MaxList-1
If f(x)>0 Then sw="<tr style='background-color:#eeeeee;'><td>" & f(x) & "</td><td>" & g(x) & "</td></tr>" & sw
Next
sw="<table style='border:1px solid #222222;'><tr style='background-color:#dddddd;'><th>Total</th><th>" & Disp(9) & "</th></tr>" & sw & "</table>"
s2="<b>" & Disp(7) & " :</b> " & d.Count & "<br>"
s2=s2 & "<table><tr><td valign=top>"
s2=s2 & "<b>Top " & C_MaxList & " - " & Disp(5) & "</b><br>" & sq & "</td><td valign=top>"
s2=s2 & "<b>Top " & C_MaxList & " - " & Disp(9) & "</b><br>" & sw & "</td><td valign=top>"
s2=s2 & " <b>" & Disp(6) & " :</b>" & s
s2=s2 & "</td></tr></table>"
MaListe.InnerHTML=s2
End Sub
Function RegExpTest(patrn, strng, Pos)
Dim RetStr,regEx, regExw, Match,Matchw,Matches,Matchesw,Matchesws,k,i,j,x,s,w
Set regEx=New RegExp
Set regExw=New RegExp
regEx.Pattern=patrn
regExw.Pattern="\w+"
regEx.IgnoreCase=True ' Set case insensitivity.
regExw.IgnoreCase=True
regEx.Global=True ' Set global applicability.
regExw.Global=True
Set Matches=regEx.Execute(strng) ' Execute search.
RetStr=""
For Each Match in Matches
s=Mid(Match.Value,Pos)
s=Left(s,Len(s)-1)
s=Replace(s,"+"," ")
s=Replace(s,"%20"," ")
s=trim(s)
If s<>"" Then
s=Replace(s,"%21","!"):s=Replace(s,"%22",chr(34))
s=Replace(s,"%23","#"): s=Replace(s,"%25","%")
s=Replace(s,"%26","&"):s=Replace(s,"%27","'")
s=Replace(s,"%28","("):s=Replace(s,"%29",")")
s=Replace(s,"%2A","*"):s=Replace(s,"%2B","+")
s=Replace(s,"%2C",","):s=Replace(s,"%2F","/")
s=Replace(s,"%3A",":")
s=Replace(s,"%3D","=")
s=Replace(s,"%3F","?")
s=Replace(s,"%40","@"):s=Replace(s,"%B4","´")
s=Replace(s,"%C4","Ä"):s=Replace(s,"%D6","Ö")
s=Replace(s,"%DC","Ü"):s=Replace(s,"%DF","ß")
s=Replace(s,"%E0","à"):s=Replace(s,"%E2","â")
s=Replace(s,"%E4","ä"):s=Replace(s,"%E7","ç")
s=Replace(s,"%E8","è"):s=Replace(s,"%E9","é")
s=Replace(s,"%EA","ê"):s=Replace(s,"%EB","ë")
s=Replace(s,"%F6","ö")
s=Replace(s,"%F9","ù"):s=Replace(s,"%FC","ü")
s=Replace(s,"<","<"):s=Replace(s,">",">")
If d.Exists(s) Then
k=d.Item(s)+1
d.Item(s)=k
i=-1 'If more than the first value, insert it
do while (a(i+1)<k) and (i<C_MaxList-1)
i=i+1
loop
if i>=0 Then 'i=where to be inserted
x=0
For j=0 to C_MaxList-1
If ucase(b(j))=ucase(s) Then
x=j
Exit For
End If
Next
&nbs