Site Administration - Files Source Code in ASP

Special : Web Developer's Collection CD-ROM
50,000+ Web Templates, Logos, Cliparts, Scripts. Order Now!

Add to Favorites Make Home Page

1586 Online

Language Categories

Source Codes Home
Project Ideas New!
Interview Questions
FAQs Home
ASP Home: ASP Source Codes; ASP Script Directory New!; ASP .Net Script Directory New!; ASP Interview Questions; ASP FAQs; ASP How Tos
C Home: C Source Codes; C Script Directory New!; C Interview Questions; C FAQs; C How Tos
C++ Home: C++ Source Codes; C++ Script Directory New!; C++ Interview Questions; C++ FAQs; C++ How Tos
Java Home: Java Source Codes; Java Directory New!; Java Interview Questions; Java FAQs; Java How Tos
JavaScript Home: JavaScript Directory New!; JavaScript Source Codes; JavaScript FAQs; JavaScript How Tos
COBOL Home: COBOL Source Codes; COBOL FAQs; COBOL How Tos
Pascal Home: Pascal Source Codes; Pascal FAQs; Pascal How Tos
PHP Script Directory New!
Python Script Directory New!
Perl & CGI Script Directory New!
Flash Script Directory New!
CFML Script Directory New!
Remotely Hosted Scripts New!
Tools & Utilities Directory New!
XML Script Directory New!
Best Programmers: Amit Mathur; Vishal Bhardwaj; Deepesh Jain
Vyom NetWork

Our Services

Get 9,000 Interview Questions & Answers in an eBook.

9500+ Pages
9000 Question & Answers
All Tech. Categories

14 MB Content

Get it now !!

Home » ASP Home » Files Home » Site Administration

A D V E R T I S E M E N T

Title	Site Administration
Author	John Martin
Author Email	andmore [at] alief.com
Description	This is an application to administer a website remotely through an ASP
Category	ASP » Files
Hits	385653
Code	Select and Copy the Code
<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: [email protected] ' ' 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))+a2) 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/102410+.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 = 260 '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 %>

Related Source Codes

Script Name Author

�� VyomWorld

Resistor color code reader A.Chermarajan.

Telephone Directory dhivya

card swapping game (Mini Project) nityanand

simple hangman-pascalsource Seabert

college dirtectory (Mini Project) msridhar

Poll Application John van Meter

ASP Daily Hit Counter. Tejaskumar Gandhi

To avoid null in asp environment using sql Sami

Maklumbalas webmaster

poll John van Meter

EasyASP Template Engine. TjoekBezoer

Basic Calculator using HTML & Javascript. Patrick M. D Souza

What servers support ASP ? VyomWorld

What is ASP? VyomWorld

A D V E R T I S E M E N T

Google Groups Subscribe to SourceCodesWorld - Techies Talk

Email:

Free eBook - Interview Questions: Get over 1,000 Interview Questions in an eBook for free when you join JobsAssist. Just click on the button below to join JobsAssist and you will immediately receive the Free eBook with thousands of Interview Questions in an ebook when you join.

Free Tutorials - HTML, Java, SQL, PHP, ASP, Perl, SQL Tutorials
Discuss Programming Problems and Freshers Jobs related issues here.
Discuss Final Year Project Ideas here.