关键字排名(Keyword Ranking)_hta教程-查字典教程网

Real-time ranking of keywords entered on search engines

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格式。

复制代码代码如下:

<title>Keyword Ranking, (c) Jean-Luc Antoine</title>

<HTA:APPLICATION APPLICATIONNAME="Search Engine Tools"

BORDER="thick"BORDER

CAPTION="yes" CONTEXTMENU="yes"

INNERBORDER="yes" MAXIMIZEBUTTON="yes" MINIMIZEBUTTON="yes"

NAVIGABLE="no" SCROLL="yes" SCROLLFLAT="no"

SELECTION="yes"SHOWINTASKBAR="yes" SINGLEINSTANCE="no"

SYSMENU="yes" VERSION="0.3" WINDOWSTATE="normal">

Option Explicit

'Versions :

'v0.3Queries and words : simultaneously ranking

'v0.2New look, options, many SE

'Multilingual system

'v0.1First draft, keyword rank and last queries

'Todo :

'Gérer systématiquement à la fois Keyword et Phrase

'Sur les keyword, permettre de zoomer (showmodeless) sur les phrases contenant le keyword pour connaître le ranking des variations

'Lister en permanence les mots-clefs monitorés avec leur occurence et permettre le même zoom

'Mettre en gras les keywords monitorés

'Temps de mesure

'Afficher pourcentage en plus du nb d'occurences

'Monitorer X mots-clefs et leur apparition/fréquence relative

'Faire bouton de refresh manuel si ça se bloque (location.reload())

'gérer les fenêtres lancées offline et non pas inline (intercepter events par showmodeless dialog)

'identifier nb de pages retournées par requete et indice de concurrence

'Permettre de sauver le résultat

'http://wordtracker.com/newsinput.txt

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

Redim f(C_MaxList)

Redim g(C_MaxList)

For i=0 to C_MaxList-1

f(i)=0'Nb d'occurences

g(i)=""'Value

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><td>" & a(x) & "</td><td>" & b(x) & "</td></tr>" & sq

sq="<table><tr><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><td>" & f(x) & "</td><td>" & g(x) & "</td></tr>" & sw

sw="<table><tr><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

For j=x+1 to i

a(j-1)=a(j)

b(j-1)=b(j)

a(i)=k

b(i)=s

End If

Else

d.Add s,1

End If

RetStr=RetStr & d.Item(s) & "-" & s & vbCRLF

'Extract Words

Set Matchesw=regExw.Execute(s)

For Each Matchw in Matchesw

w=Matchw.Value

If Len(w)>2 Then

If dw.Exists(w) Then

k=dw.Item(w)+1

dw.Item(w)=k

i=-1'If more than the first value, insert it

do while (f(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(g(j))=ucase(w) Then

x=j

Exit For

End If

For j=x+1 to i

f(j-1)=f(j)

g(j-1)=g(j)

f(i)=k

g(i)=w

End If

Else

dw.Add w,1

End If

RegExpTest=RetStr

End Function

</script>

DoLoad

</script>

'DoSave

</xscript>

Sub DoSave

foo.setAttribute "content", foo.innerHTML

foo.save "EditContent"

End Sub

sub DoLoad

foo.load "EditContent"

content = foo.getAttribute("content")

if content<>"" Then foo.innerHTML=content

End Sub

Sub DoClear

foo.innerHTML = ""

End Sub

Function Disp(x)

Select case getlocale

Case 1036,2060,3084,5132,4108'French

Select Case x

Case 0'sous-titre

Disp="Outil d'analyse de requêtes - 1 backlink svp !"

Case 1

Disp="Votre liste de mots à monitorer :"

Case 2

Disp="Sauve"

Case 3

Disp="R.A.Z"

Case 4

Disp="Charge"

Case 5

Disp="requêtes"

Case 6

Disp="Dernières requêtes"

Case 7

Disp="Nb de requêtes lues"

Case 8

Disp="Cliquez dans le menu pour activer l'analyse d'un moteur."_

& " Recliquez pour la désactiver."

Case 9

Disp="Mots"

Case Else

Disp="###"

End Select

Case Else

Select Case x

Case 0'sub title

Disp="A linkware search engine analysis tool"

Case 1

Disp="Your keywords to monitor :"

Case 2

Disp="Save"

Case 3

Disp="Clear"

Case 4

Disp="Load"

Case 5

Disp="Queries"

Case 6

Disp="Last queries"

Case 7

Disp="Amount of scanned queries"

Case 8

Disp="Click above to start the queries analyzis on a specific search engine."_

& " Click again to stop it."

Case 9

Disp="Words"

Case Else

Disp="###"

End Select

End Function

Sub DispSE(x)

Select Case x

Case 0

if lycosfr.location="about:blank" Then

lycosfr.location="http://www.recherche.lycos.fr/voyeur"

Else

lycosfr.location="about:blank"

End If

Case 1

if lycosde.location="about:blank" Then

lycosde.location="http://www.lycos.de/inc/content/suche/"_

& "includes/livesuche_iframe.htm?ergebnisse=&refresh="

Else

lycosde.location="about:blank"

End If

Case 2

if fireballde.location="about:blank" Then

fireballde.location="http://www.fireball.de/livesuche.csp"

Else

fireballde.location="about:blank"

End If

Case 3

if metacrawler.location="about:blank" Then

metacrawler.location="http://www.metaspy.com/info.metac.spy/metaspy/unfiltered.htm"

Else

metacrawler.location="about:blank"

End If

Case 4

if kanoodle.location="about:blank" Then

kanoodle.location="http://www.kanoodle.com/spy/spy.cool"

Else

kanoodle.location="about:blank"

End If

Case 5

if galaxy.location="about:blank" Then

galaxy.location="http://watch.galaxy.com/b/watch?filter"

Else

galaxy.location="about:blank"

End If

Case Else

Msgbox "DispSE : not found - " & x

End Select

End Sub

</script>

<style>

body,td,th,p{font-size: 11px;font-family: Tahoma,Arial;}

.topmenu{

border:1px solid #222222;

background-color:#eeeeee;

}

.topmenu a{

height:15px;

background-color:#BDDCBD;

padding-top:1px;

padding-left:5px;

padding-right:5px;

text-decoration:none;

color:black;

text-align:center;

display:block;

}

.topmenu a:hover, .topmenu a:active{

background-color:#89DB89;color:black;

}

#rb{border-right:1px solid #222222;}

A{color:#AAFFCC}

BUTTON{font-size: 7pt;cursor:hand;}

.userData {behavior:url(#default#userdata);}

</style>

</head>

<H1>Keyword Ranking</H1><Script>document.write Disp(0)</Script>

<td id=rb width=80><a href="#" onClick='options.style.display="block"'>Options</a></td>

<td id=rb width=80><a href="#" Title="French">Lycos.fr</a></td>

<td id=rb width=80><a href="#" Title="Deutsch">Lycos.de</a></td>

<td id=rb width=80><a href="#" Title="Deutsch">firball.de</a></td>

<td id=rb width=80><a href="#" Title="MetaSpy">MetaCrawler</a></td>

<td id=rb width=80><a href="#">Kanoodle</a></td>

<td id=rb width=80><a href="#">Galaxy</a></td>

</tr></table>

<button onClick='DoSave()'><script>document.write Disp(2)</script></button>

<button onClick='DoClear()'><script>document.write Disp(3)</script></button>

<button onClick='DoLoad()'><script>document.write Disp(4)</script></button>

</div>

</td><td>

</td></tr></table>

</body>

</html>

原文：http://www.interclasse.com/scripts/keywordranking.php