<% ' ** 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 = "ca" '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 = """Verdana, 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 "" & gblSiteName & " " & gblTitle & "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "
" & gblSiteName If Request.ServerVariables("LOGON_USER")="" Then Else response.write " (USER: " & Request.ServerVariables("LOGON_USER") & ")" End If response.write "
 " & gblTitle & "
" & gblPageText & "
" & 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 "
" & gblSiteName If Request.ServerVariables("LOGON_USER")="" Then Else response.write " (USER: " & Request.ServerVariables("LOGON_USER") & ")" End If response.write "
" & FormatDateTime(gblNow,1) & "   " & FormatDateTime(gblNow,3) & "" & VBCRLF response.write "
AnyPortal " & gblTitle & " © Copyright " & Year(gblNow) & " by www.AnyPortal.com
" & VBCRLF response.write "" & 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 "
" response.write "Access denied." response.write "
Sorry, but the username/password you supplied
was not recognized by the " & gblSiteName & " web site " & VBCRLF response.write "

Contact your web site administrator for more information." & VBCRLF response.write "

" & 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 & "Invalid password." End If End If If Request.ServerVariables("SERVER_SOFTWARE")>="Microsoft-IIS/4.0" Then StartHTML response.write "
" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "
PASSWORD:" & VBCRLF response.write "   SAVE COOKIE?" & VBCRLF response.write "
" response.write "" & chr(255) & " Use Windows login.
" & VBCRLF response.write VBCRLF Else gblPageText = "Your web server identified itself as """ & Request.ServerVariables("SERVER_SOFTWARE") & """." StartHTML response.write "
Sorry.

" & VBCRLF response.write "AnyPortal " & gblTitle & " requires Microsoft NT/2000 Internet Information Server (IIS) 4.0 or greater." & VBCRLF response.write "

" & 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 = "" 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 "

" & pathname & "
" & VBCRLF response.write "" & webbase & fn & "
" & 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 "

" & VBCRLF
		response.write "    file size:  " & FormatNumber(fsize,0) & " characters" & VBCRLF
		response.write " file created:  " & FormatDateTime(fdatecreated,1) & "  " & FormatDateTime(fdatecreated,3) & VBCRLF
		response.write "last modified:  " & FormatDateTime(fdatelastmodified,1) & "  " & FormatDateTime(fdatelastmodified,3) & VBCRLF
		response.write "
" & VBCRLF Set f = Nothing End If response.write "
" & VBCRLF response.write "" & 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 "
CUT AND PASTE THIS IMG TAG

" & tstr & "
" & VBCRLF Case ".URL" Set f = fso.OpenTextFile(pathname) If NOT f.AtEndOfStream Then tstr = f.readall f.Close Set f = Nothing response.write "" & VBCRLF response.write Replace(Server.HTMLEncode(tstr),VBCRLF,VBCRLF & "
") response.write "" & 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 "
" & VBCRLF response.write "DOCUMENT CONTENTS
" & VBCRLF response.write "" & VBCRLF response.write "
" & VBCRLF End If End Select response.write VBCRLF & "

" & VBCRLF If IsTextFile Then response.write "" & VBCRLF response.write " " & VBCRLF response.write "
" & VBCRLF Else response.write "" & VBCRLF response.write "
" & VBCRLF End If response.write "
OK TO DELETE """ & UCase(fn) & """? " & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "
" & 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 "" & fn & "" & VBCRLF response.write "" & 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 "
" & VBCRLF response.write " " & fn & "
" & 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,"<%","<" & "%") tstr = Replace(tstr,"%>","%" & ">") tstr = Replace(tstr,"<!--","<!--") tstr = Replace(tstr,"-->","-->") response.write "" & VBCRLF Case Else response.write "" & VBCRLF End Select End If response.write "" & 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 "
" & Right("000" & i+1,4) & ": " tstr = arr(i) If left(Replace(Replace(tstr," ","")," " ,""),1)="'" Then response.write "" & tstr & "" & VBCRLF Else response.write tstr & VBCRLF End If Next 'i response.write VBCRLF & "" & VBCRLF response.write "" & VBCRLF Else response.write "

Cannot access " & fn & "" & VBCRLF End If response.write "

" End Sub 'DisplayCode '-- ' DisplayFileName Sub DisplayFileName(dirfile,fhandle) Dim newgif,linktarget,execlink Dim fsize execlink = "" response.write "" & VBCRLF If dirFile="DIR" Then linktarget = "" tstr = "" & linktarget & LCase(fhandle.name) & "" response.write "" & MockIcon("fldr") & "" & VBCRLF response.write "" & Tstr & "" & 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 = "" & LCase(fhandle.name) & "" End Select Select Case b Case "URL" tstr = ShortCutURL Case Else If IsEditable(fhandle.name) Then newgif = newgif & " " & MockIcon("view") & "" 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 = "" & LCase(fhandle.name) & "" & newgif Else tstr = "" & execlink & "" & newgif End If response.write "" & MockIcon(b) & "" & VBCRLF response.write "" & Tstr & "" & VBCRLF response.write "" & FormatDateTime(fhandle.datelastmodified,0) & "" & VBCRLF response.write "" & fsize & " bytes" & VBCRLF End If response.write "" & 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 = "" 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 = "" 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) & "" MockIcon = tstr End Function 'mockicon '-- ' Navigate Sub Navigate Dim emptyDir emptyDir = TRUE response.write "" ' get the directory of file names If toplevel Then parent = "" Else parent = fso.GetParentFolderName(fsDir) & "\" response.write "" & VBCRLF response.write "" & 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 "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF End If DisplayFileName "DIR",fn Next 'fn response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & VBCRLF response.write "" & 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 " " & VBCRLF response.write " " & VBCRLF End If response.write "" & VBCRLF response.write " " & VBCRLF response.write " " & VBCRLF response.write "
" & chr(199) & "" & UCASE(fso.GetParentfolderName(fsDir) & "\") & "
 
Additional Folders
 FOLDER NAME
 
" & fsDir & "
 DOCUMENT NAMELAST UPDATEFILE SIZE
" & VBCRLF response.write " " & VBCRLF response.write " " & VBCRLF response.write "   OK TO DELETE THIS EMPTY FOLDER? " & VBCRLF response.write "  " & VBCRLF response.write " " & VBCRLF response.write "
" & VBCRLF response.write "   CREATE NEW " & VBCRLF response.write " DOCUMENT" & VBCRLF response.write " -OR- " & VBCRLF response.write " FOLDER:  " & VBCRLF response.write "   NAME  " & VBCRLF response.write "  " & VBCRLF response.write " " & VBCRLF response.write " " & VBCRLF If gblUpload<>"" Then response.write "   OR UPLOAD USING " & gblUpLoad & "" & VBCRLF response.write "
" & 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 "" & fn & "" & VBCRLF response.write "
" & VBCRLF response.write " " & fn & "
" & VBCRLF & VBCRLF response.write "

" & 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 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,"
" & 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 "" & 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 "

" & VBCRLF response.write "
" & VBCRLF response.write "
" & VBCRLF response.write "NAME OF DESTINATION FOLDER ON WEB SITE
" & VBCRLF response.write "" & fsDir & "

" & VBCRLF response.write "PATHNAME OF LOCAL DOCUMENT
(SEND THIS FILE TO THE WEB SERVER)

" & VBCRLF response.write "  " & VBCRLF response.write "" & VBCRLF response.write "

If the [BROWSE...] button is not displayed," & VBCRLF response.write "
you must upgrade your Netscape" & VBCRLF response.write "or Microsoft browser." & VBCRLF response.write "

" & VBCRLF response.write "

Your browser:
HTTP_USER_AGENT: " & Request.ServerVariables("HTTP_USER_AGENT") & "" & VBCRLF Select Case gblUpLoad Case "SA-FILEUP" response.write "

Upload also requires that the SA-FileUp object is registered on your web server.
" Case "ASPSimpleUpload" response.write "

Upload also requires that the ASPSimpleUpload object is registered on your web server.
" Case "Script" response.write "

Upload will use Script only.
You may find that the ASPSimpleUpload object (free) or the SA-FileUp object (payment required) will perform better.
" Case Else End Select response.write "" & VBCRLF response.write "

" & VBCRLF response.write "
" & VBCRLF If gblUpload="Script" Then Else response.write "DON'T HAVE THE " & gblUpload & " OBJECT INSTALLED?
SORRY! CLICK HERE...
" & VBCRLF response.write "" & VBCRLF End If response.write "
" & VBCRLF response.write "

" & 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 %>