I do not know that it is scripts \plug-ins I wish to learn that this script does!
[div class='codetop']CODE[/div][div class='codemain' style='height:200px;white-space:pre;overflow:auto'] Public FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Public heros
Function Ispresent(user)
If GetPositionByName(user) > 0 Then Ispresent = True : Exit Function
Ispresent = False
End Function
Function ReadText(filepath)
Dim File
ReadText=""
If FSO.FileExists(filepath) Then
Set File = FSO.GetFile(filepath)
If Clng(file.size)=0 Then
exit function
End If
Set File = FSO.OpenTextFile(filepath,1)
ReadText=File.ReadAll
End If
End Function
Function getclanicon(user)
user = lcase(user)
If savedicons.Exists(user) Then
getclanicon = savedicons.item(user)
If everyotherone<>9 then
everyotherone=9
Else
everyotherone=8
End If
addchat color(everyotherone), "Found local stuff for "&user&" --> "&Replace(getclanicon, ldot, "")
' playercount=playercount+1
Exit Function
End If
content=ScINet.OpenURL("
http://www.battle.net/war3/ladder/W3XP-player-profile.aspx?Gateway=Azeroth&PlayerName="&user)
'Call WriteText1(exports&"profiles\"&user&".txt",content)
'content=ReadText(exports&"profiles\"&(user)&".txt")
If instr(content,"<title>Frozen Throne Ladder</title>") Then
getclanicon = "_____No such player exists."
If everyotherone<>9 then
everyotherone=9
Else
everyotherone=8
End If
addchat vbred, "No such player exists --> "&user
' playercount=playercount+1
Exit Function
End If
dim xicon
xicon=mid(content,instr(content,"/w3xp/")+8,2)
zicon=""
for i = 0 to ubound(iconcode2)
if xicon = iconcode2(i) then
zicon=icon(i)
Exit For
End If
Next
clan=""
clantag=instr(content,"ClanTag=")
If clantag=0 Then
clan="-"
Else
clan=mid(content,clantag+8,6)
clan=left(clan,instr(clan,">")-2)
End If
wins=split(content,"Total:")
winsx=split(wins(1),"rankingRow"&qm&">")
winsy=left(winsx(1),instr(winsx(1),"<")-1)&"/"&left(winsx(2),instr(winsx(2),"<")-1)
getclanicon=zicon& s &string(12-len(zicon),ldot)&winsy&string(13-(len(winsy)+len(clan)),ldot)& s &clan
savedicons.add user, getclanicon
if iconstoadd <> "" then iconstoadd = iconstoadd & vbCrLf
iconstoadd = iconstoadd & user & s & getclanicon
If everyotherone<>9 then
everyotherone=9
Else
everyotherone=8
End If
addchat color(everyotherone), "Parsing data from web page for player "&user&" --> "&Replace(getclanicon, ldot, "")
' playercount=playercount+1
End Function
Function String10plus(filepath)
filepatharr=split(filepath,"\")
addchat color(1), "Ripping and parsing export text file: "&filepatharr(ubound(filepatharr))
Dim Content, playersxx, team, orderplayers, quitsx, pheros
Content = ReadText(Filepath)
count = 1
vLines = Split(Content, vbCrLf)
pheros = getheros(content, 0)
For i = 15 to 27
If len(vLines(i)) = 0 Then
Exit For
End If
count=count+1
Next
playersxx=""
teams=""
For i = 14 to count+11
if mid(vLines(i),27,6) = "Player" then
playersxx=playersxx&RTrim(mid(vLines(i),7,16))&" "
team=mid(vLines(i),57,1)
teams=teams&team&" "
end if
Next
orderplayers=""
For i = 15 to ubound(vlines)
If left(vlines(i),5) = " ---" then
orderplayers=orderplayers&mid(vlines(i-1),3)&" "
End If
Next
quitsx=""
For Each vLine In vLines
If Instr(vLine, " Quit Game: ") Then
quit=mid(vLine,instr(vLine,"Quit Game: ")+11)
If quit="Win" or quit="Lost" Then
quit="Finished"
End If
qtime=RTrim(mid(vLine,3,10))
len2=len(qtime)+len(quit)
quitsx=quitsx&","&qtime&string(20-len2,ldot)&s&quit
End If
Next
quitsx=mid(quitsx,2)
String10plus=RTrim(playersxx)&";;"&RTrim(teams)&";;"&RTrim(orderplayers)&";;"&quitsx&";;"&pheros&";;"&vlines(5)&vbCrLf&"Host"&mid(vlines(7),8)&vbCrLf&vlines(6)&vbCrLf&vlines(4)&vbCrLf
addchat color(2), "Done!"
End Function
Public Function getheros(content, mode)
Dim hero, herostring, count, xplayers, holdheros
'Content = ReadText(Filepath)
vLines = Split(Content, vbCrLf)
herostring=""
xplayers=""
count=0
For i = 15 to ubound(vLines)
If mid(vLines(i),15,13)="Use ability: " Then
tempstr=split(mid(vLines(i),28)," Target:")(0)
temparr=split(herostring,"$*rk50ndk#@NI-+")(count)
If tempstr<>"Attribute Bonus" and instr(temparr,tempstr) = 0 Then
herostring=herostring&","&tempstr
End If
ElseIf mid(vLines(i),15,12)="Unknown ID: " then
tempstr=mid(vLines(i),27,4)
If instr(herostring,tempstr) = 0 Then
herostring=herostring&","&tempstr
End If
ElseIf left(vlines(i),5) = " ---" then
herostring=herostring&"$*rk50ndk#@NI-+,UNKNOWN"
count=count+1
If mode = 1 then xplayers=xplayers&" "&mid(vlines(i-1),3)
End If
Next
holdheros = ""
'addchat vbyellow, herostring
herostring = split(mid(herostring, 16),"$*rk50ndk#@NI-+,")
For i = 0 to ubound(herostring)
' If herostring(i) = "UNKNOWN" Then holdhero = "UNKNOWN"
holdhero = translatehero(herostring(i))
'addchat vbgreen, holdhero
holdheros = holdheros&" "&holdhero
Next
If mode = 1 Then
holdheros = mid(holdheros, 2)
xplayers = mid(xplayers, 2)
xplayers = split(mid(xplayers,2))
holdheros = split(holdheros)
dim stringg
stringg=""
For i = 0 to ubound(herostring)
stringg = stringg & vbCrLf & i+1 & ".) " & xplayers(i) & vbCrLf & holdheros(i)
Next
getheros = stringg
' addchat color(1), stringg
Exit Function
End If
getheros=mid(holdheros, 2)
End Function
Function translatehero(stringg)
lilcode=split(mid(stringg,2), ",")
count=0
For each lilc in lilcode
For i = 1 to ubound(heros) Step 2
if instr(heros(i),lilc) Then
translatehero = heros(i-1)
Exit Function
End If
Next
If count = ubound(lilcode) Then
translatehero = lastresort(stringg)
End If
count=count+1
Next
End Function
Function lastresort(stringg)
If instr(stringg,"Thunder Clap") and instr(stringg,"Evasion") Then
lastresort = "Void"
Exit Function
End If
lastresort = "unknown"
End Function
'// gets all chat from both types* of replays
Function getchat(filepath,player)
Dim Content, chat, xplayers, xplayer, team
Content = ReadText(Filepath)
vLines = Split(Content, vbCrLf)
chat = ""
xplayers = ""
team = ""
'//FOR 2 '//stpt stands for 'stopping point'stpt2=18:stpt2=20
stpt=29 : stpt1=21 : stpt2=39 : stpt3=47 : stpt4=52
'//FOR sort player on
if mid(vlines(40),5,1)=":" Then stpt=13 : stpt1=3 : stpt2=23 : stpt3=31 : stpt4=36
For i = 15 to ubound(vlines)
if mid(vLines(i),stpt,9)=" Chat(To" then
if mid(vLines(i),stpt2,6)="allies" Then
chat=chat&mid(vLines(i),stpt1,9)&team&"[Allies] "&xplayer&":"&mid(vLines(i),stpt3)&vbCrLf
else
chat=chat&mid(vLines(i),stpt1,9)&team&"[All] "&xplayer&":"&mid(vLines(i),stpt4)&vbCrLf
End If
elseif mid(vLines(i),stpt,9) = " Quit Ga" Then
quit=mid(vLines(i),instr(vLines(i),"Quit Game: ")+11)
If quit="Win" or quit="Lost" Then
quit="Finished"
End If
chat=chat&mid(vLines(i),stpt1,9)&team&" "&xplayer&" Quit Game: " & quit & vbCrLf & vbCrLf
elseif left(vlines(i),5) = " ---" then
xplayer=mid(vlines(i-1),3)
xplayers=xplayers&" / "&xplayer
team=mid(content,instr(250,content,xplayer)+50,1)
tlasttime = "00:00" : lasttime = 0
end if
if stpt1=3 then
if mid(vlines(i),5,1)=":" Then
tthistime = trim(left(vlines(i),10))
thistimearr = split(tthistime,":")
thistime = cint(thistimearr(ubound(thistimearr)-1))
If thistime > lasttime + 2 then
chat = chat & "AFK start: " & tlasttime &s& xplayer & vbCrLf & "Back from AFK: " & tthistime &s& xplayer &" aprox afk time = "&thistime-lasttime&" minutes"& vbCrLf
tlasttime = tthistime : lasttime = thistime
Else
tlasttime = tthistime : lasttime = thistime
End If
End If
End if
Next
xplayers=mid(xplayers,4)
If player <> "" Then
vlines=split(chat,vbCrLf)
chat=""
For each vline in vlines
If lcase(player) = rtrim(left(vline,15)) Then
chat=chat&vline&vbCrLf
End If
Next
End If
getchat=vlines(5)&vbCrLf&"Host"&mid(vlines(7),8)&vbCrLf&vlines(6)&vbCrLf&vlines(4)&vbCrLf&xplayers&vbCrLf&chat
addchat color(2), "Done!"
End Function
'// for now just sorts out all instances of players using items. Eventually I hope to
'// find out all items the players bought and used.
Function getitems(Content)
Dim chat, xplayers, xplayer, team
vLines = Split(Content, vbCrLf)
chat = ""
xplayers = ""
team = ""
'//FOR 2 '//stpt stands for 'stopping point'stpt2=18:stpt2=20
stpt=29 : stpt1=21' : stpt2=39 : stpt3=47 : stpt4=52
'//FOR sort player on
if mid(vlines(40),5,1)=":" Then stpt=13 : stpt1=3' : stpt2=23 : stpt3=31 : stpt4=36
For i = 15 to ubound(vlines)
if lcase(mid(vLines(i),stpt,9))=" use ite" then
chat=chat&mid(vLines(i),stpt1,9)&team&"[Item] "&xplayer&":"&mid(vLines(i),stpt+1)&vbCrLf
elseif mid(vLines(i),stpt,9) = " Quit Ga" Then
quit=mid(vLines(i),instr(vLines(i),"Quit Game: ")+11)
If quit="Win" or quit="Lost" Then
quit="Finished"
End If
chat=chat&mid(vLines(i),stpt1,9)&team&" "&xplayer&" Quit Game: "&quit&vbCrLf&vbCrLf
elseif left(vlines(i),5) = " ---" then
xplayer=mid(vlines(i-1),3)
xplayers=xplayers&" / "&xplayer
team=mid(content,instr(250,content,xplayer)+50,1)
end if
Next
xplayers=mid(xplayers,4)
getitems=vlines(5)&vbCrLf&"Host"&mid(vlines(7),8)&vbCrLf&vlines(6)&vbCrLf&vlines(4)&vbCrLf&xplayers&vbCrLf&chat
addchat color(2), "Done!"
End Function
'// this gets all occurances of all abilities used in the game or by one player, use "" for player to get all
'// not called by anything atm
Function getabilities(filepath,player)
Dim Content, chat, xplayers
Content = ReadText(Filepath)
vLines = Split(Content, vbCrLf)
chat=""
xplayers=""
For i = 15 to ubound(vlines)
if mid(vLines(i),11,11)=" Use abi" or mid(vLines(i),11,11)=" Unknown" then
chat=chat&vLines(i)&vbCrLf
elseif left(vlines(i),5) = " ---" then
xplayer=mid(vlines(i-1),3)
xplayers=xplayers&" "&xplayer
chat=chat&vbCrLf&"$*rk50ndk#@NI-+"&xplayer&vbCrLf&vbCrLf
end if
Next
if player<>"" then
xplayers="filler "&xplayers
xplayers=split(xplayers)
chat=split(chat,"$*rk50ndk#@NI-+")
for i = 0 to ubound(xplayers)
if lcase(player)=lcase(xplayers(i)) then
getabilities=chat(i)
exit function
End If
Next
End If
getabilities=vbCrLf&replace(chat,"$*rk50ndk#@NI-+" , "")
addchat color(2), "Done!"
End Function
'// this lists each ablity used in the game. only once is it listed however many times it's used
'// to get abilities for all players use "" for player
'//damit it returns an array . careful with these . ones like this are meant to go through the asort function
'//returns an array NOT a string
Function replaynames(filepath)
Dim Content
Content = ReadText(Filepath)
vLines = Split(Content, vbCrLf)
Content=""
For Each vLine In vLines
imark = instr(vLine, ".w3g ( ")
If imark > 0 Then
Content=Content&"/"&trim(mid(vLine,1,imark+4))
End If
Next
replaynames=asort(split(mid(content,2),"/"),"/")
End Function
Function geturl(exportfile)
If len(postlines)<20 then geturl = "No URL available." : Exit Function
w3gfile = replace(exportfile, "[1]", "")
w3gfile = replace(w3gfile,".txt",".w3g (")
temparr=split(postlines,w3gfile)
if ubound(temparr)<1 then geturl = "No URL available." : Exit Function
httpmark=instr(temparr(1),"http://")
If httpmark=0 then geturl = "No URL available." : Exit Function
httptext = mid(temparr(1),httpmark)
geturl = left(httptext,instr(httptext,"showtopic=")+14)
'geturl = mid(temparr(1),httpmark,57)
End Function
'
http://dota-allstars.com/forums/index.php?showtopic=10110' Function missingnames()
' posts = replaynames(sorted&"0000 POSTS 0000.txt")
' replays = asort(FilesInFolder(replayf))
' for each post in posts
' for each replay in replays
' if replay = post the
' End Function
Function list(arrayy)
stringg=""
For i = 0 to ubound(arrayy)
stringg=stringg&vbCrLf&i+1&".) "&arrayy(i)
Next
list=stringg
End Function
Function list2(arr, arr1)
stringg=""
For i = 0 to ubound(arr)
stringg=stringg&vbCrLf&i+1&".) "&arr(i)&vbCrLf&arr1(i)
Next
list2=stringg
End Function
Function FilesInFolder(folder)
Dim FO, fil, FC
Set FO = FSO.GetFolder(folder)
Set FC = FO.Files
FI=""
For each fil in FC
FI=FI&"/"&fil.name
Next
FilesInFolder=mid(FI,2)
End Function
'// complicated booger. seems like it would be a simple thing to alphabetize an array.
'// but vbs leaves it all up to you!! . credits: (started by sox52(u can tell))
Public Function asort(ByRef arr(),frog)
Dim value,index,firstItem,indexLimit,lastSwap,temparr, arr1, arr2
temparr=split(lcase(join(arr,frog)),frog)' //lcase the whole array
arr1=temparr' //saved to preserve the same order as arr but lcased
arr2=temparr' //saved for like a blank array to be overwritten
numEls = UBound(temparr)
firstItem = LBound(temparr)
lastSwap = numEls
Do' // double loop to sort lcase array
indexLimit = lastSwap - 1
lastSwap = 0
For Index = firstItem To indexLimit
value = temparr(Index)
If (value > temparr(Index + 1)) Then
'// if the items are not in order, swap them
temparr(Index) = temparr(Index + 1)
temparr(Index + 1) = value
lastSwap = Index
End If
Next
Loop While lastSwap
dim j,i
for j = firstitem to numEls
for i = firstItem to numEls
if arr1(i)=temparr(j) then' // match up the order of temparr
arr2(j)=arr(i)' //filling in the blank array with the preserved case array
exit for
end if
next
next
asort=arr2
End Function
Public Function InString(arr1, str1)
for each ar1 in arr1
If instr(str1, ar1) Then
InString = true
Exit Function
End If
Next
InString = false
End Function
'//////////////////
'// AND NOW SUBS //
'//////////////////
'functions have to come before subs, I know it's dumb
'//attempt to orderchat by content
Sub OrderChatCont(filepath, mode)
Dim Content, Content1, chat
file2=replace(filepath,right(filepath,4),"2.txt")
If not FSO.fileexists(file2) then addchat vbred, file2&" does not exist!" : Exit sub
If mode = 0 Then
vLines = getchat(Filepath,"")
vLines1 = getchat(file2,"")
ElseIf mode = 1 Then
vLines = getitems(readtext(Filepath))
vLines1 = getitems(readtext(file2))
End If
'spaces=""
vLines = Split(vLines, vbCrLf)
vLines1 = Split(vLines1, vbCrLf)
chat=""
donelines = " "
'afktimes = ""
'afkmode = 0
newfile = replace(filepath,exports,"")
For each vLine1 in vLines1
If instr(vLine1,": ") Then
matchline = left(vline1,8)&mid(vline1,instr(vLine1,": "))
For i = 0 to ubound(vLines)
If instr(vLines(i),": ") Then
If left(vlines(i),8)&mid(vlines(i),instr(vLines(i),": ")) = matchline Then
if mode = 1 then
chat=chat&vline&space(75-len(vline))&vbCrLf
Exit For
else
if instr(donelines,s&i&s)=0 Then
chat=chat&vlines(i)&vbCrLf
donelines = donelines & i &s
if left(vlines(i+1),3)="AFK" Then chat = chat & vlines(i+1) & vbCrLf & vlines(i+2) & vbCrLf
Exit For
End If
End If
End If
End If
Next
Else
chat=chat&vLine1&vbCrLf
End If
Next
' playersxx=""
' For i = 14 to 26
' if mid(vLines(i),27,6) = "Player" then
' playersxx=playersxx&mid(vLines(i),7,15)&mid(vLines(i),57,1)&vbCrLf
' end if
' Next
If mode = 0 Then
writetext sorted&newfile, vlines(4)&vbCrLf&newfile&vbCrLf&chat
ElseIf mode = 1 Then
writetext sorted&"items\"&newfile, newfile&chat
End If
End sub
'//this takes 1 of each type of chat file and combines the 2 to get player names AND order.
Sub orderchat(filepath,filepath1)
Dim Content, Content1, chat
Content = ReadText(Filepath)
Content1 = ReadText(Filepath1)
vLines = Split(Content, vbCrLf)
vLines1 = Split(Content1, vbCrLf)
chat=""
newfile = replace(filepath,chatf,"")
For each vLine1 in vLines1
If instr(vLine1,": ") Then
matchline = left(vline1,8)&mid(vline1,instr(vLine1,": "))
For each vLine in vLines
If instr(vLine,": ") Then
If left(vline,8)&mid(vline,instr(vLine,": ")) = matchline Then
chat=chat&vline&vbCrLf
Exit For
End If
End If
Next
Else
chat=chat&vLine1&vbCrLf
End If
Next
writetext sorted&newfile, newfile&chat
End sub
Sub checkfile_Event_Load
addchat RGB(210,107,87), "botpath = "&botpath
count=0 : missingfiles="" : ccount=0
For i = 0 to ubound(requiredfiles)
shortpath=replace(requiredfiles(i),botpath,"")
If right(requiredfiles(i),1)="\" Then
If FSO.FolderExists(requiredfiles(i)) Then
addchat color(ccount), shortpath&" -- folder --> CHECK!!"
Else
FSO.CreateFolder requiredfiles(i)
colorx=color(ccount)
addchat colorx, shortpath&" NOT FOUND!. Don't trip, I'll make an empty folder for you."
addchat colorx, shortpath&" -- folder --> CHECK!!"
End If
Else
If FSO.FileExists(requiredfiles(i)) Then
addchat color(ccount), shortpath&" -- file --> CHECK!!"
Else
addchat RGB(206,10,14), "ERROR: Missing required file!"&vbCrLf&requiredfiles(i)&" Not found."
missingfiles=missingfiles&requiredfiles(i)&vbCrLf
count=count+1
End If
End If
ccount=ccount+1
if ccount=7 then ccount=0
Next
If count>0 Then
addchat RGB(206,10,14), "ERROR, "&count&" required files are missing from your bot folder."&vbCrLf&missingfiles&"Check where you got this plug in from and get all the files. RA commands disabled."
disabled=1
End If
End Sub
Sub movefile(pathfrom, pathto)
If not FSO.FolderExists(pathto) Then FSO.CreateFolder(pathto)
checkname = mid(pathfrom, instrrev(pathfrom, "\")+1)
If FSO.FileExists(pathfrom) Then
If FSO.FileExists(pathto&checkname) Then
newname=left(checkname,len(checkname)-4)&".RN."&round(rnd*1000)&".txt"
Set FC = FSO.GetFile(pathfrom)
FC.Name = newname
FSO.MoveFile pathfrom&newname, pathto
addchat vbgreen, "There was already a file by that name. So I renamed it"
Exit Sub
End If
FSO.MoveFile pathfrom, pathto
addchat vbcyan, "File moved from "&pathfrom&" to "&vbCrLf&pathto&checkname
Else
addchat vbred, "ERROR! file: '"&checkfile&" does not exist in "&vbCrLf&pathfrom
End If
End Sub
Sub DeleteThisFile(filepath)
'Dim File
'If FSO.FileExists(filepath) Then
' Set File = FSO.GetFile(filepath)
FSO.DeleteFile(filepath)
'End If
Set File = FSO.OpenTextFile(filepath,8,true)
'File.Write ""
End Sub
Sub AppendLine(filepath,text)
Dim File
If FSO.FileExists(filepath) Then
Set File = FSO.GetFile(filepath)
End If
Set File = FSO.OpenTextFile(filepath,8,true)
File.WriteLine text
End Sub
Sub WriteText1(filepath,text)
Dim File
If FSO.FileExists(filepath) Then
Set File = FSO.GetFile(filepath)
End If
Set File = FSO.OpenTextFile(filepath,2,true)
File.Write text
End Sub
Sub WriteText(filepath,text)
Dim File
If FSO.FileExists(filepath) Then
Set File = FSO.GetFile(filepath)
End If
Set File = FSO.OpenTextFile(filepath,2,true)
File.Write text
End Sub
'// can't get this to work, so I'll just make urls I guess.
Sub PHPparse(mode)
exfiles = split(filesinfolder(phpfolder),"/")
exfiles = filter(exfiles,".w3g")
donefiles = "/"&filesinfolder(exports)&"/"
If mode = 1 then
If FSO.FileExists(exports&exfiles(0)&".txt") or FSO.FileExists(exports&exfiles(0)&".txt") Then mode = 2
End If
for each ex in exfiles
ex=left(ex,len(ex)-4)
If instr(donefiles,"/"&ex&".txt/")=0 Then
addchat vbyellow, localhostpath&ex
If mode=2 Then link2 localhostpath&ex
if mode=0 then
mode=1
link2 localhostpath&ex
End If
End If
Next
End Sub
'// this is really spare parts. Just used it once to rearange my sorted.txt so I wouldn't have to bother scinet and bots
'// again with those 100 or so replays
' Sub temptosort
' content=readtext(sorted&"SORTED.txt")
' vlines=split(content,vbCrLf)
' stuff=""
' For each vline in vlines
' if len(vline)>100 then
' stuff=stuff&left(vline,27)&mid(vline,40,10)&mid(vline,29,10)&right(vline,68)&vbCrLf
' else
' stuff=stuff&vline&vbCrLf
' end if
' next
' writetext sorted&"SORTED.txt", stuff
' End Sub
'//* one type is created with 'sort actions by player' on and the other with it off
[/div]
