Time Elapsed: " & TimeElapsed & " ticks (tenths of a millisecond)"
Set objProfiler = Nothing
end function
'================
'render the options on the nav bar
function NavBarSubsites
%>
edit details |
| add a topic |
| add a PK3 |
| edit a PK3 |
| log out |
<%
else
'no cookie found, give them some options
%>
<%
end function
dim nl
'should use vblf instead but some old functions may use nl
nl = Chr(13) & Chr(10)
dim date_now
date_now = date
'make sure we have at least some results
date_now = DatePart("d",date_now) & " " & MonthName(DatePart("m",date_now),true) & " " & DatePart("yyyy",date_now) & " " & Lcase(time)
if debug then
Response.Write("date_now=[" & date_now & "]
")
end if
'makes a nice safe easy-to-use date format
function SQLdate(this_date)
SQLdate = DatePart("d",this_date) & " " & MonthName(DatePart("m",this_date),true) & " " & DatePart("yyyy",this_date) & " " & DatePart("h",this_date) & ":" & DatePart("n",this_date) & ":" & DatePart("s",this_date)
end function
function funkydate(this_date)
tmp_hour = DatePart("h",this_date)
tmp_min = DatePart("n",this_date)
if tmp_min < 10 then
tmp_min = "0" & tmp_min
end if
tmp_time = tmp_hour & ":" & tmp_min
funkydate = DatePart("d",this_date) & " " & MonthName(DatePart("m",this_date),true) & " " & DatePart("yyyy",this_date) & " " & tmp_time
end function
'convert the date to a universal format (that looks better too :])
function funkdate(byval full_date)
dim t_hour, t_minute
t_hour = DatePart("h",full_date)
if Right(full_date,2) = "PM" then
t_hour = t_hour + 12
end if
if t_hour = 24 then
t_hour = 0
end if
'do a catch of errors over 24hr (not sure why it happens)
if t_hour > 24 then
t_hour = t_hour - 12
end if
t_minute = DatePart("n",full_date)
if t_minute < 10 then
t_minute = "0" & t_minute
end if
'construct it
funkdate = DatePart("d",full_date) & _
"." & MonthName(DatePart("m",full_date),true) & _
"." & Mid(DatePart("yyyy",full_date),3) & _
" " & t_hour & ":" & t_minute
end function
'show time diff in hours
function hours_from_now(byval old_date)
hours_from_now = round((datediff("h",old_date,now())),2)
end function
'show time diff in days
function days_from_now(byval old_date)
days_from_now = round((datediff("h",old_date,now())/ 24),2)
end function
'find out where the zip should be
function file_dir(filespec)
if (Lcase(Left(filespec,1)) = "a") or _
(Lcase(Left(filespec,1)) = "b") or _
(Lcase(Left(filespec,1)) = "c") or _
(Lcase(Left(filespec,1)) = "d") or _
(Lcase(Left(filespec,1)) = "e") or _
(Lcase(Left(filespec,1)) = "f") then
file_dir = "a-f"
elseif (Lcase(Left(filespec,1)) = "g") or _
(Lcase(Left(filespec,1)) = "h") or _
(Lcase(Left(filespec,1)) = "i") or _
(Lcase(Left(filespec,1)) = "j") or _
(Lcase(Left(filespec,1)) = "k") or _
(Lcase(Left(filespec,1)) = "l") then
file_dir = "g-l"
elseif (Lcase(Left(filespec,1)) = "m") or _
(Lcase(Left(filespec,1)) = "n") or _
(Lcase(Left(filespec,1)) = "o") or _
(Lcase(Left(filespec,1)) = "p") or _
(Lcase(Left(filespec,1)) = "q") or _
(Lcase(Left(filespec,1)) = "r") then
file_dir = "m-r"
elseif (Lcase(Left(filespec,1)) = "s") or _
(Lcase(Left(filespec,1)) = "t") or _
(Lcase(Left(filespec,1)) = "u") or _
(Lcase(Left(filespec,1)) = "v") or _
(Lcase(Left(filespec,1)) = "w") or _
(Lcase(Left(filespec,1)) = "x") or _
(Lcase(Left(filespec,1)) = "y") or _
(Lcase(Left(filespec,1)) = "z") then
file_dir = "s-z"
else
file_dir = "other"
end if
end function
' makes sql strings safe from '
Function SQLSafe(byVal S)
SQLSafe = replace(S,"'","''")
End function
' work out a date, one every can understand
function realdate(ByVal thisdate)
if thisdate <> "" then
if Cdate(thisdate) then
'response.write("thisdate=" & thisdate & "
")
realdate = DatePart("d",thisdate) & "." & MonthName(DatePart("m",thisdate),true) & "." & DatePart("yyyy",thisdate)
end if
end if
end function
function realdateshort(ByVal thisdate)
if thisdate <> "" then
if Cdate(thisdate) then
'response.write("thisdate=" & thisdate & "
")
realdateshort = DatePart("d",thisdate) & "." & MonthName(DatePart("m",thisdate),true) & "." & Right(DatePart("yyyy",thisdate),2)
end if
end if
end function
'%%%%%%%%%
'% file query info starts here
'checking for a Language File for a review
function LanguageFileCHK(byval Filename)
dim fso
set fso = CreateObject("Scripting.FileSystemObject")
'Response.Write("filespec=" & filespec & "
")
if fso.fileExists(Filename) then
LanguageFileCHK = true
end if
set fso = nothing
end function
'reading a Language File for a review
function LanguageFileREAD(byval Filename)
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(Filename, ForReading, True)
LanguageFileREAD = f.ReadAll
f.Close
end function
' getting the date of the folder
Function ShowDateCreated(folderspec)
dim fso, f
set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(folderspec)
ShowDateCreated = f.DateCreated
End Function
' getting the date of the file
Function ShowFileDateCreated(filespec)
dim fso, f
set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(filespec)
ShowFileDateCreated = f.DateCreated
End Function
'check for file size - in bytes
Function FileSize(filespec)
'Response.Write("filespec=" & filespec & "
")
dim fso, f, sl, S
set fso = CreateObject("Scripting.FileSystemObject")
if fso.fileExists(filespec) then
Set f = fso.GetFile(filespec)
if f.size < 1024 then
s = Fix(f.size) & " bytes"
else
s = Fix(f.size/1024) & " kb"
end if
end if
FileSize = s
'FileSize = "GSN is FUCKED!"
End Function
Function FileSize2(filespec)
'Response.Write("filespec=" & filespec & "
")
Dim fso, f, s
set fso = CreateObject("Scripting.FileSystemObject")
if fso.FileExists(filespec) then
Set f = fso.GetFile(filespec)
s = "(" & round((f.size/1024)/1024,2) & " MB)"
FileSize2 = s
'FileSize2 = "(GSN is FUCKED!)"
else
FileSize2 = ""
end if
Set f = nothing
Set fso = nothing
End Function
Function FileSize3(filespec)
'just the file size this time plz (in bytes)
dim fso, f, s
set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(filespec)
s = f.size
FileSize3 = s
End Function
function BetaImageCheckSM(filespec)
dim fso
set fso = CreateObject("Scripting.FileSystemObject")
'Response.Write(beta_shots & filespec & "sm.jpg")
if (fso.FileExists(beta_shots & filespec & "sm.jpg")) then
if FileSize3(beta_shots & filespec & "sm.jpg") < 3100 then
'Response.Write("this is image is fine (sm)
")
BetaImageCheckSM = true
end if
end if
end function
function BetaImageCheckLG(filespec)
dim fso
set fso = CreateObject("Scripting.FileSystemObject")
if (fso.FileExists(beta_shots & filespec & "lg.jpg")) then
if FileSize3(beta_shots & filespec & "lg.jpg") < 42000 then
'Response.Write("this is image is fine (lg) :]
")
BetaImageCheckLG = true
end if
end if
end function
function ModImageCheckSM(filespec)
dim fso
set fso = CreateObject("Scripting.FileSystemObject")
'Response.Write(beta_shots & filespec & "sm.jpg")
if (fso.FileExists(mods_shots & filespec & "sm.jpg")) then
if FileSize3(mods_shots & filespec & "sm.jpg") < 3100 then
'Response.Write("this is image is fine (sm)
")
ModImageCheckSM = true
end if
end if
end function
function ModImageCheckLG(filespec)
dim fso
set fso = CreateObject("Scripting.FileSystemObject")
if (fso.FileExists(mods_shots & filespec & "lg.jpg")) then
if FileSize3(mods_shots & filespec & "lg.jpg") < 42000 then
'Response.Write("this is image is fine (lg) :]
")
ModImageCheckLG = true
end if
end if
end function
'use this to go back one folder
Function GetTheParent(DriveSpec)
dim fso
set fso = CreateObject("Scripting.FileSystemObject")
GetTheParent = fso.GetParentFolderName(Drivespec)
End Function
Function ShowFileAccessInfo(filespec)
dim fso, f, s
set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(filespec)
's = filespec
' s = s & "Created: " & f.DateCreated & " - "
' s = s & "Last Accessed: " & f.DateLastAccessed & " - "
' s = s & "Last Modified: " & f.DateLastModified
' s = s & funkdate(f.DateLastModified)
' ShowFileAccessInfo = s
' this is all we need :]
ShowFileAccessInfo = realdateshort(f.DateLastModified)
End Function
'%%%%%%%%%
'% file quiey info ends here
Function ValidEmail(byVal S)
dim Sa,Sb,Sc
Sa = InStr(1,S,"@")
Sb = InStr(1,S,".")
Sc = InStr(1,S," ")
'Response.Write("Sa = " & Sa & "
")
'Response.Write("Sb = " & Sb & "
")
'Response.Write("Sc = " & Sc & "
")
if (Sc <> 0) or _
(Sb = 0) or _
(S = "") or _
(Sa = 0) or _
(Sa = 1) or _
(cint(Sa) = Len(S)) or _
(CInt(Sb) = (CInt(Sa)+1)) or _
(CInt(Sa) = (CInt(Sb)+1)) then
ValidEmail = false
else
ValidEmail = true
end if
end function
Function JAVAS(byVal S)
dim l,i,R,C
l = Len(S)
R = ""
for i = 1 to l
C = mid(S,i,1)
if (C = "'") Then
R = R & "/'"
elseif (C = "'") Then
R = R & "/" & Chr(34)
elseif (C = Chr(13)) Then
R = R & "//n"
elseif (C = Chr(10)) Then
R = R & "//r"
elseif (C = Chr(7)) Then
R = R & "//t"
else
R = R & C
end if
next
JAVAS = R
End function
Function FileExists(filespec)
Dim fso, msg
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FileExists(current_ROOT & filespec)) Then
if debug then
Response.Write("FileExists = true
")
end if
FileExists = true
Else
if debug then
Response.Write("FileExists = false
")
end if
FileExists = false
End If
End Function
Function ReadEntireFile(ByVal filename)
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, f
if debug then
Response.Write("Read Entire File - " & current_ROOT & filename & "
")
end if
Set fso = CreateObject("Scripting.FileSystemObject")
if FileExists(filename) Then
'readme
'Set f = fso.OpenTextFile(current_ROOT & filename, ForReading, True)
Set f = fso.OpenTextFile(readme & filename, ForReading, True)
ReadEntireFile = f.ReadAll
f.Close
else
ReadEntireFile = "The content file " & filename & " does not exist
" & _
"I'm looking for " & current_ROOT & filename & "
On the server at " & Request.ServerVariables("LOCAL_ADDR")
end if
End Function
'======================
'reading the XML short map list
'======================
function ReadXMLMainNews(byval XMLToRead)
'if the cached date + 1 hour is great than now show the cached vars
if dateadd("h",1,Application("lvlNewsCache")) > now() then
' Response.Write("old news
")
' Response.Write("Application(""lvlNewsCache"")=[" & Application("lvlNewsCache") & "]
")
' Response.Write("NewsDate=["& Application("lvlNewsDate") &"]
")
'
NewsDate = Application("lvlNewsDate")
LevelCount = Application("lvlLevelCount")
LastMapDate = Application("lvlLastMapDate")
CurrentNews = Application("lvlCurrentNews")
else
'Response.Write("current_ROOT & XMLToRead=[" & current_ROOT & XMLToRead & "]
")
'Response.Write("new news
")
'Response.Write("Application(""lvlNewsCache"")=[" & Application("lvlNewsCache") & "]
")
dim error, objXML, articles
Set objXML = CreateObject("Microsoft.XMLDOM")
objXML.async = False
objXML.Load (current_ROOT & XMLToRead)
if objXML.parseError.errorCode <> 0 Then
dim tmp_body
tmp_body = objXML.parseError.errorCode & " at " & now()
if Request.ServerVariables("LOCAL_ADDR") = local_ip then
call cdontstime("lvl@ebom.org", "lvl@ebom.org", "XML main news problem", tmp_body)
else
call emailtime("lvl@ebom.org", "lvl@ebom.org", "XML main news problem", tmp_body)
end if
'Response.Write("No news is good news, well, in this case there is a problem and Tigger will fix it very soon")
NewsDate = Application("lvlNewsDate")
LevelCount = Application("lvlLevelCount")
LastMapDate = Application("lvlLastMapDate")
CurrentNews = Application("lvlCurrentNews")
else
set articles = objXML.documentElement.selectnodes("news")
NewsDate = objXML.documentElement.childnodes(0).childnodes(0).text
LevelCount = objXML.documentElement.childnodes(0).childnodes(1).text
LastMapDate = objXML.documentElement.childnodes(0).childnodes(2).text
CurrentNews = objXML.documentElement.childnodes(0).childnodes(3).text
set articles = nothing
end if
set objXML = nothing
'set the cache timeout
Application("lvlNewsCache") = now()
'now the cache
Application("lvlNewsDate") = NewsDate
Application("lvlLevelCount") = LevelCount
Application("lvlLastMapDate") = LastMapDate
Application("lvlCurrentNews") = CurrentNews
end if
end function
'======================
'reading the XML p1mpin' link
'======================
function ReadXMLPimpLink(byval XMLToRead)
'if the cached date + 1 hour is great than now show the cached vars
if dateadd("h",1,Application("lvlPimpCache")) > now() then
PimpLink = Application("lvlPimpLink")
PimpLinkTitle = Application("lvlPimpLinkTitle")
PimpLinkCopy = Application("lvlPimpLinkCopy")
PimpLinkURL = Application("lvlPimpLinkURL")
'Response.Write("no need for update - now()=[" & now() & "] and lvlNewsCahce=[" & Application("lvlNewsCache") & "]")
else
dim error, objXML, articles
Set objXML = CreateObject("Microsoft.XMLDOM")
objXML.async = False
objXML.Load (current_ROOT & XMLToRead)
if objXML.parseError.errorCode <> 0 Then
dim tmp_body
tmp_body = objXML.parseError.errorCode & " at " & now()
if Request.ServerVariables("LOCAL_ADDR") = local_ip then
call cdontstime("lvl@ebom.org", "lvl@ebom.org", "XML Pimp Link problem", tmp_body)
else
call emailtime("lvl@ebom.org", "lvl@ebom.org", "XML Pimp Link problem", tmp_body)
end if
'Response.Write("No news is good news, well, in this case there is a problem and Tigger will fix it very soon")
PimpLink = Application("lvlPimpLink")
PimpLinkTitle = Application("lvlPimpLinkTitle")
PimpLinkCopy = Application("lvlPimpLinkCopy")
PimpLinkURL = Application("lvlPimpLinkURL")
'Response.Write("use old ones")
else
set articles = objXML.documentElement.selectnodes("pimplinkdata")
'Response.Write("get new ones")
PimpLink = objXML.documentElement.childnodes(0).childnodes(0).text
PimpLinkTitle = objXML.documentElement.childnodes(0).childnodes(1).text
PimpLinkCopy = objXML.documentElement.childnodes(0).childnodes(2).text
PimpLinkURL = objXML.documentElement.childnodes(0).childnodes(3).text
set articles = nothing
'now the cache
Application("lvlPimpLink") = PimpLink
Application("lvlPimpLinkTitle") = PimpLinkTitle
Application("lvlPimpLinkCopy") = PimpLinkCopy
Application("lvlPimpLinkURL") = PimpLinkURL
Application("lvlPimpCache") = now()
'Response.Write("reset vars")
end if
set objXML = nothing
end if
end function
'======================
'reading the XML short map list
'======================
function ReadXMLMapList(byval XMLToRead)
'Response.Write("now()=["& second(now()) &"]
")
dim error, objXML, articles, list, mapId, mapTitle, j, i
Set objXML = CreateObject("Microsoft.XMLDOM")
objXML.async = False
'objXML.Load ("d:\websites\lvlq3a\xml\recentlevels.xml")
objXML.Load (current_ROOT & XMLToRead)
if objXML.parseError.errorCode <> 0 Then
dim tmp_body
tmp_body = objXML.parseError.errorCode & " at " & now()
if Request.ServerVariables("LOCAL_ADDR") = local_ip then
call cdontstime("lvl@ebom.org", "lvl@ebom.org", "XMLMap list problem", tmp_body)
else
call emailtime("lvl@ebom.org", "lvl@ebom.org", "XMLMap list problem", tmp_body)
end if
'Response.Write("Problem with map list, email lvl@ebom.org please")
else
'set object for the nodelist of 'level' nodes
set articles = objXML.documentElement.selectnodes("level")
'get the number of level nodes in the xml file
list = articles.length
'For every 'level' node in the xml file
for i = 1 to (list-1)
mapId = objXML.documentElement.childnodes(i).childnodes(0).text
mapTitle = objXML.documentElement.childnodes(i).childnodes(1).text
Response.Write("" & safelen(mapTitle) & "![]() |
" & vbcr)
next
set articles = nothing
end if
set objXML = nothing
'Response.Write("now()=["& second(now()) &"]
")
end function
'======================
'reading the XML pk3 short list
'======================
function ReadXMLPK3List(byval XMLToRead)
'==============
'format of feed is;
'
' A PK3
'
dim error, objXML, articles, list, pk3Title, j, i
set objXML = CreateObject("Microsoft.XMLDOM")
objXML.async = False
'objXML.Load ("d:\websites\lvlq3a\xml\recentlevels.xml")
objXML.Load (current_ROOT & XMLToRead)
if objXML.parseError.errorCode <> 0 Then
dim tmp_body
tmp_body = objXML.parseError.errorCode & " at " & now()
if Request.ServerVariables("LOCAL_ADDR") = local_ip then
call cdontstime("lvl@ebom.org", "lvl@ebom.org", "XML PK3 list problem", tmp_body)
else
call emailtime("lvl@ebom.org", "lvl@ebom.org", "XML PK3 list problem", tmp_body)
end if
'Response.Write("Problem with PK3 list, email lvl@ebom.org please")
else
'set object for the nodelist of 'level' nodes
set articles = objXML.documentElement.selectnodes("PK3")
'get the number of level nodes in the xml file
list = articles.length
'For every 'level' node in the xml file
for i = 0 to (list-1)
pk3Title = objXML.documentElement.childnodes(i).childnodes(0).text
Response.Write("" & safelen(server.HTMLEncode(pk3Title)) & "![]() |
" & vbcr)
next
set articles = nothing
end if
set objXML = nothing
end function
function dloadcounter(byval level_id)
set tigdCON = Server.CreateObject("ADODB.Connection")
tigdCON.Open(DSN)
'is there any yet?
query = "SELECT num_dload " & _
"FROM q3a_download " & _
"WHERE level_id = '" & level_id & "'"
'Response.Write("query(count)=[" & query & "]
")
set tigdRS = tigdCON.Execute(query)
if tigdRS.EOF then
'must be a new map or 1st d/load
dloadcounter = "0"
else
dloadcounter = tigdRS("num_dload")
end if
tigdRS.Close
tigdCON.Close
end function
function emailtime(byval sendto, byval from, byval subject, byval body)
Dim JMail
Set JMail = Server.CreateObject("JMail.SMTPMail")
JMail.ServerAddress = "mail.gamespy.com;mail1.gamespy.com;mail2.gamespy.com;mail3.gamespy.com"
JMail.Sender = from
JMail.Subject = subject
JMail.AddRecipient sendto
JMail.AddRecipientBCC "lvl@ebom.org"
JMail.Body = body
JMail.Execute
'If JMail.Execute Then
' Response.Write "sent email message"
'Else
' Response.Write "send message returned false"
'End If
end function
function cdontstime(byval sendto, byval from, byval subject, byval body)
Dim CDONTSMail
Set CDONTSMail = CreateObject("CDONTS.NewMail")
CDONTSMail.To = sendto
CDONTSMail.Bcc = "lvl@ebom.org"
CDONTSMail.From = "lvl@ebom.org"
CDONTSMail.Subject = subject
CDONTSMail.Body = body
CDONTSMail.Send
Set CDONTSMail = Nothing
end function
'does an auto (
insert) line return
function insert_br(byval text)
insert_br = Replace(text,vbcr,"
")
end function
'does the revese of above :]
function insert_vblf(byval text)
insert_vblf = Replace(text,"
",vbcrlf)
insert_vblf = Replace(insert_vblf,"
",vbcrlf)
end function
function striphtml(byval text_to_clean)
'do a quick security check or 2
'this shoould catch "most" naughty ppl, but still allow bold,
'italics and other more formating based tags pass
striphtml = replace(text_to_clean,"<","<")
striphtml = replace(striphtml,">",">")
if Instr(1,lcase(striphtml),"<p>") then
striphtml = replace(striphtml,"<p>","")
striphtml = replace(striphtml,"<P>","
")
end if
if Instr(1,lcase(striphtml),"</p>") then
striphtml = replace(striphtml,"</p>","
")
striphtml = replace(striphtml,"</P>","")
end if
if Instr(1,lcase(striphtml),"<b>") then
striphtml = replace(striphtml,"<b>","")
striphtml = replace(striphtml,"<B>","")
end if
if Instr(1,lcase(striphtml),"</b>") then
striphtml = replace(striphtml,"</b>","")
striphtml = replace(striphtml,"</B>","")
end if
if Instr(1,lcase(striphtml),"<i>") then
striphtml = replace(striphtml,"<i>","")
striphtml = replace(striphtml,"<I>","")
end if
if Instr(1,lcase(striphtml),"</i>") then
striphtml = replace(striphtml,"</i>","")
striphtml = replace(striphtml,"</I>","")
end if
'do this clear here to remove unwanted
tags from cached session vars
if Instr(1,lcase(striphtml),"<br>") then
'Response.Write("found one!")
striphtml = replace(striphtml,"<br>","")
striphtml = replace(striphtml,"<BR>","")
end if
'do this clear here to remove unwanted
tags from cached session vars
if Instr(1,lcase(striphtml),"<br />") then
'Response.Write("found one!")
striphtml = replace(striphtml,"<br />","")
striphtml = replace(striphtml,"<BR />","")
end if
end function
function no_tags(byval text)
'Response.Write(text)
no_tags = replace(text,"","")
no_tags = replace(no_tags,"","")
no_tags = replace(no_tags,"","")
no_tags = replace(no_tags,"","")
no_tags = replace(no_tags,"
","")
no_tags = replace(no_tags,"
","")
no_tags = replace(no_tags,"","")
no_tags = replace(no_tags,"
","")
no_tags = replace(no_tags,"<","<")
no_tags = replace(no_tags,">",">")
end function
function httplink(byval text)
dim tmp_data, tmp_end, new_text, holdme, http
if len(text) > 0 then
'only do stuff if the comment contanins data
tmp_data = split(text,"http://")
httplink = tmp_data(0)
for http=1 to ubound(tmp_data,1)
holdme = replace(tmp_data(http),chr(13)," "& chr(13),1,1)
if instr(1,holdme," ") > 0 then
tmp_end = instr(1,holdme," ")
httplink = httplink & "http://"& trim(mid(holdme,1,tmp_end)) & replace(holdme," "," ",tmp_end,1)
else
httplink = httplink & "http://"& mid(holdme,1) &""
end if
next
end if
end function
function ftplink(byval text)
dim tmp_data, tmp_end, new_text, holdme, ftp
if len(text) > 0 then
'only do stuff if the comment contanins data
tmp_data = split(text,"ftp://")
ftplink = tmp_data(0)
for ftp=1 to ubound(tmp_data,1)
holdme = replace(tmp_data(ftp),chr(13)," "& chr(13),1,1)
if instr(1,holdme," ") > 0 then
tmp_end = instr(1,holdme," ")
ftplink = ftplink & "ftp://"& trim(mid(holdme,1,tmp_end)) & replace(holdme," "," ",tmp_end,1)
else
ftplink = ftplink & "ftp://"& mid(holdme,1) &""
end if
next
end if
end function
function insertLinks(data)
dim found, start_pos, end_pos, end_comment, chunk
end_comment = len(data)
start_pos = 1
do while not start_pos > end_comment
found = instr(start_pos, data, "http://")
'Response.Write("
start_pos [" & start_pos & "] found [" & found & "]" )
if found <> 0 then
end_pos = instr(found, data, " ")
if end_pos = 0 then
end_pos = end_comment + 1
end if
'Response.Write("end_pos [" & end_pos & "] end_comment [" &end_comment & "]")
chunk = mid(data, found, (end_pos - found))
'Response.Write("
chunk [" & chunk & "]")
data = replace(data, chunk, "" & chunk & "",1,1)
'Response.Write("
data [" & data & "]")
start_pos = end_pos + len(chunk) + 28
end_comment = len(data)
'Response.Write("
end [" & end_comment & "] next strt [" & start_pos & "]")
else
start_pos = end_comment + 1
end if
loop
'next
end_comment = len(data)
start_pos = 1
do while not start_pos > end_comment
found = instr(start_pos, data, "ftp://")
if found <> 0 then
end_pos = instr(found, data, " ")
if end_pos = 0 then
end_pos = end_comment + 1
end if
chunk = mid(data, found, (end_pos - found))
chunk = replace(chunk, "
", "")
data = replace(data, chunk, "" & chunk & "",1,1)
'Response.Write("
ftp data [" & data & "]")
start_pos = end_pos + len(chunk) + 28
end_comment = len(data)
else
start_pos = end_comment + 1
end if
loop
insertLinks = data
end function
'====================
'using reg exp to do formating of http://, ftp:// and email@
'modified mandog code to show on the host of the file, not
'the full url
Function InsertHyperlinks(inText, shortdisplay)
Dim objRegExp, strBuf
Dim objMatches, objMatch
Dim Value, ReplaceValue, iStart, iEnd, tmp_url_obj
strBuf = ""
iStart = 1
iEnd = 1
Set objRegExp = New RegExp
objRegExp.Pattern = "\b(www|http|ftp|\S+@)\S+\b" ' Match URLs and emails
objRegExp.IgnoreCase = True ' Set case insensitivity.
objRegExp.Global = True ' Set global applicability.
Set objMatches = objRegExp.Execute(inText)
For Each objMatch in objMatches
iEnd = objMatch.FirstIndex
strBuf = strBuf & Mid(inText, iStart, iEnd-iStart+1)
tmp_url_obj = replace(objMatch.Value," 0 then
strBuf = strBuf & GetHref(tmp_url_obj, "WEB", "_TOP", true)
else
strBuf = strBuf & GetHref(tmp_url_obj, "WEB", "_BLANK", true)
end if
else
if instr(1,objMatch.Value,"planetquake.com/lvl") > 0 then
strBuf = strBuf & GetHref(tmp_url_obj, "WEB", "_TOP", false)
else
strBuf = strBuf & GetHref(tmp_url_obj, "WEB", "_BLANK", false)
end if
end if
End If
iStart = iEnd + objMatch.Length + 1
Next
strBuf = strBuf & Mid(inText, iStart)
InsertHyperlinks = replace(strBuf,vblf,"
")
'InsertHyperlinks = strBuf
End Function
'html format www, htp, ftp or email. Allows for target for links and subject for email
Function GetHref(url, urlType, Target, shortdisplay)
Dim strBuf, show, host_s, host_e
'insert a space every column width to maintain table formatting
'if len(url) > 72 then
' show = breakDisplay(url,72)
'else
show = url
'end if
if (urlType = "WEB") and (shortdisplay) then
if instr(1,show,"://") > 1 then
host_s = instr(1,show,"://") + 3
'Response.Write("found :// at " & instr(1,show,"://") & "
")
'Response.Write("start display (host_s) at " & host_s & "
")
else
host_s = 1
'Response.Write("no :// found
")
'Response.Write("start display (host_s) at " & host_s & "
")
end if
if instr(host_s + 2,show,"/") > 1 then
host_e = instr(host_s + 2,show,"/")
'Response.Write("found / at " & instr(host_s + 2,show,"/") & "
")
'Response.Write("last chr to be displayed at " & host_e & "
")
else
host_e = len(show) + 1
'Response.Write("last chr to be displayed at " & host_e & "
")
end if
'only show the host domain
show = mid(show,host_s, host_e - host_s)
'Response.Write("show(aftermid)=[" & show & "]
")
end if
strBuf = "<a href="""
if UCase(urlType) = "WEB" then
if LCase(Left(url, 3)) = "www" then
strBuf = "" & show & ""
elseif LCase(Left(url, 4)) = "ftp." then
strBuf = "" & show & ""
else
strBuf = "" & show & ""
end if
elseif UCase(urlType) = "EMAIL" then
strBuf = "" & show & ""
end if
GetHref = strBuf
End Function
'breaks display text into column width chunks by inserting a space
function breakDisplay(data,break)
dim strbuf_L, strbuf, startpt, found
startpt = 1
do while not startpt > len(data)
found = instr(startpt,data," ")
if found > break or found = 0 then
strbuf_L = mid(data,startpt,break)
strbuf = strbuf & strbuf_L & " "
startpt = startpt + break + 1
else
startpt = strtpt + 1
end if
loop
breakDisplay = trim(strbuf)
end function
'=================
'end reg exp code
function SafeLength2(data)
dim start_pos, found, chunk
start_pos = 1
do while not start_pos > len(data)
found = instr(start_pos, data, " ")
'Response.Write("
start_pos [" & start_pos & "] found [" & found & "]")
if found > 72 then
chunk = mid(data, start_pos, 72)
data = replace(data, chunk, chunk & vbcrlf, 1,1)
Response.Write("
data [" & data & "]" )
start_pos = start_pos + 74
else
start_pos = found + 2
end if
loop
SafeLength = data
end function
function SafeLength(text)
dim how_long, cleaned_txt, one_space
how_long = len(text)
one_space = 1
cleaned_txt = ""
for i = 1 to how_long
if mid(text,i,1) = " " or mid(text,i,1) = chr(13) then
'update the one_space number
one_space = i
'Response.Write("got one
")
end if
if (i-one_space) > 72 then
'Response.Write("in here plz
")
cleaned_txt = cleaned_txt & mid(text,i,1) & vbcrlf
one_space = i
else
cleaned_txt = cleaned_txt & mid(text,i,1)
end if
next
'Response.Write("txt=[" & replace(replace(cleaned_txt,"<","<"),">",">") & "]
")
SafeLength = cleaned_txt
end function
dim encode(9,11)
function encodeTable
encode(0,0) = "G"
encode(1,0) = "S"
encode(2,0) = "C"
encode(0,1) = "A"
encode(1,1) = "U"
encode(2,1) = "I"
encode(3,1) = "m"
encode(4,1) = "H"
encode(5,1) = "E"
encode(6,1) = "O"
encode(7,1) = "u"
encode(8,1) = "R"
encode(9,1) = "Y"
encode(0,2) = "R"
encode(1,2) = "G"
encode(2,2) = "K"
encode(3,2) = "T"
encode(4,2) = "B"
encode(5,2) = "X"
encode(6,2) = "Z"
encode(7,2) = "D"
encode(8,2) = "K"
encode(9,2) = "V"
encode(0,4) = "G"
encode(1,4) = "K"
encode(2,4) = "F"
encode(3,4) = "S"
encode(4,4) = "T"
encode(5,4) = "W"
encode(6,4) = "V"
encode(7,4) = "D"
encode(8,4) = "Q"
encode(9,4) = "M"
encode(0,5) = "8"
encode(1,5) = "1"
encode(2,5) = "A"
encode(3,5) = "E"
encode(4,5) = "y"
encode(5,5) = "0"
encode(6,5) = "U"
encode(7,5) = "O"
encode(8,5) = "H"
encode(9,5) = "3"
encode(0,6) = "W"
encode(1,6) = "R"
encode(2,6) = "X"
encode(3,6) = "G"
encode(4,6) = "Z"
encode(5,6) = "Q"
encode(6,6) = "M"
encode(7,6) = "K"
encode(8,6) = "L"
encode(9,6) = "S"
encode(0,8) = "Q"
encode(1,8) = "S"
encode(2,8) = "T"
encode(3,8) = "G"
encode(4,8) = "K"
encode(5,8) = "l"
encode(6,8) = "5"
encode(7,8) = "B"
encode(8,8) = "F"
encode(9,8) = "P"
encode(0,9) = "E"
encode(1,9) = "a"
encode(2,9) = "e"
encode(3,9) = "I"
encode(4,9) = "O"
encode(5,9) = "U"
encode(6,9) = "Y"
encode(7,9) = "H"
encode(8,9) = "A"
encode(9,9) = "8"
encode(0,10) = "M"
encode(1,10) = "K"
encode(2,10) = "X"
encode(3,10) = "Z"
encode(4,10) = "G"
encode(5,10) = "L"
encode(6,10) = "B"
encode(7,10) = "P"
encode(8,10) = "T"
encode(9,10) = "V"
end function
function IPEncode(data)
dim output, start_pos, num, last, olong, t
'Response.Write("
in data [" & data & "]")
if instr(data, ".") = 2 then
data = "00" & data
elseif instr(data,".") = 3 then
data = "0" & data
end if
'Response.Write("
data1 [" & data & "]")
if mid(data,6,1) = "." then
output = left(data,4) & "00" & right(data,len(data) - 4)
data = output
elseif mid(data,7,1) = "." then
output = left(data,4) & "0" & right(data,len(data) - 4)
data = output
end if
'Response.Write("
data2 [" & data & "]")
if mid(data,10,1) = "." then
output = left(data,8) & "00" & right(data,len(data) - 8)
data = output
elseif mid(data,11,1) = "." then
output = left(data,8) & "0" & right(data,len(data) - 8)
data = output
end if
'Response.Write("
data2 [" & data & "]")
output = ""
for t = 0 to 10
num = mid(data,t+1, 1)
if num <> "." and isNumeric(num) then
output = output & encode(cint(num),t)
else
output = output & "-"
end if
next
if len(data) = 13 then
IPEncode = output & "-" & right(data,1)
elseif len(data) = 14 then
IPEncode = output & "-" & right(data,2)
else
IPEncode = output & "-" & right(data,3)
end if
end function
'=============================
'encodes the admin ip numbers
'=============================
function ipmask(ip_number)
'203.164.170.86 = cable modem
'203.24.131.70 = tig main box
'203.24.131.71 = tig BSD box
'203.24.131.72 = mandog old box
'203.24.131.74 = mandog main box
'203.62.157.160 = tig work box
if (ip_number = "203.164.170.86") or (ip_number = "203.24.131.70") or (ip_number = "203.24.131.71") or (ip_number = "203.24.131.72") or (ip_number = "203.24.131.74") or (ip_number = "203.62.157.160") then
ipmask = "..::LvL Admin"
else
ipmask = "id#" & IPEncode(ip_number)
end if
end function
%>