This is an application to administer a website remotely through an ASP
<SCRIPT LANGUAGE="VBScript" RUNAT="Server" >
</SCRIPT >
<%
' ** Copyright 1999-2001 by John Martin d/b/a www.ANYPORTAL.com **
' ** All Rights Reserved. **
' ** **
' ** This software is freeware and is not in the public domain. **
' ** You are hereby granted the right to freely distribute this **
' ** software as long as this copyright notice remains in place. **
' ** **
' ** Comments or suggestions? email: andmore@alief.com **
' ** **
' ** Date Remarks **
' ** --------- ----------------------------------------------- **
' ** 25 MAY 99 original **
' ** 26 MAY 99 allow the script to run from a subdirectory **
' ** 27 MAY 99 increase security use of cookie **
' ** 03 JUN 99 fix UNIX html file record endings **
' ** 07 JUN 99 fix spaces in file name problem **
' ** 10 JUL 99 fix subdirectory problem with createimagetag **
' ** 10 JUL 99 add create document/folder logic **
' ** 11 JUL 99 fix spaces in file name, again **
' ** 11 JUL 99 .cfm & .php3 now edit like .asp/.html, etc. **
' ** 25 JUL 99 add interface to SA-FILEUP to upload files **
' ** 25 AUG 99 recode authorization routine, allow no password **
' ** 31 AUG 99 some cosmetic; integrate with email community **
' ** 01 SEP 99 add link on detail page **
' ** 05 SEP 99 add missing EndHTML on detail page **
' ** 24 OCT 00 plug /../ hole **
' ** 14 NOV 00 add Windows login security method **
' ** 14 NOV 00 convert in-line HTML to response.write **
' ** 14 NOV 00 improve shortcut parsing, clean-up link styles **
' ** 10 APR 01 make more file types editable/listable **
' ** 11 APR 01 add code to execute BAT and VBS files on server **
' ** 11 APR 01 allow either SA-FILEUP or ASPSimpleUpload **
' ** 07 JUN 01 add cut/paste textarea for img tags **
' ** 07 JUN 01 fix typo ! for ' **
' ** 12 JUN 01 fix missing IsEditable on detail page **
Option Explicit
' universal variables (these undo the option explicit)
Dim action
Dim a,b,c,i,item,j
Dim f,fso
Dim arr,tstr
' security
Dim gblPassword
gblPassword = NULL 'your password here
'^^^^------ NULL forces mandatory Windows login.
Dim gblUpload 'Pick one: how to do upload?
' gblUpload = "Script" 'not working. do not use.
gblUpload = "ASPSimpleUpload"
gblUpload = "SA-FILEUP"
' configuration
Dim gblSiteName,gblSiteCode
gblSiteName = Request.ServerVariables("SERVER_NAME")
gblSiteCode = ""
Dim gblNow 'server may not be local time
gblNow = Now
Dim gblFace,gblColor 'needs three quotes
gblFace = """Arial, Helvetica, sans-serif"""
gblColor = """#000066"""
Dim gblRed,gblReverse
gblRed = """#FF0000"""
gblReverse = """#E0E0E0"""
' global variables
Dim gblTitle,gblPageText
gblTitle = " * * * TITLE NOT SET * * * "
gblPageText = " "
' global constants
Dim gblScriptName,gblRoot
gblScriptName = Request.ServerVariables("Script_Name")
gblScriptName = Mid(gblScriptName,InstrRev(gblScriptName,"/") + 1)
gblRoot = Replace(Request.ServerVariables("Script_Name"),"/" & gblScriptName,"")
'--
'StartHTML
Sub StartHTML
response.write " <HTML > <HEAD > <TITLE >" & gblSiteName & " " & gblTitle & " </TITLE >" & VBCRLF
response.write " <META NAME=""description"" CONTENT=""AnyPortal"" " & gblTitle & ". " & gblSiteName & " >" & VBCRLF
response.write " <META NAME=""keywords"" CONTENT=""anyportal, " & Lcase(gblTitle) & ", anyportal " & Lcase(gblTitle) & ", one file footprint, www.anyportal.com, andmore, the ANDMORE Companies, Houston, Texas, active server pages, ASP, asp, 100% ASP, 100% asp"" >" & VBCRLF
response.write " </HEAD >" & VBCRLF
response.write " <BODY BGCOLOR=""#FFFFFF"" > <TABLE WIDTH=""100%"" >" & VBCRLF
response.write " <TR > <TD ALIGN=""RIGHT"" VALIGN=""BOTTOM"" > <FONT COLOR=" & gblColor & " SIZE=3 FACE=" & gblFace & " >" & gblSiteName
If Request.ServerVariables("LOGON_USER")="" Then
Else
response.write " ( <FONT SIZE=1 >USER: </FONT > " & Request.ServerVariables("LOGON_USER") & ")"
End If
response.write " </FONT > </TD > </TR >" & VBCRLF
response.write " <TR > <TD ALIGN=""LEFT"" VALIGN=""BOTTOM"" BGCOLOR=" & gblColor & " > <FONT FACE=" & gblFace & " SIZE=4 COLOR=""#FFFFFF"" > <B > " & gblTitle & " </B > </FONT > </TD > </TR >" & VBCRLF
response.write " <TR > <TD ALIGN=""LEFT"" VALIGN=""TOP"" > <FONT FACE=" & gblFace & " SIZE=2 >" & gblPageText & " </FONT > </TD > </TR >" & VBCRLF
response.write " </TABLE >" & VBCRLF
response.write " <" & "!" & "-- begin " & gblScriptName & " --" & " >" & VBCRLF
response.write " <" & "!" & "-- ---------------------------------------------------------- --" & " >" & VBCRLF
End Sub 'StartHTML
'--
'EndHTML
Sub EndHTML
response.write " <" & "!" & "-- ---------------------------------------------------------- --" & " >" & VBCRLF
response.write " <" & "!" & "-- end " & gblScriptName & " --" & " >" & VBCRLF
response.write " <HR > <FONT SIZE=1 FACE=" & gblFace & " > <FONT COLOR=" & gblColor & " SIZE=3 FACE=" & gblFace & " >" & gblSiteName
If Request.ServerVariables("LOGON_USER")="" Then
Else
response.write " ( <FONT SIZE=1 >USER: </FONT > " & Request.ServerVariables("LOGON_USER") & ")"
End If
response.write " </FONT > <BR >" & FormatDateTime(gblNow,1) & " " & FormatDateTime(gblNow,3) & "" & VBCRLF
response.write " <BR >AnyPortal " & gblTitle & " © Copyright " & Year(gblNow) & " by <A TITLE=""www.anyportal.com is a project of the ANDMORE Companies -- Houston, Texas"" HREF=""http://www.anyportal.com"" >www.AnyPortal.com </A > <BR > </FONT >" & VBCRLF
response.write " </BODY > </HTML >" & VBCRLF
response.write VBCRLF
End Sub 'EndHTML
'--
' Authorize
Function Authorize
Dim a,i,pw
If _
(gblPassword="") OR _
(Request.Cookies(gblSiteCode & gblScriptName)=Condensation(SStr(gblPassword))) OR _
Request.ServerVariables("LOGON_USER") < >"" _
Then
Authorize = TRUE
Else
If Request.QueryString("w")="y" AND Request.ServerVariables("LOGON_USER")="" Then
Response.Status = "401 Access Denied"
StartHTML
response.write " <BLOCKQUOTE > <FONT FACE=" & gblFace & " SIZE=5 >"
response.write " <FONT COLOR=""#FF0000"" > <B >Access denied. </B > </FONT > <FONT SIZE=2 >"
response.write " <BR >Sorry, but the username/password you supplied <BR > was not recognized by the <A HREF=""http://" & gblSiteName & """ >" & gblSiteName & " </A > web site " & VBCRLF
response.write " <P >Contact your web site administrator for more information." & VBCRLF
response.write " </FONT > </FONT > </BLOCKQUOTE >" & VBCRLF
EndHTML
Response.End
End If
Authorize = FALSE
pw = Request.Form("password")
a = Condensation(pw)
If pw < >"" OR Request.Form("OK") < >"" Then
If pw = gblPassword Then
' cookie expires when browser is closed...
Response.Cookies(gblSiteCode & gblScriptName) = a
' set a permanent one to never see this page again
If Request.Form("SAVE") = "on" Then Response.Cookies(gblSiteCode & gblScriptName).Expires = gblNow+30
Response.Redirect gblScriptName & "?d="
Else
gblPageText = gblPageText & " <FONT TITLE=""Sorry. That's not the password. Try again."" COLOR=" & gblRed & " > <B >Invalid password. </B > </FONT >"
End If
End If
If Request.ServerVariables("SERVER_SOFTWARE") >="Microsoft-IIS/4.0" Then
StartHTML
response.write " <FORM METHOD=""POST"" ACTION=""" & gblScriptName & """ > <BLOCKQUOTE > <TABLE CELLPADDING=5 >" & VBCRLF
response.write " <TR >" & VBCRLF
response.write " <TD > <FONT TITLE=""The password method uses cookies to secure this site. For the correct password, contact the web site administrator."" FACE=" & gblFace & " SIZE=1 >PASSWORD: </FONT >" & VBCRLF
response.write " <INPUT TYPE=""PASSWORD"" SIZE=17 NAME=""Password"" > </TD >" & VBCRLF
response.write " <TD BGCOLOR=" & gblReverse & " > <FONT FACE=" & gblFace & " SIZE=1 TITLE=""Check this box to save a cookie in the browser of this machine. You won't have to log-in again for the next 30 days."" > SAVE COOKIE? </FONT >" & VBCRLF
response.write " <INPUT TYPE=""CHECKBOX"" NAME=""SAVE"" > </TD >" & VBCRLF
response.write " <TD > <INPUT TYPE=""SUBMIT"" NAME=""OK"" VALUE=""ENTER"" > </TD >" & VBCRLF
response.write " </TR >" & VBCRLF
response.write " <TR > <TD COLSPAN=3 >"
response.write " <FONT FACE=""Wingdings"" SIZE=6 COLOR=""#000000"" >" & chr(255) & " </FONT > <FONT TITLE=""The login method uses your Windows username and password to secure this site."" FACE=" & gblFace & " SIZE=3 > Use Windows <A HREF=""" & gblScriptName & "?w=y"" >login </A >. </FONT > </TR >" & VBCRLF
response.write " </TABLE > </BLOCKQUOTE > </FORM >" & VBCRLF
response.write VBCRLF
Else
gblPageText = "Your web server identified itself as """ & Request.ServerVariables("SERVER_SOFTWARE") & """."
StartHTML
response.write " <BLOCKQUOTE > <FONT FACE=" & gblFace & " SIZE=5 > <B >Sorry. </B > <P >" & VBCRLF
response.write "AnyPortal " & gblTitle & " requires Microsoft NT/2000 Internet Information Server (IIS) 4.0 or greater." & VBCRLF
response.write " </FONT > </BLOCKQUOTE >" & VBCRLF
End If
EndHTML
End If
End Function 'Authorize
'--
' Condensation
Function Condensation(s)
a = 0
For i = 1 to len(s)
a = (ASC(mid(s,i,1))+a*2) Mod 77411
Next 'i
Condensation = Right("00000" & Cstr(a),5) & Right("00000" & Cstr((len(s)*23)+25433),5)
End Function 'Condensation(s)
'--
' CreateImageTag
Function CreateImageTag(fn,altstr,align,border)
Dim f,fso,pn
Dim tstr,alignstr,borderstr
Dim chars,hw,width,height
If border="" Then
borderstr = " BORDER=0"
Else
borderstr = " BORDER=" & Cstr(border)
End If
If align="" Then
alignstr = ""
Else
alignstr = " ALIGN="""
Select Case UCase(left(align,1))
Case "L"
tstr = "LEFT"
Case "R"
tstr = "RIGHT"
Case "C"
tstr = "CENTER"
Case Else
End Select
alignstr = " ALIGN=""" & tstr & """"
End If
Set fso = CreateObject("Scripting.FileSystemObject")
pn = Server.MapPath(fn)
tstr = ""
Set f = fso.OpenTextFile(pn)
Select Case UCase(Right(fn,4))
Case ".GIF",".JPG"
If NOT f.AtEndOfStream Then
If UCase(Right(fn,4))=".GIF" Then 'always works
chars = f.read(10)
width = asc(mid(chars,8,1))*256 + asc(mid(chars,7,1))
height = asc(mid(chars,10,1))*256 + asc(mid(chars,9,1))
hw = " WIDTH=" & width & " HEIGHT=" & height
Else 'usually works
chars = f.read(200)
height = asc(mid(chars,164,1))*256 + asc(mid(chars,165,1))
width = asc(mid(chars,166,1))*256 + asc(mid(chars,167,1))
If (height >600) OR (height <3) OR (WIDTH <3) OR (WIDTH >600) Then
' could be wrong height, width... forget 'em
Else
hw = " WIDTH=" & width & " HEIGHT=" & height
End If
End If
End If
tstr = " <IMG SRC=""" & Replace(Replace(fn,"\","/")," ","%20") & """" & hw & borderstr & alignstr & " ALT=""" & altstr & """ >"
End Select
f.Close
Set f = Nothing
Set fso = Nothing
CreateImageTag = tstr
End Function 'CreateImageTag
'--
' DetailPage
Sub DetailPage
Dim chars,fstr,hw,height,width
Dim IsTextFile,pathname
Dim fsize,fdatecreated,fdatelastmodified
pathname = Lcase(fsDir & fn)
If right(pathname,1)="\" Then pathname = Left(pathname,len(pathname)-1)
If fso.FolderExists(pathname) Then
response.redirect gblScriptName & "?d=" & URLSpace(pathname) & "\"
End If
' create if you gotta
If fso.FileExists(pathname) Then
Else
Select Case UCase(Request.QueryString("T"))
Case "D" 'create document
Set f = fso.CreateTextFile(pathname)
f.Close
Set f= Nothing
Case "F" 'create folder
Set f = fso.CreateFolder(pathname)
pathname = pathname & "\"
response.redirect gblScriptName & "?d=" & URLSpace(pathname)
End Select
End If
StartHTML
response.write " <P > <FONT FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=4 > <B >" & pathname & " </B > <BR >" & VBCRLF
response.write " <A HREF=""" & webbase & fn & """ >" & webbase & fn & " </A > <BR > </FONT >" & VBCRLF
If fso.FileExists(pathname) Then
' fetch Window's file information
Set f = fso.GetFile(pathname)
fsize = f.size
fdatecreated = f.datecreated
fdatelastmodified = f.datelastmodified
response.write " <PRE >" & VBCRLF
response.write " file size: " & FormatNumber(fsize,0) & " characters" & VBCRLF
response.write " file created: <B >" & FormatDateTime(fdatecreated,1) & " </B > " & FormatDateTime(fdatecreated,3) & VBCRLF
response.write "last modified: <B >" & FormatDateTime(fdatelastmodified,1) & " </B > " & FormatDateTime(fdatelastmodified,3) & VBCRLF
response.write " </PRE >" & VBCRLF
Set f = Nothing
End If
response.write " <FORM ACTION=""" & gblScriptName & """ METHOD=""POST"" >" & VBCRLF
response.write " <INPUT TYPE=""HIDDEN"" NAME=""fsDIR"" VALUE=""" & fsDir & """ >" & VBCRLF
IsTextFile = FALSE
Select Case UCase(Right(fn,4))
Case ".GIF",".JPG"
tstr = CreateImageTag(basedir & fn,fn & " (" & FormatNumber(Int(fsize/1024*10+.05)/10,1) & " Kb)","",0)
response.write " <TABLE CELLPADDING=2 BGCOLOR=" & gblReverse & " > <TR > <TD > <FONT SIZE=1 FACE=" & gblFace & " >CUT AND PASTE THIS IMG TAG </FONT > <BR > <TEXTAREA ROWS=4 COLS=60 >"
response.write Server.HTMLEncode(tstr) & " </TEXTAREA > </TD > </TR > </TABLE > <BR >" & tstr & " <BR CLEAR=""ALL"" >" & VBCRLF
Case ".URL"
Set f = fso.OpenTextFile(pathname)
If NOT f.AtEndOfStream Then tstr = f.readall
f.Close
Set f = Nothing
response.write " <FONT COLOR=""#3333FF"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=2 >" & VBCRLF
response.write Replace(Server.HTMLEncode(tstr),VBCRLF,VBCRLF & " <BR >")
response.write " </FONT >" & VBCRLF
Case Else
If IsEditable(fn) Then
'read the file
Set f = fso.OpenTextFile(pathname)
If NOT f.AtEndOfStream Then fstr = f.readall
f.Close
Set f = Nothing
Set fso = Nothing
IsTextFile = TRUE
response.write " <TABLE BGCOLOR=" & gblReverse & " > <TR > <TD >" & VBCRLF
response.write " <FONT TITLE=""Use this text area to view or change the contents of this document. Click [SAVE] to store the updated contents to the web server."" FACE=" & gblFace & "SIZE=1 > <B >DOCUMENT CONTENTS </B > </FONT > <BR >" & VBCRLF
response.write " <TEXTAREA NAME=""FILEDATA"" ROWS=18 COLS=70 WRAP=""OFF"" >" & Server.HTMLEncode(fstr) & " </TEXTAREA >" & VBCRLF
response.write " </TD > </TR > </TABLE >" & VBCRLF
End If
End Select
response.write VBCRLF & " <BR > <BR >" & VBCRLF
If IsTextFile Then
response.write " <INPUT TYPE=""TEXT"" SIZE=48 MAXLENGTH=255 NAME=""PATHNAME"" VALUE=""" & pathname & """ >" & VBCRLF
response.write " <INPUT TYPE=""RESET"" VALUE=""RESET"" > <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""SAVE"" >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""CANCEL"" > <BR >" & VBCRLF
Else
response.write " <INPUT TYPE=""HIDDEN"" NAME=""PATHNAME"" VALUE=""" & pathname & """ >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""BACK"" > <BR >" & VBCRLF
End If
response.write " <HR > <FONT TITLE=""Check OK and click [DELETE] to delete this document from the web server. (Cannot be undone.)"" FACE=" & gblFace & "SIZE=1 > <B >OK TO DELETE """ & UCase(fn) & """? </B > </FONT >" & VBCRLF
response.write " <INPUT TYPE=""CHECKBOX"" NAME=""DELETEOK"" >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""DELETE"" >" & VBCRLF
response.write " </FORM >" & VBCRLF
EndHTML
End Sub 'DetailPage
'--
' DisplayCode
Sub DisplayCode
Dim fn,fso,f
Dim code,tstr
Dim a,arr,i
fn = Request.QueryString("c")
response.write " <HTML > <HEAD > <TITLE >" & fn & " </TITLE > </HEAD > <BODY >" & VBCRLF
response.write " <STYLE >" & VBCRLF
response.write " <!" & "--" & VBCRLF
response.write "SPAN{color:Navy;background-color:Yellow}" & VBCRLF
response.write "--" & " >" & VBCRLF
response.write " </STYLE >" & VBCRLF
If Instr(fn,fsroot)=1 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(fn, 1, 0, 0)
If f.AtEndOfStream Then
code = ""
Else
code = f.ReadAll
End If
response.write " <TABLE WIDTH=""100%"" BGCOLOR=" & gblColor & " > <TR > <TD > <FONT COLOR=""#FFFFFF"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=5 > <B >" & VBCRLF
response.write " " & fn & " </B > </FONT > </TD > </TR > </TABLE >" & VBCRLF
' quickly format code for readability...
' could be smarter, but it sure is simple!
tstr = Server.HTMLEncode(code)
tstr = Replace(tstr,chr(9)," ")
If len(fn) >3 Then
Select Case lcase(Mid(fn,InstrRev(fn,".")+1))
Case "asa","asp","aspx","htm","html","shtm","shtml"
tstr = Replace(tstr," "," ")
tstr = Replace(tstr,"<%"," <SPAN ><" & "% </SPAN > <FONT COLOR=""#000000"" >")
tstr = Replace(tstr,"%>"," <SPAN >%" & " </FONT >> </SPAN >")
tstr = Replace(tstr,"<!--"," <I > <FONT COLOR=""#CC0033"" ><!--")
tstr = Replace(tstr,"-->","--> </I > </FONT >")
response.write " <FONT COLOR=""#0000FF"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=2 >" & VBCRLF
Case Else
response.write " <FONT COLOR=""#000000"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=2 >" & VBCRLF
End Select
End If
response.write " <!" & "-- file listing --" & " >" & VBCRLF & VBCRLF
arr = Split(Replace(tstr,chr(13),""),chr(10)) 'handle unix/linux files, too
For i = 0 to UBound(arr)
' add line numbers and output
response.write " <BR > <FONT COLOR=""#008000"" >" & Right("000" & i+1,4) & ": </FONT > "
tstr = arr(i)
If left(Replace(Replace(tstr," ","")," " ,""),1)="'" Then
response.write " <FONT COLOR=""#CC0033"" > <I >" & tstr & " </I > </FONT >" & VBCRLF
Else
response.write tstr & VBCRLF
End If
Next 'i
response.write VBCRLF & " <!" & "-- end of code listing --" & " >" & VBCRLF
response.write " </FONT >" & VBCRLF
Else
response.write " <P > <FONT COLOR=""#CC0033"" SIZE=3 >Cannot access " & fn & " </FONT >" & VBCRLF
End If
response.write " <HR > </BODY > </HTML >"
End Sub 'DisplayCode
'--
' DisplayFileName
Sub DisplayFileName(dirfile,fhandle)
Dim newgif,linktarget,execlink
Dim fsize
execlink = ""
response.write " <TR >" & VBCRLF
If dirFile="DIR" Then
linktarget = " <A HREF=""" & gblScriptName & "?d=" & URLSpace(fhandle) & "\"" TITLE=""Click here to move down a level and list the documents in this folder."" >"
tstr = " <FONT FACE=" & gblFace & " SIZE=2 >" & linktarget & LCase(fhandle.name) & " </A > </FONT >"
response.write " <TD VALIGN=""TOP"" ALIGN=""RIGHT"" >" & MockIcon("fldr") & " </TD >" & VBCRLF
response.write " <TD COLSPAN=3 VALIGN=""TOP"" BGCOLOR=" & gblReverse & " >" & Tstr & " </TD >" & VBCRLF
Else
newgif = ""
If fhandle.datelastmodified+14 >gblNow Then newgif = MockIcon("newicon")
b = ""
If len(fhandle.name) >4 Then b = Ucase(Right(fhandle.name,4))
If Left(b,1) = "." Then b = Right(b,3)
Select Case b
Case "VBS","BAT"
execlink = " <A TARGET=""_blank"" HREF=""" & gblScriptName & "?x=" & URLSpace(fsDir & fhandle.name) & """ TITLE=""Click here to run this document."" >" & LCase(fhandle.name) & " </A >"
End Select
Select Case b
Case "URL"
tstr = ShortCutURL
Case Else
If IsEditable(fhandle.name) Then newgif = newgif & " <A TARGET=""_blank"" HREF=""" & gblScriptName & "?c=" & URLSpace(fsDir & fhandle.name) & """ TITLE=""Click here to list the contents of this document."" STYLE=""{text-decoration:none}"" >" & MockIcon("view") & " </A >"
tstr = webbase & replace(fhandle.name," ","%20")
End Select
If fhandle.size <10240 Then
If fhandle.size=0 Then
fsize = "0"
Else
fsize = FormatNumber(fhandle.size,0,0,-2)
End If
Else
fsize = FormatNumber((fhandle.size+1023)/1024,0,0,-2) & "K"
End If
If execlink="" Then
tstr = " <FONT FACE=" & gblFace & " SIZE=2 > <A HREF=""" & tstr & """ TITLE=""Click here to link to this document."" >" & LCase(fhandle.name) & " </A > </FONT >" & newgif
Else
tstr = " <FONT FACE=" & gblFace & " SIZE=2 >" & execlink & " </FONT >" & newgif
End If
response.write " <TD VALIGN=""TOP"" ALIGN=""RIGHT"" > <A HREF=""" & gblScriptName & "?f=" & URLSpace(fhandle.name) & "&d=" & URLSpace(fsDir) & """ TITLE=""Click here to view more details about this document."" STYLE=""{text-decoration:none}"" >" & MockIcon(b) & " </A > </TD >" & VBCRLF
response.write " <TD VALIGN=""TOP"" BGCOLOR=" & gblReverse & " >" & Tstr & " </TD >" & VBCRLF
response.write " <TD VALIGN=""TOP"" BGCOLOR=" & gblReverse & " > <FONT FACE=" & gblFace & " SIZE=1 >" & FormatDateTime(fhandle.datelastmodified,0) & " </FONT > </TD >" & VBCRLF
response.write " <TD VALIGN=""TOP"" BGCOLOR=" & gblReverse & " > <FONT FACE=" & gblFace & " SIZE=1 >" & fsize & " bytes </FONT > </TD >" & VBCRLF
End If
response.write " </TR >" & VBCRLF
End Sub 'DisplayFileName
'--
' IsEditable
Function IsEditable(pn)
Dim rt
If len(pn) >3 Then
rt = TRUE
Select Case lcase(Mid(pn,InstrRev(pn,".")+1))
' Wanna make a file editable and listable?
' Just add the extension to any of these lists (all lower case!)
Case "asa","asp","aspx","css","htm","html","js","shtm","shtml"
Case "cfm","jsp","php3","php4"
Case "bat","inc","ini","log","txt","url","vbs"
Case "c","cpp","h","src","tag"
Case "loc","out","sql"
Case Else
rt = FALSE
End Select
Else
rt = FALSE
End If
IsEditable = rt
End Function 'IsEditable
'--
' MockIcon (icon emulator)
Function MockIcon(txt)
Dim tstr,d
' Sorry, mac/linux users.
tstr = " <FONT FACE=""WingDings"" SIZE=4 COLOR=" & gblRed & " >"
Select Case Lcase(txt)
Case "bmp","gif","jpg","tif","jpeg","tiff"
d = 176
Case "doc"
d = 50
Case "exe","bat","bas","c","src","vbs"
d = 255
Case "file"
d = 51
Case "fldr"
d = 48
Case "htm","html","asa","asp","cfm","php3"
d = 182
Case "pdf"
d = 38
Case "xls"
d = 252
Case "zip","arc","sit"
d = 59
Case "newicon"
tstr = " <FONT TITLE=""This document has been modified sometime during the last 14 days."" FACE=""WingDings"" SIZE=4 COLOR=" & gblRed & " >"
d = 171
Case "view"
d = 52
Case Else
If IsEditable("." & txt) Then
d = 52
Else
d = 51
End If
End Select
tstr = tstr & Chr(d) & " </FONT >"
MockIcon = tstr
End Function 'mockicon
'--
' Navigate
Sub Navigate
Dim emptyDir
emptyDir = TRUE
response.write " <TABLE BORDER=0 CELLPADDING=2 CELLSPACING=3 WIDTH=""100%"" >"
' get the directory of file names
If toplevel Then
parent = ""
Else
parent = fso.GetParentFolderName(fsDir) & "\"
response.write " <TR > <TD VALIGN=""TOP"" ALIGN=""RIGHT"" > <FONT FACE=""WingDings"" SIZE=4 COLOR=" & gblRed & " >" & chr(199) & " </FONT > </TD >" & VBCRLF
response.write " <TD COLSPAN=3 > <FONT FACE=" & gblFace & " SIZE=1 > <B > <A TITLE=""Click here to move up a level to the parent folder."" HREF=""" & gblScriptName & "?d=" & URLSpace(parent) & """ >" & UCASE(fso.GetParentfolderName(fsDir) & "\") & " </A > </B > </FONT > </TD > </TR >" & VBCRLF
End If
Set f = fso.GetFolder(fsDir)
Set FileList = f.subFolders
a = 0
For Each fn in FileList
emptyDir = FALSE
If a = 0 Then
a = 1
response.write " <TR > <TD VALIGN=""TOP"" > </TD >" & VBCRLF
response.write " <TD COLSPAN=3 > <HR > <FONT FACE=" & gblFace & " SIZE=4 > <B >Additional Folders </B > </FONT > </TD >" & VBCRLF
response.write " </TR >" & VBCRLF
response.write " <TR > <TD VALIGN=""TOP"" > </TD >" & VBCRLF
response.write " <TD COLSPAN=3 VALIGN=""BOTTOM"" > <FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1 > <B >FOLDER NAME </B > </FONT > </TD >" & VBCRLF
response.write " </TR >" & VBCRLF
End If
DisplayFileName "DIR",fn
Next 'fn
response.write " <TR > <TD VALIGN=""TOP"" > </TD >" & VBCRLF
response.write " <TD COLSPAN=3 > <HR > <FONT FACE=" & gblFace & " SIZE=4 > <B >" & fsDir & " </B > </FONT > </TD >" & VBCRLF
response.write " </TR >" & VBCRLF
response.write " <TR > <TD VALIGN=""TOP"" > </TD >" & VBCRLF
response.write " <TD VALIGN=""BOTTOM"" > <FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1 > <B >DOCUMENT NAME </B > </FONT > </TD >" & VBCRLF
response.write " <TD VALIGN=""BOTTOM"" > <FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1 > <B >LAST UPDATE </B > </FONT > </TD >" & VBCRLF
response.write " <TD VALIGN=""BOTTOM"" > <FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1 > <B >FILE SIZE </B > </FONT > </TD >" & VBCRLF
response.write " </TR >" & VBCRLF
response.write "" & VBCRLF
Set filelist = f.Files
For Each fn in filelist
emptyDir = FALSE
DisplayFileName "FILE",fn
Next 'fn
If emptyDir Then
response.write " <FORM METHOD=""POST"" ACTION=""" & gblScriptName & """ >" & VBCRLF
response.write " <TR > <TD > </TD > <TD COLSPAN=3 VALIGN=""BOTTOM"" BGCOLOR=" & gblReverse & " >" & VBCRLF
response.write " <INPUT TYPE=""HIDDEN"" NAME=""PARENT"" VALUE=""" & parent & """ >" & VBCRLF
response.write " <INPUT TYPE=""HIDDEN"" NAME=""PATHNAME"" VALUE=""" & fsDir & """ >" & VBCRLF
response.write " <FONT FACE=" & gblFace & " SIZE=1 > OK TO DELETE THIS EMPTY FOLDER? </FONT >" & VBCRLF
response.write " <INPUT TYPE=""CHECKBOX"" NAME=""OK"" > " & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""DELETE"" >" & VBCRLF
response.write " </TD > </TR > </FORM >" & VBCRLF
End If
response.write " <TR > <TD > </TD > <TD COLSPAN=3 > <HR > </TD > </TR >" & VBCRLF
response.write " <FORM METHOD=""GET"" ACTION=""" & gblScriptName & """ >" & VBCRLF
response.write " <TR > <TD > </TD > <TD COLSPAN=3 VALIGN=""BOTTOM"" BGCOLOR=" & gblReverse & " >" & VBCRLF
response.write " <FONT FACE=" & gblFace & " SIZE=1 > CREATE NEW </FONT >" & VBCRLF
response.write " <INPUT TYPE=""RADIO"" NAME=""T"" VALUE=""D"" CHECKED > <FONT FACE=" & gblFace & " SIZE=1 >DOCUMENT </FONT >" & VBCRLF
response.write " <FONT FACE=" & gblFace & " SIZE=1 > -OR- </FONT >" & VBCRLF
response.write " <INPUT TYPE=""RADIO"" NAME=""T"" VALUE=""F"" > <FONT FACE=" & gblFace & " SIZE=1 >FOLDER: </FONT > " & VBCRLF
response.write " <FONT FACE=" & gblFace & " SIZE=1 > NAME </FONT > " & VBCRLF
response.write " <INPUT TYPE=""TEXT"" NAME=""F"" SIZE=14 > " & VBCRLF
response.write " <INPUT TYPE=""HIDDEN"" NAME=""D"" VALUE=""" & fsDir & """ >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" VALUE=""CREATE"" >" & VBCRLF
If gblUpload < >"" Then response.write " <NOBR > <FONT FACE=" & gblFace & " SIZE=1 > OR <A HREF=""" & gblScriptName & "?u=Y&d=" & URLSpace(fsDir) & """ >UPLOAD </A > USING " & gblUpLoad & " </FONT > </NOBR >" & VBCRLF
response.write " </TD > </TR > </FORM >" & VBCRLF
response.write " </TABLE >" & VBCRLF
End Sub 'Navigate
'--
' RunVBSCode
Sub RunVBSCode
Dim fn,fso,f
Dim code,tstr
Dim a,arr,i
Dim wshShell,outFile,batFile
Dim runWait
If Request.QueryString("t")="" Then
Server.ScriptTimeout = 2*60 '2 minutes
Else
Server.ScriptTimeout = Request.QueryString("t")*60 'convert to minutes
End If
fn = Request.QueryString("x")
response.write " <HTML > <HEAD > <TITLE >" & fn & " </TITLE > </HEAD > <BODY >" & VBCRLF
response.write " <TABLE WIDTH=""100%"" BGCOLOR=" & gblColor & " > <TR > <TD > <FONT COLOR=""#FFFFFF"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=5 > <B >" & VBCRLF
response.write " " & fn & " </B > </FONT > </TD > </TR > </TABLE >" & VBCRLF & VBCRLF
response.write " <FONT COLOR=""#000000"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=2 > <P >" & VBCRLF
If Instr(fn,fsroot)=1 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set wshShell = Server.CreateObject("Wscript.Shell")
If LCase(Mid(fn,InstrRev(fn,".") + 1)) = "bat" Then
batFile = fn
runWait = FALSE
Else
batFile = replace(fsroot & fso.GetTempName,".tmp",".bat")
Set f = fso.CreateTextFile(batFile)
outFile = fsroot & fso.GetTempName
tstr = "cscript " & fn & " > " & outFile
f.Write tstr & VBCRLF
f.Close
runWait = TRUE
End If
Response.Write " <!" & "--" & VBCRLF
Response.Write tstr & VBCRLF
Response.Write "--" & " >" & VBCRLF
a = wshShell.Run(batFile,1,runWait)
If runWait Then
If fso.FileExists(outFile) Then
Set f = fso.OpenTextFile(outFile, 1, 0, 0)
If f.AtEndOfStream Then
Else
code = f.ReadAll
Response.Write replace(replace(code," "," "),VBCRLF," <BR >" & VBCRLF) & VBCRLF
End If
f.Close
Set f = fso.GetFile(outFile)
f.delete
Set f = nothing
Else
Response.Write "Completed with code=" & a & "." & VBCRLF & "No output file." & VBCRLF
End If
If fso.FileExists(batFile) Then
Set f = fso.GetFile(batFile)
f.delete
Set f = nothing
End If
Else
Response.Write "Batch job started" & VBCRLF & FormatDateTime(gblNow,1) & " " & FormatDateTime(gblNow,3) & VBCRLF
End If
Else
Response.Write "Can't run " & fn & VBCRLF
End If
response.write " </FONT >" & VBCRLF
EndHTML
End Sub 'RunVBSCode
'--
' ShortCutURL
Function ShortCutURL
Dim f,fstr,tstr
tstr = ""
Set f = fso.OpenTextFile(fn)
Do While NOT f.AtEndOfStream
tstr = f.readline
If len(tstr) <7 Then
Else
If left(lcase(tstr),4)="url=" Then
fstr = tstr
End If
End If
Loop
f.Close
Set f= Nothing
If fstr = "" Then
ShortCutURL = fn
Else
ShortCutURL = Replace(mid(fstr,5,255)," ","%20")
End If
End Function 'ShortCutURL
'--
' SStr (force null to "")
Function SStr(v)
Dim rt
If IsNull(v) Then
rt = ""
Else
rt = Trim(Cstr(v))
End If
SStr = rt
End Function 'sstr
'--
' UploadPage
Sub UploadPage
StartHTML
response.write " <P > <TABLE BORDER=0 CELLPADDING=5 > <TR > <TD WIDTH=5 > </TD > <TD BGCOLOR=" & gblReverse & " VALIGN=""""TOP"""" >" & VBCRLF
response.write " <FORM ENCTYPE=""multipart/form-data"" METHOD=""POST"" ACTION=""" & gblScriptName & "?u=D&d=" & URLSpace(fsDir) & """ >" & VBCRLF
response.write " <FONT SIZE=1 FACE=" & gblFace & " >NAME OF DESTINATION FOLDER ON WEB SITE </FONT > <BR >" & VBCRLF
response.write " <FONT SIZE=4 FACE=" & gblFace & " > <B >" & fsDir & " </B > </FONT > <P >" & VBCRLF
response.write " <FONT SIZE=1 FACE=" & gblFace & " >PATHNAME OF LOCAL DOCUMENT <BR >(SEND THIS FILE TO THE WEB SERVER) </FONT > <BR > <INPUT SIZE=30 TYPE=""FILE"" NAME=""F1"" > <P >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" VALUE=""UPLOAD"" > " & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""CANCEL"" >" & VBCRLF
response.write " <P > <FONT SIZE=2 FACE=" & gblFace & " >If the <B >[BROWSE...] </B > button is not displayed," & VBCRLF
response.write " <BR >you must upgrade your <A HREF=""http://www.netscape.com"" >Netscape </A >" & VBCRLF
response.write "or <A HREF=""http://www.microsoft.com"" >Microsoft </A > browser." & VBCRLF
response.write " </FORM > </TD >" & VBCRLF
response.write " <TD VALIGN=""TOP"" > <FONT SIZE=2 FACE=" & gblFace & " >" & VBCRLF
response.write " <P >Your browser: <BR >HTTP_USER_AGENT: " & Request.ServerVariables("HTTP_USER_AGENT") & "" & VBCRLF
Select Case gblUpLoad
Case "SA-FILEUP"
response.write " <P >Upload also requires that <A TARGET=""_blank"" HREF=""http://www.softartisans.com"" >the SA-FileUp object </A > is registered on your web server. <BR >"
Case "ASPSimpleUpload"
response.write " <P >Upload also requires that <A TARGET=""_blank"" HREF=""http://www.asphelp.com/ASPSimpleUpload/Default.Asp"" >the ASPSimpleUpload object </A > is registered on your web server. <BR >"
Case "Script"
response.write " <P > <B >Upload will use Script only. </B > <BR >You may find that <A TARGET=""_blank"" HREF=""http://www.asphelp.com/ASPSimpleUpload/Default.Asp"" >the ASPSimpleUpload object </A > (free) or <A TARGET=""_blank"" HREF=""http://www.softartisans.com"" >the SA-FileUp object </A > (payment required) will perform better. <BR >"
Case Else
End Select
response.write " </FONT >" & VBCRLF
response.write " <FORM METHOD=""POST"" ACTION=""" & gblScriptName & """ >" & VBCRLF
response.write " <INPUT TYPE=""HIDDEN"" NAME=""fsDir"" VALUE=""" & fsDir & """ > <BR >" & VBCRLF
If gblUpload="Script" Then
Else
response.write " <FONT SIZE=2 FACE=" & gblFace & " >DON'T HAVE THE " & gblUpload & " OBJECT INSTALLED? <BR >SORRY! CLICK HERE... </FONT > <BR >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""CANCEL"" >" & VBCRLF
End If
response.write " </FORM >" & VBCRLF
response.write " </TD > </TR > </TABLE > <P >" & VBCRLF
EndHTML
End Sub 'UploadPage
'--
' URLspace
Function URLSpace(s)
URLSpace = replace(replace(s,"+","%2B")," ","+")
End Function 'URLSpace
'----
'MAIN
'----
Dim filelist,fn,upl
Dim TextObject,fhandle,lsplit
Dim fsDir,baseDir,webbase
Dim fsRoot,webRoot
Dim pathname,parent,toplevel
gblTitle = "Site Manager"
If NOT Authorize Then
' function will output HTML for password
Else
' initialization
Set fso = CreateObject("Scripting.FileSystemObject")
' dynamically find out where the documents and web pages are located
fsDir = replace(LCase(replace(Request.QueryString("d"),"..",".")),"/.","/")
If fsDir="" Then fsDir = Request.Form("fsDir")
fsRoot = LCase(Replace(Server.MapPath(gblScriptName),"\" & gblScriptName,"") & "\")
If Instr(fsdir,fsroot) < >1 Then fsDir = fsRoot
If Lcase(fsDir)=Lcase(fsRoot) Then toplevel = TRUE
basedir = Replace(Mid(fsDir,len(fsRoot),250),"\","/")
webRoot = "http://" & Request.ServerVariables("SERVER_NAME") & Replace(Request.ServerVariables("SCRIPT_NAME"),"/" & gblScriptName,"")
webbase = replace(webroot & basedir," ","%20")
' process a GET/POST request
If Request.QueryString("u")="D" Then
Action = "UPLOAD"
Else
Action = Request.Form("POSTACTION")
pathname = Request.Form("PATHNAME")
End If
Select Case UCase(Action)
Case "UPLOAD"
Select Case gblUpload
Case "SA-FILEUP"
Set upl = Server.CreateObject("SoftArtisans.FileUp")
tstr = Mid(upl.UserFilename, InstrRev(upl.UserFilename, "\") + 1)
If tstr = "" Then
Else
upl.SaveAs fsdir & tstr
End If
Case "ASPSimpleUpload"
Set upl = Server.CreateObject("ASPSimpleUpload.Upload")
If Len(upl.Form("f1")) > 0 Then
tstr = fsdir & upl.ExtractFileName(upl.Form("f1"))
tstr = Mid(tstr,len(fsroot))
tstr = upl.SaveToWeb("f1", tstr)
End If
Case "Script"
' sorry. not implemented.
Case Else
End Select
Case "SAVE"
If IsEditable(pathname) Then
If Instr(pathname,fsroot) = 1 Then
Set f = fso.CreateTextFile(pathname)
f.write Request.Form("FILEDATA")
f.close
End If
End If
Case "DELETE" 'either document or folder
If Request.Form("OK") = "on" Then
parent = Request.Form("Parent")
If Instr(pathname,fsroot) = 1 Then
fso.DeleteFolder Left(pathname,Len(pathname)-1),TRUE
response.redirect gblScriptName & "?d=" & URLSpace(parent)
End If
End If
If Request.Form("DELETEOK") = "on" Then
If Instr(pathname,fsroot) = 1 Then
If fso.FileExists(Request.Form("PathName")) Then
Set f = fso.GetFile(Request.Form("PathName"))
f.delete
End If
End If
End If
End Select
If Action="" Then
Else
tstr = gblScriptName & "?d="
If NOT toplevel Then tstr = tstr & URLSpace(fsDir)
response.redirect tstr
End If
' check for mode... navigate, code display, upload, or detail?
fn = LCase(Request.QueryString("f"))
If fn="" Then
If Request.QueryString("u")="Y" Then
gblTitle = gblTitle & " (Upload Page)"
gblPageText = "Use this page to upload a single document to this web site."
UploadPage
Else
If Request.QueryString("c")="" Then
If Request.QueryString("x")="" Then
gblPageText = "Use this page to add, delete or revise documents on this web site."
StartHTML
Navigate
EndHTML
Else
RunVBSCode
End If
Else
DisplayCode
End If
End If
Else
gblTitle = gblTitle & " (Detail Page)"
gblPageText = "Use this page to view, modify or delete a single document on this web site."
DetailPage
End If
End If
% >
</SCRIPT >
<%
' ** Copyright 1999-2001 by John Martin d/b/a www.ANYPORTAL.com **
' ** All Rights Reserved. **
' ** **
' ** This software is freeware and is not in the public domain. **
' ** You are hereby granted the right to freely distribute this **
' ** software as long as this copyright notice remains in place. **
' ** **
' ** Comments or suggestions? email: andmore@alief.com **
' ** **
' ** Date Remarks **
' ** --------- ----------------------------------------------- **
' ** 25 MAY 99 original **
' ** 26 MAY 99 allow the script to run from a subdirectory **
' ** 27 MAY 99 increase security use of cookie **
' ** 03 JUN 99 fix UNIX html file record endings **
' ** 07 JUN 99 fix spaces in file name problem **
' ** 10 JUL 99 fix subdirectory problem with createimagetag **
' ** 10 JUL 99 add create document/folder logic **
' ** 11 JUL 99 fix spaces in file name, again **
' ** 11 JUL 99 .cfm & .php3 now edit like .asp/.html, etc. **
' ** 25 JUL 99 add interface to SA-FILEUP to upload files **
' ** 25 AUG 99 recode authorization routine, allow no password **
' ** 31 AUG 99 some cosmetic; integrate with email community **
' ** 01 SEP 99 add link on detail page **
' ** 05 SEP 99 add missing EndHTML on detail page **
' ** 24 OCT 00 plug /../ hole **
' ** 14 NOV 00 add Windows login security method **
' ** 14 NOV 00 convert in-line HTML to response.write **
' ** 14 NOV 00 improve shortcut parsing, clean-up link styles **
' ** 10 APR 01 make more file types editable/listable **
' ** 11 APR 01 add code to execute BAT and VBS files on server **
' ** 11 APR 01 allow either SA-FILEUP or ASPSimpleUpload **
' ** 07 JUN 01 add cut/paste textarea for img tags **
' ** 07 JUN 01 fix typo ! for ' **
' ** 12 JUN 01 fix missing IsEditable on detail page **
Option Explicit
' universal variables (these undo the option explicit)
Dim action
Dim a,b,c,i,item,j
Dim f,fso
Dim arr,tstr
' security
Dim gblPassword
gblPassword = NULL 'your password here
'^^^^------ NULL forces mandatory Windows login.
Dim gblUpload 'Pick one: how to do upload?
' gblUpload = "Script" 'not working. do not use.
gblUpload = "ASPSimpleUpload"
gblUpload = "SA-FILEUP"
' configuration
Dim gblSiteName,gblSiteCode
gblSiteName = Request.ServerVariables("SERVER_NAME")
gblSiteCode = ""
Dim gblNow 'server may not be local time
gblNow = Now
Dim gblFace,gblColor 'needs three quotes
gblFace = """Arial, Helvetica, sans-serif"""
gblColor = """#000066"""
Dim gblRed,gblReverse
gblRed = """#FF0000"""
gblReverse = """#E0E0E0"""
' global variables
Dim gblTitle,gblPageText
gblTitle = " * * * TITLE NOT SET * * * "
gblPageText = " "
' global constants
Dim gblScriptName,gblRoot
gblScriptName = Request.ServerVariables("Script_Name")
gblScriptName = Mid(gblScriptName,InstrRev(gblScriptName,"/") + 1)
gblRoot = Replace(Request.ServerVariables("Script_Name"),"/" & gblScriptName,"")
'--
'StartHTML
Sub StartHTML
response.write " <HTML > <HEAD > <TITLE >" & gblSiteName & " " & gblTitle & " </TITLE >" & VBCRLF
response.write " <META NAME=""description"" CONTENT=""AnyPortal"" " & gblTitle & ". " & gblSiteName & " >" & VBCRLF
response.write " <META NAME=""keywords"" CONTENT=""anyportal, " & Lcase(gblTitle) & ", anyportal " & Lcase(gblTitle) & ", one file footprint, www.anyportal.com, andmore, the ANDMORE Companies, Houston, Texas, active server pages, ASP, asp, 100% ASP, 100% asp"" >" & VBCRLF
response.write " </HEAD >" & VBCRLF
response.write " <BODY BGCOLOR=""#FFFFFF"" > <TABLE WIDTH=""100%"" >" & VBCRLF
response.write " <TR > <TD ALIGN=""RIGHT"" VALIGN=""BOTTOM"" > <FONT COLOR=" & gblColor & " SIZE=3 FACE=" & gblFace & " >" & gblSiteName
If Request.ServerVariables("LOGON_USER")="" Then
Else
response.write " ( <FONT SIZE=1 >USER: </FONT > " & Request.ServerVariables("LOGON_USER") & ")"
End If
response.write " </FONT > </TD > </TR >" & VBCRLF
response.write " <TR > <TD ALIGN=""LEFT"" VALIGN=""BOTTOM"" BGCOLOR=" & gblColor & " > <FONT FACE=" & gblFace & " SIZE=4 COLOR=""#FFFFFF"" > <B > " & gblTitle & " </B > </FONT > </TD > </TR >" & VBCRLF
response.write " <TR > <TD ALIGN=""LEFT"" VALIGN=""TOP"" > <FONT FACE=" & gblFace & " SIZE=2 >" & gblPageText & " </FONT > </TD > </TR >" & VBCRLF
response.write " </TABLE >" & VBCRLF
response.write " <" & "!" & "-- begin " & gblScriptName & " --" & " >" & VBCRLF
response.write " <" & "!" & "-- ---------------------------------------------------------- --" & " >" & VBCRLF
End Sub 'StartHTML
'--
'EndHTML
Sub EndHTML
response.write " <" & "!" & "-- ---------------------------------------------------------- --" & " >" & VBCRLF
response.write " <" & "!" & "-- end " & gblScriptName & " --" & " >" & VBCRLF
response.write " <HR > <FONT SIZE=1 FACE=" & gblFace & " > <FONT COLOR=" & gblColor & " SIZE=3 FACE=" & gblFace & " >" & gblSiteName
If Request.ServerVariables("LOGON_USER")="" Then
Else
response.write " ( <FONT SIZE=1 >USER: </FONT > " & Request.ServerVariables("LOGON_USER") & ")"
End If
response.write " </FONT > <BR >" & FormatDateTime(gblNow,1) & " " & FormatDateTime(gblNow,3) & "" & VBCRLF
response.write " <BR >AnyPortal " & gblTitle & " © Copyright " & Year(gblNow) & " by <A TITLE=""www.anyportal.com is a project of the ANDMORE Companies -- Houston, Texas"" HREF=""http://www.anyportal.com"" >www.AnyPortal.com </A > <BR > </FONT >" & VBCRLF
response.write " </BODY > </HTML >" & VBCRLF
response.write VBCRLF
End Sub 'EndHTML
'--
' Authorize
Function Authorize
Dim a,i,pw
If _
(gblPassword="") OR _
(Request.Cookies(gblSiteCode & gblScriptName)=Condensation(SStr(gblPassword))) OR _
Request.ServerVariables("LOGON_USER") < >"" _
Then
Authorize = TRUE
Else
If Request.QueryString("w")="y" AND Request.ServerVariables("LOGON_USER")="" Then
Response.Status = "401 Access Denied"
StartHTML
response.write " <BLOCKQUOTE > <FONT FACE=" & gblFace & " SIZE=5 >"
response.write " <FONT COLOR=""#FF0000"" > <B >Access denied. </B > </FONT > <FONT SIZE=2 >"
response.write " <BR >Sorry, but the username/password you supplied <BR > was not recognized by the <A HREF=""http://" & gblSiteName & """ >" & gblSiteName & " </A > web site " & VBCRLF
response.write " <P >Contact your web site administrator for more information." & VBCRLF
response.write " </FONT > </FONT > </BLOCKQUOTE >" & VBCRLF
EndHTML
Response.End
End If
Authorize = FALSE
pw = Request.Form("password")
a = Condensation(pw)
If pw < >"" OR Request.Form("OK") < >"" Then
If pw = gblPassword Then
' cookie expires when browser is closed...
Response.Cookies(gblSiteCode & gblScriptName) = a
' set a permanent one to never see this page again
If Request.Form("SAVE") = "on" Then Response.Cookies(gblSiteCode & gblScriptName).Expires = gblNow+30
Response.Redirect gblScriptName & "?d="
Else
gblPageText = gblPageText & " <FONT TITLE=""Sorry. That's not the password. Try again."" COLOR=" & gblRed & " > <B >Invalid password. </B > </FONT >"
End If
End If
If Request.ServerVariables("SERVER_SOFTWARE") >="Microsoft-IIS/4.0" Then
StartHTML
response.write " <FORM METHOD=""POST"" ACTION=""" & gblScriptName & """ > <BLOCKQUOTE > <TABLE CELLPADDING=5 >" & VBCRLF
response.write " <TR >" & VBCRLF
response.write " <TD > <FONT TITLE=""The password method uses cookies to secure this site. For the correct password, contact the web site administrator."" FACE=" & gblFace & " SIZE=1 >PASSWORD: </FONT >" & VBCRLF
response.write " <INPUT TYPE=""PASSWORD"" SIZE=17 NAME=""Password"" > </TD >" & VBCRLF
response.write " <TD BGCOLOR=" & gblReverse & " > <FONT FACE=" & gblFace & " SIZE=1 TITLE=""Check this box to save a cookie in the browser of this machine. You won't have to log-in again for the next 30 days."" > SAVE COOKIE? </FONT >" & VBCRLF
response.write " <INPUT TYPE=""CHECKBOX"" NAME=""SAVE"" > </TD >" & VBCRLF
response.write " <TD > <INPUT TYPE=""SUBMIT"" NAME=""OK"" VALUE=""ENTER"" > </TD >" & VBCRLF
response.write " </TR >" & VBCRLF
response.write " <TR > <TD COLSPAN=3 >"
response.write " <FONT FACE=""Wingdings"" SIZE=6 COLOR=""#000000"" >" & chr(255) & " </FONT > <FONT TITLE=""The login method uses your Windows username and password to secure this site."" FACE=" & gblFace & " SIZE=3 > Use Windows <A HREF=""" & gblScriptName & "?w=y"" >login </A >. </FONT > </TR >" & VBCRLF
response.write " </TABLE > </BLOCKQUOTE > </FORM >" & VBCRLF
response.write VBCRLF
Else
gblPageText = "Your web server identified itself as """ & Request.ServerVariables("SERVER_SOFTWARE") & """."
StartHTML
response.write " <BLOCKQUOTE > <FONT FACE=" & gblFace & " SIZE=5 > <B >Sorry. </B > <P >" & VBCRLF
response.write "AnyPortal " & gblTitle & " requires Microsoft NT/2000 Internet Information Server (IIS) 4.0 or greater." & VBCRLF
response.write " </FONT > </BLOCKQUOTE >" & VBCRLF
End If
EndHTML
End If
End Function 'Authorize
'--
' Condensation
Function Condensation(s)
a = 0
For i = 1 to len(s)
a = (ASC(mid(s,i,1))+a*2) Mod 77411
Next 'i
Condensation = Right("00000" & Cstr(a),5) & Right("00000" & Cstr((len(s)*23)+25433),5)
End Function 'Condensation(s)
'--
' CreateImageTag
Function CreateImageTag(fn,altstr,align,border)
Dim f,fso,pn
Dim tstr,alignstr,borderstr
Dim chars,hw,width,height
If border="" Then
borderstr = " BORDER=0"
Else
borderstr = " BORDER=" & Cstr(border)
End If
If align="" Then
alignstr = ""
Else
alignstr = " ALIGN="""
Select Case UCase(left(align,1))
Case "L"
tstr = "LEFT"
Case "R"
tstr = "RIGHT"
Case "C"
tstr = "CENTER"
Case Else
End Select
alignstr = " ALIGN=""" & tstr & """"
End If
Set fso = CreateObject("Scripting.FileSystemObject")
pn = Server.MapPath(fn)
tstr = ""
Set f = fso.OpenTextFile(pn)
Select Case UCase(Right(fn,4))
Case ".GIF",".JPG"
If NOT f.AtEndOfStream Then
If UCase(Right(fn,4))=".GIF" Then 'always works
chars = f.read(10)
width = asc(mid(chars,8,1))*256 + asc(mid(chars,7,1))
height = asc(mid(chars,10,1))*256 + asc(mid(chars,9,1))
hw = " WIDTH=" & width & " HEIGHT=" & height
Else 'usually works
chars = f.read(200)
height = asc(mid(chars,164,1))*256 + asc(mid(chars,165,1))
width = asc(mid(chars,166,1))*256 + asc(mid(chars,167,1))
If (height >600) OR (height <3) OR (WIDTH <3) OR (WIDTH >600) Then
' could be wrong height, width... forget 'em
Else
hw = " WIDTH=" & width & " HEIGHT=" & height
End If
End If
End If
tstr = " <IMG SRC=""" & Replace(Replace(fn,"\","/")," ","%20") & """" & hw & borderstr & alignstr & " ALT=""" & altstr & """ >"
End Select
f.Close
Set f = Nothing
Set fso = Nothing
CreateImageTag = tstr
End Function 'CreateImageTag
'--
' DetailPage
Sub DetailPage
Dim chars,fstr,hw,height,width
Dim IsTextFile,pathname
Dim fsize,fdatecreated,fdatelastmodified
pathname = Lcase(fsDir & fn)
If right(pathname,1)="\" Then pathname = Left(pathname,len(pathname)-1)
If fso.FolderExists(pathname) Then
response.redirect gblScriptName & "?d=" & URLSpace(pathname) & "\"
End If
' create if you gotta
If fso.FileExists(pathname) Then
Else
Select Case UCase(Request.QueryString("T"))
Case "D" 'create document
Set f = fso.CreateTextFile(pathname)
f.Close
Set f= Nothing
Case "F" 'create folder
Set f = fso.CreateFolder(pathname)
pathname = pathname & "\"
response.redirect gblScriptName & "?d=" & URLSpace(pathname)
End Select
End If
StartHTML
response.write " <P > <FONT FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=4 > <B >" & pathname & " </B > <BR >" & VBCRLF
response.write " <A HREF=""" & webbase & fn & """ >" & webbase & fn & " </A > <BR > </FONT >" & VBCRLF
If fso.FileExists(pathname) Then
' fetch Window's file information
Set f = fso.GetFile(pathname)
fsize = f.size
fdatecreated = f.datecreated
fdatelastmodified = f.datelastmodified
response.write " <PRE >" & VBCRLF
response.write " file size: " & FormatNumber(fsize,0) & " characters" & VBCRLF
response.write " file created: <B >" & FormatDateTime(fdatecreated,1) & " </B > " & FormatDateTime(fdatecreated,3) & VBCRLF
response.write "last modified: <B >" & FormatDateTime(fdatelastmodified,1) & " </B > " & FormatDateTime(fdatelastmodified,3) & VBCRLF
response.write " </PRE >" & VBCRLF
Set f = Nothing
End If
response.write " <FORM ACTION=""" & gblScriptName & """ METHOD=""POST"" >" & VBCRLF
response.write " <INPUT TYPE=""HIDDEN"" NAME=""fsDIR"" VALUE=""" & fsDir & """ >" & VBCRLF
IsTextFile = FALSE
Select Case UCase(Right(fn,4))
Case ".GIF",".JPG"
tstr = CreateImageTag(basedir & fn,fn & " (" & FormatNumber(Int(fsize/1024*10+.05)/10,1) & " Kb)","",0)
response.write " <TABLE CELLPADDING=2 BGCOLOR=" & gblReverse & " > <TR > <TD > <FONT SIZE=1 FACE=" & gblFace & " >CUT AND PASTE THIS IMG TAG </FONT > <BR > <TEXTAREA ROWS=4 COLS=60 >"
response.write Server.HTMLEncode(tstr) & " </TEXTAREA > </TD > </TR > </TABLE > <BR >" & tstr & " <BR CLEAR=""ALL"" >" & VBCRLF
Case ".URL"
Set f = fso.OpenTextFile(pathname)
If NOT f.AtEndOfStream Then tstr = f.readall
f.Close
Set f = Nothing
response.write " <FONT COLOR=""#3333FF"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=2 >" & VBCRLF
response.write Replace(Server.HTMLEncode(tstr),VBCRLF,VBCRLF & " <BR >")
response.write " </FONT >" & VBCRLF
Case Else
If IsEditable(fn) Then
'read the file
Set f = fso.OpenTextFile(pathname)
If NOT f.AtEndOfStream Then fstr = f.readall
f.Close
Set f = Nothing
Set fso = Nothing
IsTextFile = TRUE
response.write " <TABLE BGCOLOR=" & gblReverse & " > <TR > <TD >" & VBCRLF
response.write " <FONT TITLE=""Use this text area to view or change the contents of this document. Click [SAVE] to store the updated contents to the web server."" FACE=" & gblFace & "SIZE=1 > <B >DOCUMENT CONTENTS </B > </FONT > <BR >" & VBCRLF
response.write " <TEXTAREA NAME=""FILEDATA"" ROWS=18 COLS=70 WRAP=""OFF"" >" & Server.HTMLEncode(fstr) & " </TEXTAREA >" & VBCRLF
response.write " </TD > </TR > </TABLE >" & VBCRLF
End If
End Select
response.write VBCRLF & " <BR > <BR >" & VBCRLF
If IsTextFile Then
response.write " <INPUT TYPE=""TEXT"" SIZE=48 MAXLENGTH=255 NAME=""PATHNAME"" VALUE=""" & pathname & """ >" & VBCRLF
response.write " <INPUT TYPE=""RESET"" VALUE=""RESET"" > <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""SAVE"" >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""CANCEL"" > <BR >" & VBCRLF
Else
response.write " <INPUT TYPE=""HIDDEN"" NAME=""PATHNAME"" VALUE=""" & pathname & """ >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""BACK"" > <BR >" & VBCRLF
End If
response.write " <HR > <FONT TITLE=""Check OK and click [DELETE] to delete this document from the web server. (Cannot be undone.)"" FACE=" & gblFace & "SIZE=1 > <B >OK TO DELETE """ & UCase(fn) & """? </B > </FONT >" & VBCRLF
response.write " <INPUT TYPE=""CHECKBOX"" NAME=""DELETEOK"" >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""DELETE"" >" & VBCRLF
response.write " </FORM >" & VBCRLF
EndHTML
End Sub 'DetailPage
'--
' DisplayCode
Sub DisplayCode
Dim fn,fso,f
Dim code,tstr
Dim a,arr,i
fn = Request.QueryString("c")
response.write " <HTML > <HEAD > <TITLE >" & fn & " </TITLE > </HEAD > <BODY >" & VBCRLF
response.write " <STYLE >" & VBCRLF
response.write " <!" & "--" & VBCRLF
response.write "SPAN{color:Navy;background-color:Yellow}" & VBCRLF
response.write "--" & " >" & VBCRLF
response.write " </STYLE >" & VBCRLF
If Instr(fn,fsroot)=1 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(fn, 1, 0, 0)
If f.AtEndOfStream Then
code = ""
Else
code = f.ReadAll
End If
response.write " <TABLE WIDTH=""100%"" BGCOLOR=" & gblColor & " > <TR > <TD > <FONT COLOR=""#FFFFFF"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=5 > <B >" & VBCRLF
response.write " " & fn & " </B > </FONT > </TD > </TR > </TABLE >" & VBCRLF
' quickly format code for readability...
' could be smarter, but it sure is simple!
tstr = Server.HTMLEncode(code)
tstr = Replace(tstr,chr(9)," ")
If len(fn) >3 Then
Select Case lcase(Mid(fn,InstrRev(fn,".")+1))
Case "asa","asp","aspx","htm","html","shtm","shtml"
tstr = Replace(tstr," "," ")
tstr = Replace(tstr,"<%"," <SPAN ><" & "% </SPAN > <FONT COLOR=""#000000"" >")
tstr = Replace(tstr,"%>"," <SPAN >%" & " </FONT >> </SPAN >")
tstr = Replace(tstr,"<!--"," <I > <FONT COLOR=""#CC0033"" ><!--")
tstr = Replace(tstr,"-->","--> </I > </FONT >")
response.write " <FONT COLOR=""#0000FF"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=2 >" & VBCRLF
Case Else
response.write " <FONT COLOR=""#000000"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=2 >" & VBCRLF
End Select
End If
response.write " <!" & "-- file listing --" & " >" & VBCRLF & VBCRLF
arr = Split(Replace(tstr,chr(13),""),chr(10)) 'handle unix/linux files, too
For i = 0 to UBound(arr)
' add line numbers and output
response.write " <BR > <FONT COLOR=""#008000"" >" & Right("000" & i+1,4) & ": </FONT > "
tstr = arr(i)
If left(Replace(Replace(tstr," ","")," " ,""),1)="'" Then
response.write " <FONT COLOR=""#CC0033"" > <I >" & tstr & " </I > </FONT >" & VBCRLF
Else
response.write tstr & VBCRLF
End If
Next 'i
response.write VBCRLF & " <!" & "-- end of code listing --" & " >" & VBCRLF
response.write " </FONT >" & VBCRLF
Else
response.write " <P > <FONT COLOR=""#CC0033"" SIZE=3 >Cannot access " & fn & " </FONT >" & VBCRLF
End If
response.write " <HR > </BODY > </HTML >"
End Sub 'DisplayCode
'--
' DisplayFileName
Sub DisplayFileName(dirfile,fhandle)
Dim newgif,linktarget,execlink
Dim fsize
execlink = ""
response.write " <TR >" & VBCRLF
If dirFile="DIR" Then
linktarget = " <A HREF=""" & gblScriptName & "?d=" & URLSpace(fhandle) & "\"" TITLE=""Click here to move down a level and list the documents in this folder."" >"
tstr = " <FONT FACE=" & gblFace & " SIZE=2 >" & linktarget & LCase(fhandle.name) & " </A > </FONT >"
response.write " <TD VALIGN=""TOP"" ALIGN=""RIGHT"" >" & MockIcon("fldr") & " </TD >" & VBCRLF
response.write " <TD COLSPAN=3 VALIGN=""TOP"" BGCOLOR=" & gblReverse & " >" & Tstr & " </TD >" & VBCRLF
Else
newgif = ""
If fhandle.datelastmodified+14 >gblNow Then newgif = MockIcon("newicon")
b = ""
If len(fhandle.name) >4 Then b = Ucase(Right(fhandle.name,4))
If Left(b,1) = "." Then b = Right(b,3)
Select Case b
Case "VBS","BAT"
execlink = " <A TARGET=""_blank"" HREF=""" & gblScriptName & "?x=" & URLSpace(fsDir & fhandle.name) & """ TITLE=""Click here to run this document."" >" & LCase(fhandle.name) & " </A >"
End Select
Select Case b
Case "URL"
tstr = ShortCutURL
Case Else
If IsEditable(fhandle.name) Then newgif = newgif & " <A TARGET=""_blank"" HREF=""" & gblScriptName & "?c=" & URLSpace(fsDir & fhandle.name) & """ TITLE=""Click here to list the contents of this document."" STYLE=""{text-decoration:none}"" >" & MockIcon("view") & " </A >"
tstr = webbase & replace(fhandle.name," ","%20")
End Select
If fhandle.size <10240 Then
If fhandle.size=0 Then
fsize = "0"
Else
fsize = FormatNumber(fhandle.size,0,0,-2)
End If
Else
fsize = FormatNumber((fhandle.size+1023)/1024,0,0,-2) & "K"
End If
If execlink="" Then
tstr = " <FONT FACE=" & gblFace & " SIZE=2 > <A HREF=""" & tstr & """ TITLE=""Click here to link to this document."" >" & LCase(fhandle.name) & " </A > </FONT >" & newgif
Else
tstr = " <FONT FACE=" & gblFace & " SIZE=2 >" & execlink & " </FONT >" & newgif
End If
response.write " <TD VALIGN=""TOP"" ALIGN=""RIGHT"" > <A HREF=""" & gblScriptName & "?f=" & URLSpace(fhandle.name) & "&d=" & URLSpace(fsDir) & """ TITLE=""Click here to view more details about this document."" STYLE=""{text-decoration:none}"" >" & MockIcon(b) & " </A > </TD >" & VBCRLF
response.write " <TD VALIGN=""TOP"" BGCOLOR=" & gblReverse & " >" & Tstr & " </TD >" & VBCRLF
response.write " <TD VALIGN=""TOP"" BGCOLOR=" & gblReverse & " > <FONT FACE=" & gblFace & " SIZE=1 >" & FormatDateTime(fhandle.datelastmodified,0) & " </FONT > </TD >" & VBCRLF
response.write " <TD VALIGN=""TOP"" BGCOLOR=" & gblReverse & " > <FONT FACE=" & gblFace & " SIZE=1 >" & fsize & " bytes </FONT > </TD >" & VBCRLF
End If
response.write " </TR >" & VBCRLF
End Sub 'DisplayFileName
'--
' IsEditable
Function IsEditable(pn)
Dim rt
If len(pn) >3 Then
rt = TRUE
Select Case lcase(Mid(pn,InstrRev(pn,".")+1))
' Wanna make a file editable and listable?
' Just add the extension to any of these lists (all lower case!)
Case "asa","asp","aspx","css","htm","html","js","shtm","shtml"
Case "cfm","jsp","php3","php4"
Case "bat","inc","ini","log","txt","url","vbs"
Case "c","cpp","h","src","tag"
Case "loc","out","sql"
Case Else
rt = FALSE
End Select
Else
rt = FALSE
End If
IsEditable = rt
End Function 'IsEditable
'--
' MockIcon (icon emulator)
Function MockIcon(txt)
Dim tstr,d
' Sorry, mac/linux users.
tstr = " <FONT FACE=""WingDings"" SIZE=4 COLOR=" & gblRed & " >"
Select Case Lcase(txt)
Case "bmp","gif","jpg","tif","jpeg","tiff"
d = 176
Case "doc"
d = 50
Case "exe","bat","bas","c","src","vbs"
d = 255
Case "file"
d = 51
Case "fldr"
d = 48
Case "htm","html","asa","asp","cfm","php3"
d = 182
Case "pdf"
d = 38
Case "xls"
d = 252
Case "zip","arc","sit"
d = 59
Case "newicon"
tstr = " <FONT TITLE=""This document has been modified sometime during the last 14 days."" FACE=""WingDings"" SIZE=4 COLOR=" & gblRed & " >"
d = 171
Case "view"
d = 52
Case Else
If IsEditable("." & txt) Then
d = 52
Else
d = 51
End If
End Select
tstr = tstr & Chr(d) & " </FONT >"
MockIcon = tstr
End Function 'mockicon
'--
' Navigate
Sub Navigate
Dim emptyDir
emptyDir = TRUE
response.write " <TABLE BORDER=0 CELLPADDING=2 CELLSPACING=3 WIDTH=""100%"" >"
' get the directory of file names
If toplevel Then
parent = ""
Else
parent = fso.GetParentFolderName(fsDir) & "\"
response.write " <TR > <TD VALIGN=""TOP"" ALIGN=""RIGHT"" > <FONT FACE=""WingDings"" SIZE=4 COLOR=" & gblRed & " >" & chr(199) & " </FONT > </TD >" & VBCRLF
response.write " <TD COLSPAN=3 > <FONT FACE=" & gblFace & " SIZE=1 > <B > <A TITLE=""Click here to move up a level to the parent folder."" HREF=""" & gblScriptName & "?d=" & URLSpace(parent) & """ >" & UCASE(fso.GetParentfolderName(fsDir) & "\") & " </A > </B > </FONT > </TD > </TR >" & VBCRLF
End If
Set f = fso.GetFolder(fsDir)
Set FileList = f.subFolders
a = 0
For Each fn in FileList
emptyDir = FALSE
If a = 0 Then
a = 1
response.write " <TR > <TD VALIGN=""TOP"" > </TD >" & VBCRLF
response.write " <TD COLSPAN=3 > <HR > <FONT FACE=" & gblFace & " SIZE=4 > <B >Additional Folders </B > </FONT > </TD >" & VBCRLF
response.write " </TR >" & VBCRLF
response.write " <TR > <TD VALIGN=""TOP"" > </TD >" & VBCRLF
response.write " <TD COLSPAN=3 VALIGN=""BOTTOM"" > <FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1 > <B >FOLDER NAME </B > </FONT > </TD >" & VBCRLF
response.write " </TR >" & VBCRLF
End If
DisplayFileName "DIR",fn
Next 'fn
response.write " <TR > <TD VALIGN=""TOP"" > </TD >" & VBCRLF
response.write " <TD COLSPAN=3 > <HR > <FONT FACE=" & gblFace & " SIZE=4 > <B >" & fsDir & " </B > </FONT > </TD >" & VBCRLF
response.write " </TR >" & VBCRLF
response.write " <TR > <TD VALIGN=""TOP"" > </TD >" & VBCRLF
response.write " <TD VALIGN=""BOTTOM"" > <FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1 > <B >DOCUMENT NAME </B > </FONT > </TD >" & VBCRLF
response.write " <TD VALIGN=""BOTTOM"" > <FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1 > <B >LAST UPDATE </B > </FONT > </TD >" & VBCRLF
response.write " <TD VALIGN=""BOTTOM"" > <FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1 > <B >FILE SIZE </B > </FONT > </TD >" & VBCRLF
response.write " </TR >" & VBCRLF
response.write "" & VBCRLF
Set filelist = f.Files
For Each fn in filelist
emptyDir = FALSE
DisplayFileName "FILE",fn
Next 'fn
If emptyDir Then
response.write " <FORM METHOD=""POST"" ACTION=""" & gblScriptName & """ >" & VBCRLF
response.write " <TR > <TD > </TD > <TD COLSPAN=3 VALIGN=""BOTTOM"" BGCOLOR=" & gblReverse & " >" & VBCRLF
response.write " <INPUT TYPE=""HIDDEN"" NAME=""PARENT"" VALUE=""" & parent & """ >" & VBCRLF
response.write " <INPUT TYPE=""HIDDEN"" NAME=""PATHNAME"" VALUE=""" & fsDir & """ >" & VBCRLF
response.write " <FONT FACE=" & gblFace & " SIZE=1 > OK TO DELETE THIS EMPTY FOLDER? </FONT >" & VBCRLF
response.write " <INPUT TYPE=""CHECKBOX"" NAME=""OK"" > " & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""DELETE"" >" & VBCRLF
response.write " </TD > </TR > </FORM >" & VBCRLF
End If
response.write " <TR > <TD > </TD > <TD COLSPAN=3 > <HR > </TD > </TR >" & VBCRLF
response.write " <FORM METHOD=""GET"" ACTION=""" & gblScriptName & """ >" & VBCRLF
response.write " <TR > <TD > </TD > <TD COLSPAN=3 VALIGN=""BOTTOM"" BGCOLOR=" & gblReverse & " >" & VBCRLF
response.write " <FONT FACE=" & gblFace & " SIZE=1 > CREATE NEW </FONT >" & VBCRLF
response.write " <INPUT TYPE=""RADIO"" NAME=""T"" VALUE=""D"" CHECKED > <FONT FACE=" & gblFace & " SIZE=1 >DOCUMENT </FONT >" & VBCRLF
response.write " <FONT FACE=" & gblFace & " SIZE=1 > -OR- </FONT >" & VBCRLF
response.write " <INPUT TYPE=""RADIO"" NAME=""T"" VALUE=""F"" > <FONT FACE=" & gblFace & " SIZE=1 >FOLDER: </FONT > " & VBCRLF
response.write " <FONT FACE=" & gblFace & " SIZE=1 > NAME </FONT > " & VBCRLF
response.write " <INPUT TYPE=""TEXT"" NAME=""F"" SIZE=14 > " & VBCRLF
response.write " <INPUT TYPE=""HIDDEN"" NAME=""D"" VALUE=""" & fsDir & """ >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" VALUE=""CREATE"" >" & VBCRLF
If gblUpload < >"" Then response.write " <NOBR > <FONT FACE=" & gblFace & " SIZE=1 > OR <A HREF=""" & gblScriptName & "?u=Y&d=" & URLSpace(fsDir) & """ >UPLOAD </A > USING " & gblUpLoad & " </FONT > </NOBR >" & VBCRLF
response.write " </TD > </TR > </FORM >" & VBCRLF
response.write " </TABLE >" & VBCRLF
End Sub 'Navigate
'--
' RunVBSCode
Sub RunVBSCode
Dim fn,fso,f
Dim code,tstr
Dim a,arr,i
Dim wshShell,outFile,batFile
Dim runWait
If Request.QueryString("t")="" Then
Server.ScriptTimeout = 2*60 '2 minutes
Else
Server.ScriptTimeout = Request.QueryString("t")*60 'convert to minutes
End If
fn = Request.QueryString("x")
response.write " <HTML > <HEAD > <TITLE >" & fn & " </TITLE > </HEAD > <BODY >" & VBCRLF
response.write " <TABLE WIDTH=""100%"" BGCOLOR=" & gblColor & " > <TR > <TD > <FONT COLOR=""#FFFFFF"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=5 > <B >" & VBCRLF
response.write " " & fn & " </B > </FONT > </TD > </TR > </TABLE >" & VBCRLF & VBCRLF
response.write " <FONT COLOR=""#000000"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=2 > <P >" & VBCRLF
If Instr(fn,fsroot)=1 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set wshShell = Server.CreateObject("Wscript.Shell")
If LCase(Mid(fn,InstrRev(fn,".") + 1)) = "bat" Then
batFile = fn
runWait = FALSE
Else
batFile = replace(fsroot & fso.GetTempName,".tmp",".bat")
Set f = fso.CreateTextFile(batFile)
outFile = fsroot & fso.GetTempName
tstr = "cscript " & fn & " > " & outFile
f.Write tstr & VBCRLF
f.Close
runWait = TRUE
End If
Response.Write " <!" & "--" & VBCRLF
Response.Write tstr & VBCRLF
Response.Write "--" & " >" & VBCRLF
a = wshShell.Run(batFile,1,runWait)
If runWait Then
If fso.FileExists(outFile) Then
Set f = fso.OpenTextFile(outFile, 1, 0, 0)
If f.AtEndOfStream Then
Else
code = f.ReadAll
Response.Write replace(replace(code," "," "),VBCRLF," <BR >" & VBCRLF) & VBCRLF
End If
f.Close
Set f = fso.GetFile(outFile)
f.delete
Set f = nothing
Else
Response.Write "Completed with code=" & a & "." & VBCRLF & "No output file." & VBCRLF
End If
If fso.FileExists(batFile) Then
Set f = fso.GetFile(batFile)
f.delete
Set f = nothing
End If
Else
Response.Write "Batch job started" & VBCRLF & FormatDateTime(gblNow,1) & " " & FormatDateTime(gblNow,3) & VBCRLF
End If
Else
Response.Write "Can't run " & fn & VBCRLF
End If
response.write " </FONT >" & VBCRLF
EndHTML
End Sub 'RunVBSCode
'--
' ShortCutURL
Function ShortCutURL
Dim f,fstr,tstr
tstr = ""
Set f = fso.OpenTextFile(fn)
Do While NOT f.AtEndOfStream
tstr = f.readline
If len(tstr) <7 Then
Else
If left(lcase(tstr),4)="url=" Then
fstr = tstr
End If
End If
Loop
f.Close
Set f= Nothing
If fstr = "" Then
ShortCutURL = fn
Else
ShortCutURL = Replace(mid(fstr,5,255)," ","%20")
End If
End Function 'ShortCutURL
'--
' SStr (force null to "")
Function SStr(v)
Dim rt
If IsNull(v) Then
rt = ""
Else
rt = Trim(Cstr(v))
End If
SStr = rt
End Function 'sstr
'--
' UploadPage
Sub UploadPage
StartHTML
response.write " <P > <TABLE BORDER=0 CELLPADDING=5 > <TR > <TD WIDTH=5 > </TD > <TD BGCOLOR=" & gblReverse & " VALIGN=""""TOP"""" >" & VBCRLF
response.write " <FORM ENCTYPE=""multipart/form-data"" METHOD=""POST"" ACTION=""" & gblScriptName & "?u=D&d=" & URLSpace(fsDir) & """ >" & VBCRLF
response.write " <FONT SIZE=1 FACE=" & gblFace & " >NAME OF DESTINATION FOLDER ON WEB SITE </FONT > <BR >" & VBCRLF
response.write " <FONT SIZE=4 FACE=" & gblFace & " > <B >" & fsDir & " </B > </FONT > <P >" & VBCRLF
response.write " <FONT SIZE=1 FACE=" & gblFace & " >PATHNAME OF LOCAL DOCUMENT <BR >(SEND THIS FILE TO THE WEB SERVER) </FONT > <BR > <INPUT SIZE=30 TYPE=""FILE"" NAME=""F1"" > <P >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" VALUE=""UPLOAD"" > " & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""CANCEL"" >" & VBCRLF
response.write " <P > <FONT SIZE=2 FACE=" & gblFace & " >If the <B >[BROWSE...] </B > button is not displayed," & VBCRLF
response.write " <BR >you must upgrade your <A HREF=""http://www.netscape.com"" >Netscape </A >" & VBCRLF
response.write "or <A HREF=""http://www.microsoft.com"" >Microsoft </A > browser." & VBCRLF
response.write " </FORM > </TD >" & VBCRLF
response.write " <TD VALIGN=""TOP"" > <FONT SIZE=2 FACE=" & gblFace & " >" & VBCRLF
response.write " <P >Your browser: <BR >HTTP_USER_AGENT: " & Request.ServerVariables("HTTP_USER_AGENT") & "" & VBCRLF
Select Case gblUpLoad
Case "SA-FILEUP"
response.write " <P >Upload also requires that <A TARGET=""_blank"" HREF=""http://www.softartisans.com"" >the SA-FileUp object </A > is registered on your web server. <BR >"
Case "ASPSimpleUpload"
response.write " <P >Upload also requires that <A TARGET=""_blank"" HREF=""http://www.asphelp.com/ASPSimpleUpload/Default.Asp"" >the ASPSimpleUpload object </A > is registered on your web server. <BR >"
Case "Script"
response.write " <P > <B >Upload will use Script only. </B > <BR >You may find that <A TARGET=""_blank"" HREF=""http://www.asphelp.com/ASPSimpleUpload/Default.Asp"" >the ASPSimpleUpload object </A > (free) or <A TARGET=""_blank"" HREF=""http://www.softartisans.com"" >the SA-FileUp object </A > (payment required) will perform better. <BR >"
Case Else
End Select
response.write " </FONT >" & VBCRLF
response.write " <FORM METHOD=""POST"" ACTION=""" & gblScriptName & """ >" & VBCRLF
response.write " <INPUT TYPE=""HIDDEN"" NAME=""fsDir"" VALUE=""" & fsDir & """ > <BR >" & VBCRLF
If gblUpload="Script" Then
Else
response.write " <FONT SIZE=2 FACE=" & gblFace & " >DON'T HAVE THE " & gblUpload & " OBJECT INSTALLED? <BR >SORRY! CLICK HERE... </FONT > <BR >" & VBCRLF
response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""CANCEL"" >" & VBCRLF
End If
response.write " </FORM >" & VBCRLF
response.write " </TD > </TR > </TABLE > <P >" & VBCRLF
EndHTML
End Sub 'UploadPage
'--
' URLspace
Function URLSpace(s)
URLSpace = replace(replace(s,"+","%2B")," ","+")
End Function 'URLSpace
'----
'MAIN
'----
Dim filelist,fn,upl
Dim TextObject,fhandle,lsplit
Dim fsDir,baseDir,webbase
Dim fsRoot,webRoot
Dim pathname,parent,toplevel
gblTitle = "Site Manager"
If NOT Authorize Then
' function will output HTML for password
Else
' initialization
Set fso = CreateObject("Scripting.FileSystemObject")
' dynamically find out where the documents and web pages are located
fsDir = replace(LCase(replace(Request.QueryString("d"),"..",".")),"/.","/")
If fsDir="" Then fsDir = Request.Form("fsDir")
fsRoot = LCase(Replace(Server.MapPath(gblScriptName),"\" & gblScriptName,"") & "\")
If Instr(fsdir,fsroot) < >1 Then fsDir = fsRoot
If Lcase(fsDir)=Lcase(fsRoot) Then toplevel = TRUE
basedir = Replace(Mid(fsDir,len(fsRoot),250),"\","/")
webRoot = "http://" & Request.ServerVariables("SERVER_NAME") & Replace(Request.ServerVariables("SCRIPT_NAME"),"/" & gblScriptName,"")
webbase = replace(webroot & basedir," ","%20")
' process a GET/POST request
If Request.QueryString("u")="D" Then
Action = "UPLOAD"
Else
Action = Request.Form("POSTACTION")
pathname = Request.Form("PATHNAME")
End If
Select Case UCase(Action)
Case "UPLOAD"
Select Case gblUpload
Case "SA-FILEUP"
Set upl = Server.CreateObject("SoftArtisans.FileUp")
tstr = Mid(upl.UserFilename, InstrRev(upl.UserFilename, "\") + 1)
If tstr = "" Then
Else
upl.SaveAs fsdir & tstr
End If
Case "ASPSimpleUpload"
Set upl = Server.CreateObject("ASPSimpleUpload.Upload")
If Len(upl.Form("f1")) > 0 Then
tstr = fsdir & upl.ExtractFileName(upl.Form("f1"))
tstr = Mid(tstr,len(fsroot))
tstr = upl.SaveToWeb("f1", tstr)
End If
Case "Script"
' sorry. not implemented.
Case Else
End Select
Case "SAVE"
If IsEditable(pathname) Then
If Instr(pathname,fsroot) = 1 Then
Set f = fso.CreateTextFile(pathname)
f.write Request.Form("FILEDATA")
f.close
End If
End If
Case "DELETE" 'either document or folder
If Request.Form("OK") = "on" Then
parent = Request.Form("Parent")
If Instr(pathname,fsroot) = 1 Then
fso.DeleteFolder Left(pathname,Len(pathname)-1),TRUE
response.redirect gblScriptName & "?d=" & URLSpace(parent)
End If
End If
If Request.Form("DELETEOK") = "on" Then
If Instr(pathname,fsroot) = 1 Then
If fso.FileExists(Request.Form("PathName")) Then
Set f = fso.GetFile(Request.Form("PathName"))
f.delete
End If
End If
End If
End Select
If Action="" Then
Else
tstr = gblScriptName & "?d="
If NOT toplevel Then tstr = tstr & URLSpace(fsDir)
response.redirect tstr
End If
' check for mode... navigate, code display, upload, or detail?
fn = LCase(Request.QueryString("f"))
If fn="" Then
If Request.QueryString("u")="Y" Then
gblTitle = gblTitle & " (Upload Page)"
gblPageText = "Use this page to upload a single document to this web site."
UploadPage
Else
If Request.QueryString("c")="" Then
If Request.QueryString("x")="" Then
gblPageText = "Use this page to add, delete or revise documents on this web site."
StartHTML
Navigate
EndHTML
Else
RunVBSCode
End If
Else
DisplayCode
End If
End If
Else
gblTitle = gblTitle & " (Detail Page)"
gblPageText = "Use this page to view, modify or delete a single document on this web site."
DetailPage
End If
End If
% >
Views 4,693
Downloads 1,523
CodeID
DB ID
