f:\inetpub\wwwreg2\includes\filelist.asp
0001:
0002:
<%
'Option Explicit
0003:
%
>
0004:
0005:
<%
0006:
0007:
'universal variables (these undo the option explicit)
0008:
0009:
Dim action
0010:
Dim a,b,c,i,item,j
0011:
Dim f,fso
0012:
Dim arr,tstr
0013:
0014:
'security
0015:
0016:
Dim gblPassword
0017:
gblPassword = Null 'your password here
0018:
'^------ Null forces mandatory Windows login.
0019:
0020:
'configuration
0021:
0022:
Dim gblSiteName,gblSiteCode
0023:
gblSiteName = Request.ServerVariables("SERVER_NAME")
0024:
gblSiteCode = ""
0025:
0026:
Dim gblNow 'server may not be local time
0027:
gblNow = Now
0028:
0029:
Dim gblFace,gblColor 'needs three quotes
0030:
gblFace = """Arial, Helvetica, sans-serif"""
0031:
gblColor = """#000066"""
0032:
0033:
Dim gblRed
0034:
gblRed = """#FF0000"""
0035:
0036:
Dim gblReverse
0037:
gblReverse = """#E0E0E0"""
0038:
0039:
'global variables
0040:
0041:
Dim gblTitle,gblPageText
0042:
gblTitle = " * * * TITLE NOT SET * * * "
0043:
gblPageText = " "
0044:
0045:
'global constants
0046:
0047:
Dim gblScriptName
0048:
gblScriptName = Request.ServerVariables("Script_Name")
0049:
gblScriptName = Mid(gblScriptName,InstrRev(gblScriptName,"/") + 1)
0050:
0051:
Dim gblRoot
0052:
gblRoot = Replace(Request.ServerVariables("Script_Name"),"/" & gblScriptName,"")
0053:
0054:
'-----------
0055:
'subprograms
0056:
'-----------
0057:
0058:
0059:
'--
0060:
'StartHTML
0061:
Sub StartHTML
0062:
' response.write "<HTML><HEAD><TITLE>" & gblTitle & "</TITLE>" & VBCRLF
0063:
' response.write "</HEAD>" & VBCRLF
0064:
' response.write "<BODY BGCOLOR=""#FFFFFF""><TABLE WIDTH=""100%"">" & VBCRLF
0065:
'response.write "<TR><TD ALIGN=""RIGHT"" VALIGN=""BOTTOM""><FONT COLOR=" & gblColor & " SIZE=3 FACE=" & gblFace & ">" & gblSiteName
0066:
' If Request.ServerVariables("LOGON_USER")="" Then
0067:
' Else
0068:
'response.write " (<FONT SIZE=1>USER:</FONT> " & Request.ServerVariables("LOGON_USER") & ")"
0069:
' End If
0070:
' response.write "</FONT></TD></TR>" & VBCRLF
0071:
' response.write "<TR><TD ALIGN=""LEFT"" VALIGN=""BOTTOM"" BGCOLOR=" & gblColor & "><FONT FACE=" & gblFace & " SIZE=4 COLOR=""#FFFFFF""><B> " & gblTitle & "</B></FONT></TD></TR>" & VBCRLF
0072:
' response.write "<TR><TD ALIGN=""LEFT"" VALIGN=""TOP""><FONT FACE=" & gblFace & " SIZE=2>" & gblPageText & "</FONT></TD></TR>" & VBCRLF
0073:
' response.write "</TABLE>" & VBCRLF
0074:
response.write "<" & "!" & "-- begin " & gblScriptName & " --" & ">" & VBCRLF
0075:
response.write "<" & "!" & "-- ---------------------------------------------------------- --" & ">" & VBCRLF
0076:
End Sub 'StartHTML
0077:
0078:
'--
0079:
'EndHTML
0080:
Sub EndHTML
0081:
response.write "<" & "!" & "-- ---------------------------------------------------------- --" & ">" & VBCRLF
0082:
response.write "<" & "!" & "-- end " & gblScriptName & " --" & ">" & VBCRLF
0083:
Response.Write "</table>"
0084:
' response.write "<HR><FONT SIZE=1 FACE=" & gblFace & "><FONT COLOR=" & gblColor & " SIZE=3 FACE=" & gblFace & ">" & gblSiteName
0085:
' If Request.ServerVariables("LOGON_USER")="" Then
0086:
' Else
0087:
' response.write " (<FONT SIZE=1>USER:</FONT> " & Request.ServerVariables("LOGON_USER") & ")"
0088:
' End If
0089:
' response.write "</FONT><BR>" & FormatDateTime(gblNow,1) & " " & FormatDateTime(gblNow,3) & "" & VBCRLF
0090:
' 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
0091:
' response.write "</BODY></HTML>" & VBCRLF
0092:
' response.write VBCRLF
0093:
End Sub 'EndHTML
0094:
0095:
'--
0096:
' Authorize
0097:
Function Authorize
0098:
Dim a,i,pw
0099:
If _
0100:
(gblPassword="") OR _
0101:
(Request.Cookies(gblSiteCode & gblScriptName)=Condensation(SStr(gblPassword))) OR _
0102:
Request.ServerVariables("LOGON_USER")<>"" _
0103:
Then
0104:
Authorize = TRUE
0105:
Else
0106:
If Request.QueryString("w")="y" AND Request.ServerVariables("LOGON_USER")="" Then
0107:
Response.Status = "401 Access Denied"
0108:
StartHTML
0109:
response.write "<BLOCKQUOTE><FONT FACE=" & gblFace & " SIZE=5>"
0110:
response.write "<FONT COLOR=""##FF0000""><B>Access denied.</B></FONT><FONT SIZE=2>"
0111:
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
0112:
response.write "<P>Contact your web site administrator for more information." & VBCRLF
0113:
response.write "</FONT></FONT></BLOCKQUOTE>" & VBCRLF
0114:
EndHTML
0115:
Response.End
0116:
End If
0117:
Authorize = FALSE
0118:
pw = Request.Form("password")
0119:
a = Condensation(pw)
0120:
If pw<>"" OR Request.Form("OK")<>"" Then
0121:
If pw = gblPassword Then
0122:
'cookie expires when browser is closed...
0123:
Response.Cookies(gblSiteCode & gblScriptName) = a
0124:
'set a permanent one to never see this page again
0125:
If Request.Form("SAVE") = "on" Then Response.Cookies(gblSiteCode & gblScriptName).Expires = gblNow+30
0126:
Response.Redirect gblScriptName & "?d="
0127:
Else
0128:
gblPageText = gblPageText & "<FONT TITLE=""Sorry. That's not the password. Try again."" COLOR=" & gblRed & "><B>Invalid password.</B></FONT>"
0129:
End If
0130:
End If
0131:
If Request.ServerVariables("SERVER_SOFTWARE")>="Microsoft-IIS/4.0" Then
0132:
StartHTML
0133:
response.write "<FORM METHOD=""POST"" ACTION=""" & gblScriptName & """><BLOCKQUOTE><TABLE CELLPADDING=5>" & VBCRLF
0134:
response.write "<TR>" & VBCRLF
0135:
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
0136:
response.write "<INPUT TYPE=""PASSWORD"" SIZE=17 NAME=""Password""></TD>" & VBCRLF
0137:
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
0138:
response.write "<INPUT TYPE=""CHECKBOX"" NAME=""SAVE""></TD>" & VBCRLF
0139:
response.write "<TD><INPUT TYPE=""SUBMIT"" NAME=""OK"" VALUE=""ENTER""></TD>" & VBCRLF
0140:
response.write "</TR>" & VBCRLF
0141:
response.write "<TR><TD COLSPAN=3>"
0142:
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
0143:
response.write "</TABLE></BLOCKQUOTE></FORM>" & VBCRLF
0144:
response.write VBCRLF
0145:
Else
0146:
gblPageText = "Your web server identified itself as """ & Request.ServerVariables("SERVER_SOFTWARE") & """."
0147:
StartHTML
0148:
response.write "<BLOCKQUOTE><FONT FACE=" & gblFace & " SIZE=5><B>Sorry.</B><P>" & VBCRLF
0149:
response.write "AnyPortal " & gblTitle & " requires Microsoft NT/2000 Internet Information Server (IIS) 4.0 or greater." & VBCRLF
0150:
response.write "</FONT></BLOCKQUOTE>" & VBCRLF
0151:
End If
0152:
EndHTML
0153:
End If
0154:
End Function 'Authorize
0155:
0156:
'--
0157:
' Condensation
0158:
Function Condensation(s)
0159:
a = 0
0160:
For i = 1 to len(s)
0161:
a = (ASC(mid(s,i,1)) + a*2) Mod 77411
0162:
Next 'i
0163:
Condensation = Right("00000" & Cstr(a),5) & Right("00000" & Cstr((len(s)*23)+25433),5)
0164:
End Function 'Condensation(s)
0165:
0166:
'--
0167:
' CreateImageTag
0168:
Function CreateImageTag(fn,altstr,align,border)
0169:
Dim f,fso,pn
0170:
Dim tstr,alignstr,borderstr
0171:
Dim chars,hw,width,height
0172:
0173:
If border="" Then
0174:
borderstr = " BORDER=0"
0175:
Else
0176:
borderstr = " BORDER=" & Cstr(border)
0177:
End If
0178:
If align="" Then
0179:
alignstr = ""
0180:
Else
0181:
alignstr = " ALIGN="""
0182:
Select Case UCase(left(align,1))
0183:
Case "L"
0184:
tstr = "LEFT"
0185:
Case "R"
0186:
tstr = "RIGHT"
0187:
Case "C"
0188:
tstr = "CENTER"
0189:
Case Else
0190:
End Select
0191:
alignstr = " ALIGN=""" & tstr & """"
0192:
End If
0193:
0194:
Set fso = CreateObject("Scripting.FileSystemObject")
0195:
pn = Server.MapPath(fn)
0196:
tstr = ""
0197:
Set f = fso.OpenTextFile(pn)
0198:
0199:
Select Case UCase(Right(fn,4))
0200:
Case ".GIF",".JPG"
0201:
If NOT f.AtEndOfStream Then
0202:
If UCase(Right(fn,4))=".GIF" Then 'always works
0203:
chars = f.read(10)
0204:
width = asc(mid(chars,8,1))*256 + asc(mid(chars,7,1))
0205:
height = asc(mid(chars,10,1))*256 + asc(mid(chars,9,1))
0206:
hw = " WIDTH=" & width & " HEIGHT=" & height
0207:
Else 'usually works
0208:
chars = f.read(200)
0209:
height = asc(mid(chars,164,1))*256 + asc(mid(chars,165,1))
0210:
width = asc(mid(chars,166,1))*256 + asc(mid(chars,167,1))
0211:
If (height>600) OR (height<3) OR (WIDTH<3) OR (WIDTH>600) Then
0212:
'could be wrong height, width... forget 'em
0213:
Else
0214:
hw = " WIDTH=" & width & " HEIGHT=" & height
0215:
End If
0216:
End If
0217:
End If
0218:
tstr = "<IMG SRC=""" & Replace(Replace(fn,"\","/")," ","%20") & """" & hw & borderstr & alignstr & " ALT=""" & altstr & """>"
0219:
End Select
0220:
f.Close
0221:
Set f = Nothing
0222:
Set fso = Nothing
0223:
CreateImageTag = tstr
0224:
End Function 'CreateImageTag
0225:
0226:
'--
0227:
' DetailPage
0228:
Sub DetailPage
0229:
Dim chars,fstr,hw,height,width
0230:
Dim IsTextFile,pathname
0231:
Dim fsize,fdatecreated,fdatelastmodified
0232:
0233:
pathname = fsDir & fn
0234:
If right(pathname,1) = "\" Then pathname = Left(pathname,len(pathname)-1)
0235:
0236:
' create if you gotta
0237:
If fso.FileExists(pathname) Then
0238:
Else
0239:
Select Case UCase(Request.QueryString("T"))
0240:
Case "D" 'create document
0241:
Set f = fso.CreateTextFile(pathname)
0242:
f.Close
0243:
Set f= Nothing
0244:
Case "F" 'create folder
0245:
Set f = fso.CreateFolder(pathname)
0246:
pathname = pathname & "\"
0247:
response.redirect gblScriptName & "?d=" & URLSpace(pathname)
0248:
End Select
0249:
End If
0250:
0251:
StartHTML
0252:
response.write "<P><FONT FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=4><B>" & pathname & "</B><BR>" & VBCRLF
0253:
response.write "<A HREF=""" & webbase & fn & """>" & webbase & fn & "</A><BR></FONT>" & VBCRLF
0254:
0255:
If fso.FileExists(pathname) Then
0256:
' fetch Window's file information
0257:
Set f = fso.GetFile(pathname)
0258:
fsize = f.size
0259:
fdatecreated = f.datecreated
0260:
fdatelastmodified = f.datelastmodified
0261:
response.write "<PRE>" & VBCRLF
0262:
response.write " file size: " & FormatNumber(fsize,0) & " characters" & VBCRLF
0263:
response.write " file created: <B>" & FormatDateTime(fdatecreated,1) & " </B> " & FormatDateTime(fdatecreated,3) & VBCRLF
0264:
response.write "last modified: <B>" & FormatDateTime(fdatelastmodified,1) & " </B> " & FormatDateTime(fdatelastmodified,3) & VBCRLF
0265:
response.write "</PRE>" & VBCRLF
0266:
Set f = Nothing
0267:
End If
0268:
0269:
response.write "<FORM ACTION=""" & gblScriptName & """ METHOD=""POST"">" & VBCRLF
0270:
response.write "<INPUT TYPE=""HIDDEN"" NAME=""fsDIR"" VALUE=""" & fsDir & """>" & VBCRLF
0271:
0272:
IsTextFile = FALSE
0273:
Select Case UCase(Right(fn,4))
0274:
Case ".GIF",".JPG"
0275:
tstr = CreateImageTag(basedir & fn,fn & " (" & FormatNumber(Int(fsize/1024*10+.05)/10,1) & " Kb)","",0)
0276:
response.write "<FONT FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=2>"
0277:
response.write Server.HTMLEncode(tstr) & "</FONT><BR><BR>" & tstr & "<P>" & VBCRLF
0278:
Case ".URL"
0279:
Set f = fso.OpenTextFile(pathname)
0280:
If NOT f.AtEndOfStream Then tstr = f.readall
0281:
f.Close
0282:
Set f = Nothing
0283:
response.write "<FONT COLOR=""#3333FF"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=2>" & VBCRLF
0284:
response.write Replace(Server.HTMLEncode(tstr),VBCRLF,VBCRLF & "<BR>")
0285:
response.write "</FONT>" & VBCRLF
0286:
Case ".TXT",".ASA",".ASP",".HTM","HTML",".CFM","PHP3",".XML"
0287:
'read the file
0288:
Set f = fso.OpenTextFile(pathname)
0289:
If NOT f.AtEndOfStream Then fstr = f.readall
0290:
f.Close
0291:
Set f = Nothing
0292:
Set fso = Nothing
0293:
IsTextFile = TRUE
0294:
response.write "<TABLE BGCOLOR=" & gblReverse & "><TR><TD>" & VBCRLF
0295:
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
0296:
response.write "<TEXTAREA NAME=""FILEDATA"" ROWS=18 COLS=70 WRAP=""OFF"">" & Server.HTMLEncode(fstr) & "</TEXTAREA>" & VBCRLF
0297:
response.write "</TD></TR></TABLE>" & VBCRLF
0298:
End Select
0299:
response.write VBCRLF & "<BR><BR>" & VBCRLF
0300:
If IsTextFile Then
0301:
response.write "<INPUT TYPE=""TEXT"" SIZE=48 MAXLENGTH=255 NAME=""PATHNAME"" VALUE=""" & pathname & """>" & VBCRLF
0302:
response.write "<INPUT TYPE=""RESET"" VALUE=""RESET""> <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""SAVE"">" & VBCRLF
0303:
response.write "<INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""CANCEL""><BR>" & VBCRLF
0304:
Else
0305:
response.write "<INPUT TYPE=""HIDDEN"" NAME=""PATHNAME"" VALUE=""" & pathname & """>" & VBCRLF
0306:
response.write "<INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""BACK""><BR>" & VBCRLF
0307:
End If
0308:
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
0309:
response.write "<INPUT TYPE=""CHECKBOX"" NAME=""DELETEOK"">" & VBCRLF
0310:
response.write "<INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""DELETE"">" & VBCRLF
0311:
response.write "</FORM>" & VBCRLF
0312:
EndHTML
0313:
End Sub 'DetailPage
0314:
0315:
'--
0316:
' DisplayCode
0317:
Sub DisplayCode
0318:
Dim fn,fso,f
0319:
Dim code,tstr
0320:
Dim a,arr,i
0321:
0322:
fn = Request.QueryString("c")
0323:
response.write "<HTML><HEAD><TITLE>" & fn & "</TITLE></HEAD><BODY>" & VBCRLF
0324:
response.write "<STYLE>" & VBCRLF
0325:
response.write "<!" & "--" & VBCRLF
0326:
response.write "SPAN{color:Navy;background-color:Yellow}" & VBCRLF
0327:
response.write "--" & ">" & VBCRLF
0328:
response.write "</STYLE>" & VBCRLF
0329:
0330:
If Instr(fn,fsroot)=1 Then
0331:
Set fso = CreateObject("Scripting.FileSystemObject")
0332:
Set f = fso.OpenTextFile(fn, 1, 0, 0)
0333:
If f.AtEndOfStream Then
0334:
code = ""
0335:
Else
0336:
code = f.ReadAll 'totally unconverted
0337:
End If
0338:
'quickly format code for readability...
0339:
' could be smarter, but it sure is simple!
0340:
tstr = Server.HTMLEncode(code)
0341:
tstr = Replace(tstr,chr(9)," ")
0342:
tstr = Replace(tstr," "," ")
0343:
tstr = Replace(tstr,"<%","<SPAN><" & "%</SPAN><FONT COLOR=""#000000"">")
0344:
tstr = Replace(tstr,"%>","<SPAN>%" & "</FONT>></SPAN>")
0345:
tstr = Replace(tstr,"<!--","<I><FONT COLOR=""#CC0033""><!--")
0346:
tstr = Replace(tstr,"-->","--></I></FONT>")
0347:
0348:
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
0349:
response.write " " & fn & "</B></FONT></TD></TR></TABLE>" & VBCRLF
0350:
0351:
response.write "<FONT COLOR=""#0000FF"" FACE=""Andale Mono, Monotype.com, Courier New, Courier, sans-serif"" SIZE=2>" & VBCRLF
0352:
response.write "<!" & "-- code listing --" & ">" & VBCRLF & VBCRLF
0353:
arr = Split(Replace(tstr,chr(13),""),chr(10)) 'handle unix/linux files, too
0354:
For i = 0 to UBound(arr)
0355:
'add line numbers and output
0356:
response.write "<BR><FONT COLOR=""#008000"">" & Right("000" & i+1,4) & ":</FONT> "
0357:
tstr = arr(i)
0358:
If left(Replace(Replace(tstr," ","")," " ,""),1) = "'" Then
0359:
response.write "<FONT COLOR=""#CC0033""><I>" & tstr & "</I></FONT>" & VBCRLF
0360:
Else
0361:
response.write tstr & VBCRLF
0362:
End If
0363:
Next 'i
0364:
response.write VBCRLF & "<!" & "-- end of code listing --" & ">" & VBCRLF
0365:
response.write "</FONT>" & VBCRLF
0366:
Else
0367:
response.write "<P><FONT COLOR=""#CC0033"" SIZE=3>Cannot access " & fn & "</FONT>" & VBCRLF
0368:
End If
0369:
response.write "<HR></BODY></HTML>"
0370:
End Sub 'DisplayCode
0371:
0372:
'--
0373:
' DisplayFileName
0374:
Sub DisplayFileName(dirfile,fhandle)
0375:
Dim newgif,linktarget
0376:
Dim fsize
0377:
0378:
response.write "<TR>" & VBCRLF
0379:
If dirFile="DIR" Then
0380:
0381:
linktarget = "<A HREF=""" & gblScriptName & "?d=" & URLSpace(fhandle) & "\"" TITLE=""Click here to move down a level and list the documents in this folder."">"
0382:
tstr = "<FONT FACE=" & gblFace & " SIZE=2>" & linktarget & LCase(fhandle.name) & "</A></FONT>"
0383:
if instr(1,fhandle,"_")<1 then
0384:
response.write "<TD VALIGN=""TOP"" ALIGN=""RIGHT"">" & MockIcon("fldr") & "</TD>" & VBCRLF
0385:
response.write "<TD COLSPAN=3 VALIGN=""TOP"" BGCOLOR=" & gblReverse & ">" & Tstr & "</TD>" & VBCRLF
0386:
end if
0387:
Else
0388:
0389:
newgif = ""
0390:
If fhandle.datelastmodified+14>gblNow Then newgif = MockIcon("newicon")
0391:
b = ""
0392:
If len(fhandle.name)>4 Then b = Ucase(Right(fhandle.name,4))
0393:
If Left(b,1) = "." Then b = Right(b,3)
0394:
Select Case b
0395:
Case "ASP","HTM","HTML","ASA","TXT","CFM","PHP3"
0396:
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>"
0397:
tstr = webbase & replace(fhandle.name," ","%20")
0398:
Case "URL"
0399:
tstr = ShortCutURL
0400:
Case Else
0401:
tstr = webbase & replace(fhandle.name," ","%20")
0402:
End Select
0403:
If fhandle.size<10240 Then
0404:
If fhandle.size=0 Then
0405:
fsize = "0"
0406:
Else
0407:
fsize = FormatNumber(fhandle.size,0,0,-2)
0408:
End If
0409:
Else
0410:
fsize = FormatNumber((fhandle.size+1023)/1024,0,0,-2) & "K"
0411:
End If
0412:
0413:
If (ucase(fhandle.name) <> "SHOW.ASP" and lcase(fhandle.name) <> "_vti_inf.html" AND instr(1,fhandle,".asa")<1 AND instr(1,fhandle,".dll")<1 and instr(1,fhandle,".xml")<1 AND ucase(fhandle.name) <> "UPLOADSEND.HTM" AND ucase(fhandle.name) <> "UPLOADRECEIVE.ASP") and lcase(fhandle.name)<>"postinfo.html" and lcase(fhandle.name)<>"logerror.asp" and lcase(fhandle.name)<>"test.asp" and lcase(fhandle.name)<>"showmetheerrors.asp" then
0414:
tstr = "<FONT FACE=" & gblFace & " SIZE=2><A HREF=""" & tstr & """ TITLE=""Click here to link to this document."">" & LCase(fhandle.name) & "</A></FONT>" & newgif
0415:
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
0416:
response.write "<TD VALIGN=""TOP"" BGCOLOR=" & gblReverse & ">" & Tstr & "</TD>" & VBCRLF
0417:
response.write "<TD VALIGN=""TOP"" BGCOLOR=" & gblReverse & "><FONT FACE=" & gblFace & " SIZE=1>" & FormatDateTime(fhandle.datelastmodified,0) & "</FONT></TD>" & VBCRLF
0418:
response.write "<TD VALIGN=""TOP"" BGCOLOR=" & gblReverse & "><FONT FACE=" & gblFace & " SIZE=1>" & fsize & " bytes</FONT></TD>" & VBCRLF
0419:
End if
0420:
End If
0421:
response.write "</TR>" & VBCRLF
0422:
0423:
End Sub 'DisplayFileName
0424:
0425:
'--
0426:
' MockIcon (icon emulator)
0427:
Function MockIcon(txt)
0428:
Dim tstr,d
0429:
0430:
'Sorry, mac/linux users.
0431:
tstr = "<FONT FACE=""WingDings"" SIZE=4 COLOR=" & gblRed & ">"
0432:
Select Case Lcase(txt)
0433:
Case "bmp","gif","jpg","tif","jpeg","tiff"
0434:
d = 176
0435:
Case "doc"
0436:
d = 50
0437:
Case "exe","bat","bas","c","src"
0438:
d = 255
0439:
Case "file"
0440:
d = 51
0441:
Case "fldr"
0442:
d = 48
0443:
Case "htm","html","asa","asp","cfm","php3"
0444:
d = 182
0445:
Case "pdf"
0446:
d = 38
0447:
Case "txt","ini"
0448:
d = 52
0449:
Case "xls"
0450:
d = 252
0451:
Case "zip","arc","sit"
0452:
d = 59
0453:
Case "newicon"
0454:
tstr = "<FONT TITLE=""This document has been modified sometime during the last 14 days."" FACE=""WingDings"" SIZE=4 COLOR=" & gblRed & ">"
0455:
d = 171
0456:
Case "view"
0457:
d = 52
0458:
Case Else
0459:
d = 51
0460:
End Select
0461:
tstr = tstr & Chr(d) & "</FONT>"
0462:
MockIcon = tstr
0463:
End Function 'mockicon
0464:
0465:
'--
0466:
' Navigate
0467:
Sub Navigate
0468:
Dim emptyDir
0469:
0470:
emptyDir = TRUE
0471:
response.write "<TABLE BORDER=0 CELLPADDING=2 CELLSPACING=3 WIDTH=""100%"">"
0472:
0473:
' get the directory of file names
0474:
If toplevel Then
0475:
parent = ""
0476:
Else
0477:
parent = fso.GetParentFolderName(fsDir) & "\"
0478:
response.write "<TR><TD VALIGN=""TOP"" ALIGN=""RIGHT""><FONT FACE=""WingDings"" SIZE=4 COLOR=" & gblRed & ">" & chr(199) & "</FONT></TD>" & VBCRLF
0479:
'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
0480:
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) & """>Click here to move up a level to the parent folder.</A></B></FONT></TD></TR>" & VBCRLF
0481:
End If
0482:
Set f = fso.GetFolder(fsDir)
0483:
Set FileList = f.subFolders
0484:
a = 0
0485:
For Each fn in FileList
0486:
emptyDir = FALSE
0487:
If a = 0 Then
0488:
a = 1
0489:
response.write "<TR><TD VALIGN=""TOP""> </TD>" & VBCRLF
0490:
'response.write "<TD COLSPAN=3><HR><FONT FACE=" & gblFace & " SIZE=4><B>Additional Folders</B></FONT></TD>" & VBCRLF
0491:
response.write "</TR>" & VBCRLF
0492:
response.write "<TR><TD VALIGN=""TOP""> </TD>" & VBCRLF
0493:
response.write "<TD COLSPAN=3 VALIGN=""BOTTOM""><FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1><B>FOLDER NAME</B></FONT></TD>" & VBCRLF
0494:
response.write "</TR>" & VBCRLF
0495:
End If
0496:
DisplayFileName "DIR",fn
0497:
0498:
Next 'fn
0499:
0500:
response.write "<TR><TD VALIGN=""TOP""> </TD>" & VBCRLF
0501:
0502:
'response.write "<TD COLSPAN=3><HR><FONT FACE=" & gblFace & " SIZE=4><B>" & fsDir & "</B></FONT></TD>" & VBCRLF
0503:
'response.write "</TR>" & VBCRLF
0504:
Response.Write "<TD COLSPAN=3><HR><FONT FACE=" & gblFace & " SIZE=4><B>Documents</B></FONT></TD>" & VBCRLF
0505:
0506:
response.write "<TR><TD VALIGN=""TOP""> </TD>" & VBCRLF
0507:
response.write "<TD VALIGN=""BOTTOM""><FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1><B>DOCUMENT NAME</B></FONT></TD>" & VBCRLF
0508:
response.write "<TD VALIGN=""BOTTOM""><FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1><B>LAST UPDATE</B></FONT></TD>" & VBCRLF
0509:
response.write "<TD VALIGN=""BOTTOM""><FONT FACE=" & gblFace & " COLOR=" & gblRed & " SIZE=1><B>FILE SIZE</B></FONT></TD>" & VBCRLF
0510:
response.write "</TR>" & VBCRLF
0511:
response.write "" & VBCRLF
0512:
0513:
Set filelist = f.Files
0514:
For Each fn in filelist
0515:
emptyDir = FALSE
0516:
DisplayFileName "FILE",fn
0517:
0518:
Next 'fn
0519:
0520:
If emptyDir Then
0521:
response.write " <FORM METHOD=""POST"" ACTION=""" & gblScriptName & """>" & VBCRLF
0522:
response.write " <TR><TD></TD><TD COLSPAN=3 VALIGN=""BOTTOM"" BGCOLOR=" & gblReverse & ">" & VBCRLF
0523:
response.write " <INPUT TYPE=""HIDDEN"" NAME=""PARENT"" VALUE=""" & parent & """>" & VBCRLF
0524:
response.write " <INPUT TYPE=""HIDDEN"" NAME=""PATHNAME"" VALUE=""" & fsDir & """>" & VBCRLF
0525:
response.write " <FONT FACE=" & gblFace & " SIZE=1> Empty Folder </FONT>" & VBCRLF
0526:
'response.write " <INPUT TYPE=""CHECKBOX"" NAME=""OK""> " & VBCRLF
0527:
'response.write " <INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""DELETE"">" & VBCRLF
0528:
response.write " </TD></TR></FORM>" & VBCRLF
0529:
End If
0530:
0531:
' response.write "<TR><TD></TD><TD COLSPAN=3><HR></TD></TR>" & VBCRLF
0532:
' response.write " <FORM METHOD=""GET"" ACTION=""" & gblScriptName & """>" & VBCRLF
0533:
' response.write " <TR><TD></TD><TD COLSPAN=3 VALIGN=""BOTTOM"" BGCOLOR=" & gblReverse & ">" & VBCRLF
0534:
' response.write " <FONT FACE=" & gblFace & " SIZE=1> CREATE NEW </FONT>" & VBCRLF
0535:
' response.write " <INPUT TYPE=""RADIO"" NAME=""T"" VALUE=""D"" CHECKED><FONT FACE=" & gblFace & " SIZE=1>DOCUMENT</FONT>" & VBCRLF
0536:
' response.write " <FONT FACE=" & gblFace & " SIZE=1> -OR- </FONT>" & VBCRLF
0537:
' response.write " <INPUT TYPE=""RADIO"" NAME=""T"" VALUE=""F""><FONT FACE=" & gblFace & " SIZE=1>FOLDER:</FONT> " & VBCRLF
0538:
' response.write " <FONT FACE=" & gblFace & " SIZE=1> NAME </FONT> " & VBCRLF
0539:
' response.write " <INPUT TYPE=""TEXT"" NAME=""F"" SIZE=14> " & VBCRLF
0540:
' response.write " <INPUT TYPE=""HIDDEN"" NAME=""D"" VALUE=""" & fsDir & """>" & VBCRLF
0541:
' response.write " <INPUT TYPE=""SUBMIT"" VALUE=""CREATE"">" & VBCRLF
0542:
' response.write " <NOBR><FONT FACE=" & gblFace & " SIZE=1> OR <A HREF=""" & gblScriptName & "?u=Y&d=" & URLSpace(fsDir) & """>UPLOAD</A> USING SA-FILEUP</FONT></NOBR>" & VBCRLF
0543:
' response.write " </TD></TR></FORM>" & VBCRLF
0544:
' response.write "</TABLE>" & VBCRLF
0545:
0546:
End Sub 'Navigate
0547:
0548:
'--
0549:
' ShortCutURL
0550:
Function ShortCutURL
0551:
Dim f,fstr,tstr
0552:
tstr = ""
0553:
Set f = fso.OpenTextFile(fn)
0554:
Do While NOT f.AtEndOfStream
0555:
tstr = f.readline
0556:
If len(tstr)<7 Then
0557:
Else
0558:
If left(lcase(tstr),4)="url=" Then
0559:
fstr = tstr
0560:
End If
0561:
End If
0562:
Loop
0563:
f.Close
0564:
Set f= Nothing
0565:
If fstr = "" Then
0566:
ShortCutURL = fn
0567:
Else
0568:
ShortCutURL = Replace(mid(fstr,5,255)," ","%20")
0569:
End If
0570:
End Function 'ShortCutURL
0571:
0572:
'--
0573:
' SStr (force null to "")
0574:
Function SStr(v)
0575:
Dim rt
0576:
If IsNull(v) Then
0577:
rt = ""
0578:
Else
0579:
rt = Trim(Cstr(v))
0580:
End If
0581:
SStr = rt
0582:
End Function 'sstr
0583:
0584:
0585:
'--
0586:
' UploadPage
0587:
Sub UploadPage
0588:
StartHTML
0589:
response.write "<P><TABLE BORDER=0 CELLPADDING=5><TR><TD WIDTH=5></TD><TD BGCOLOR=" & gblReverse & " VALIGN=""""TOP"""">" & VBCRLF
0590:
response.write "<FORM ENCTYPE=""multipart/form-data"" METHOD=""POST"" ACTION=""" & gblScriptName & "?u=D&d=" & URLSpace(fsDir) & """>" & VBCRLF
0591:
response.write "<FONT SIZE=1 FACE=" & gblFace & ">NAME OF DESTINATION FOLDER ON WEB SITE</FONT><BR>" & VBCRLF
0592:
response.write "<FONT SIZE=4 FACE=" & gblFace & "><B>" & fsDir & "</B></FONT><P>" & VBCRLF
0593:
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
0594:
response.write "<INPUT TYPE=""SUBMIT"" VALUE=""UPLOAD"">" & VBCRLF
0595:
response.write "<P><FONT SIZE=2 FACE=" & gblFace & ">If the <B>[BROWSE...]</B> button is not displayed," & VBCRLF
0596:
response.write "<BR>you must upgrade your <A HREF=""http://www.netscape.com"">Netscape</A>" & VBCRLF
0597:
response.write "or <A HREF=""http://www.microsoft.com"">Microsoft</A> browser." & VBCRLF
0598:
response.write "</FORM></TD>" & VBCRLF
0599:
response.write "<TD VALIGN=""TOP""><FONT SIZE=2 FACE=" & gblFace & ">" & VBCRLF
0600:
response.write "<P>Your browser:<BR>HTTP_USER_AGENT: " & Request.ServerVariables("HTTP_USER_AGENT") & "" & VBCRLF
0601:
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." & VBCRLF
0602:
response.write "<BR>(Some object is <B>always</B> required for uploads<I>!!!</I>)" & VBCRLF
0603:
response.write "</FONT>" & VBCRLF
0604:
response.write "<FORM METHOD=""POST"" ACTION=""" & gblScriptName & """>" & VBCRLF
0605:
response.write "<INPUT TYPE=""HIDDEN"" NAME=""fsDir"" VALUE=""" & fsDir & """><BR>" & VBCRLF
0606:
response.write "<FONT SIZE=2 FACE=" & gblFace & ">DON'T USE SA-FILEUP?<BR>SORRY! CLICK HERE...</FONT><BR>" & VBCRLF
0607:
response.write "<INPUT TYPE=""SUBMIT"" NAME=""POSTACTION"" VALUE=""CANCEL"">" & VBCRLF
0608:
response.write "</FORM>" & VBCRLF
0609:
response.write "</TD></TR></TABLE><P>" & VBCRLF
0610:
EndHTML
0611:
End Sub 'UploadPage
0612:
0613:
'--
0614:
' URLspace
0615:
Function URLSpace(s)
0616:
URLSpace = replace(replace(s,"+","%2B")," ","+")
0617:
End Function 'URLSpace
0618:
0619:
'----
0620:
'MAIN
0621:
'----
0622:
Dim filelist,fn,upl
0623:
Dim TextObject,fhandle,lsplit
0624:
0625:
Dim fsDir,baseDir,webbase
0626:
Dim fsRoot,webRoot
0627:
Dim pathname,parent,toplevel
0628:
0629:
gblTitle = " Your Company Name - Download list "
0630:
0631:
0632:
0633:
'If NOT Authorize Then
0634:
'function will output HTML for password
0635:
'Else
0636:
'initialization
0637:
0638:
Set fso = CreateObject("Scripting.FileSystemObject")
0639:
0640:
'dynamically find out where the documents and web pages are located
0641:
0642:
fsDir = replace(LCase(Request.QueryString("d")),"/../","/")
0643:
0644:
0645:
If fsDir = "" Then fsDir = Request.Form("fsDir")
0646:
fsRoot = LCase(Replace(Server.MapPath(gblScriptName),"\" & gblScriptName,"") & "\")
0647:
0648:
0649:
0650:
If Instr(fsdir,fsroot) <> 1 Then fsDir = fsRoot
0651:
0652:
0653:
0654:
If Lcase(fsDir) = Lcase(fsRoot) Then toplevel = TRUE
0655:
basedir = Replace(Mid(fsDir,len(fsRoot),250),"\","/")
0656:
webRoot = "http://" & Request.ServerVariables("SERVER_NAME") & Replace(Request.ServerVariables("SCRIPT_NAME"),"/" & gblScriptName,"")
0657:
webbase = replace(webroot & basedir," ","%20")
0658:
0659:
'process a GET/POST request
0660:
0661:
If Request.QueryString("u")="D" Then
0662:
Action = "UPLOAD"
0663:
Else
0664:
Action = Request.Form("POSTACTION")
0665:
pathname = Request.Form("PATHNAME")
0666:
End If
0667:
0668:
0669:
0670:
Select Case UCase(Action)
0671:
Case "UPLOAD"
0672:
Set upl = Server.CreateObject("SoftArtisans.FileUp")
0673:
tstr = Mid(upl.UserFilename, InstrRev(upl.UserFilename, "\") + 1)
0674:
If tstr = "" Then
0675:
Else
0676:
upl.SaveAs fsdir & tstr
0677:
End If
0678:
Case "SAVE"
0679:
Select Case UCase(Right(pathname,4))
0680:
Case ".TXT",".ASA",".ASP",".HTM","HTML",".CFM","PHP3"
0681:
If Instr(pathname,fsroot) = 1 Then
0682:
Set f = fso.CreateTextFile(pathname)
0683:
f.write Request.Form("FILEDATA")
0684:
f.close
0685:
End If
0686:
End Select
0687:
Case "DELETE" 'either document or folder
0688:
If Request.Form("OK") = "on" Then
0689:
parent = Request.Form("Parent")
0690:
If Instr(pathname,fsroot) = 1 Then
0691:
fso.DeleteFolder Left(pathname,Len(pathname)-1),TRUE
0692:
response.redirect gblScriptName & "?d=" & URLSpace(parent)
0693:
End If
0694:
End If
0695:
If Request.Form("DELETEOK") = "on" Then
0696:
If Instr(pathname,fsroot) = 1 Then
0697:
If fso.FileExists(Request.Form("PathName")) Then
0698:
Set f = fso.GetFile(Request.Form("PathName"))
0699:
f.delete
0700:
End If
0701:
End If
0702:
End If
0703:
End Select
0704:
0705:
If Action <> "" Then
0706:
tstr = gblScriptName & "?d="
0707:
If NOT toplevel Then tstr = tstr & URLSpace(fsDir)
0708:
response.redirect tstr
0709:
End If
0710:
0711:
'check for mode... navigate, code display, upload, or detail?
0712:
0713:
0714:
0715:
0716:
0717:
fn = LCase(Request.QueryString("f"))
0718:
If fn="" Then
0719:
If Request.QueryString("u") = "Y" Then
0720:
gblTitle = gblTitle & " (Upload Page)"
0721:
gblPageText = "Use this page to upload a single document to this web site."
0722:
UploadPage
0723:
Else
0724:
0725:
0726:
0727:
If Request.QueryString("c") = "" Then
0728:
'gblPageText = "Use this page to add, delete or revise documents on this web site."
0729:
gblPageText = ""
0730:
StartHTML
0731:
Navigate
0732:
EndHTML
0733:
Else
0734:
DisplayCode
0735:
0736:
response.Write "no"
0737:
Response.End
0738:
End If
0739:
End If
0740:
0741:
Else
0742:
gblTitle = gblTitle & " (Detail Page)"
0743:
gblPageText = "Use this page to view, modify or delete a single document on this web site."
0744:
DetailPage
0745:
0746:
0747:
0748:
End If
0749:
'End If
0750:
%
>
0751:
0752: