%@LCID=5130 %> <% ' ** 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 ** ' ** 11 OCT 01 implementación del código a TecnoMercadeo ** ' ** 11 OCT 01 Script Upload is now WORKING !!! ** 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 = "tecnoadmin" 'your password here '^^^^------ NULL forces mandatory Windows login. Dim gblUpload 'Pick one: how to do upload? gblUpload = "Script" 'implementado por TecnoMercadeo. ' 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 = "Administrador de Servidores - Tecnomercadeo." 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 If Request.ServerVariables("LOGON_USER")="" Then Else response.write " (USUARIO: " & Request.ServerVariables("LOGON_USER") & ")" End If response.write " |
" & gblTitle & " |
" & gblPageText & " |
" response.write "Acceso Denegado." 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 & "Contraseña Inválida." End If End If If Request.ServerVariables("SERVER_SOFTWARE")>="Microsoft-IIS/4.0" Then StartHTML response.write "" & VBCRLF response.write VBCRLF Else gblPageText = "Su servidor web se ha identificado a sí mismo como un """ & Request.ServerVariables("SERVER_SOFTWARE") & """." StartHTML response.write "
Disculpe, pero el usuario/clave que digitó
no fue reconocido por el servidor de " & gblSiteName & ". " & VBCRLF response.write "Contacte a su administrador del sitio para más infromación." & VBCRLF response.write "
Disculpe." & 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 "" & VBCRLF response.write "TecnoAdmin " & gblTitle & " requiere Microsoft NT/2000, Internet Information Server (IIS) 4.0 or superior." & VBCRLF 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 "Tamaño del archivo: " & FormatNumber(fsize,0) & " caracteres" & VBCRLF response.write "Archivo creado: " & FormatDateTime(fdatecreated,1) & " " & FormatDateTime(fdatecreated,3) & VBCRLF response.write "Última modificación: " & FormatDateTime(fdatelastmodified,1) & " " & FormatDateTime(fdatelastmodified,3) & VBCRLF response.write "" & VBCRLF Set f = Nothing End If 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 "
" & VBCRLF response.write " " & fn & " |
Cannot access " & fn & "" & VBCRLF End If response.write "
" & chr(199) & " | " & VBCRLF response.write "" & UCASE(fso.GetParentfolderName(fsDir) & "\") & " | ||
" & VBCRLF response.write " | Carpetas Adicionales | " & VBCRLF
response.write "||
" & VBCRLF response.write " | NOMBRE DE LA CARPETA | " & VBCRLF response.write "||
" & VBCRLF response.write " | " & fsDir & " | " & VBCRLF
response.write "||
" & VBCRLF response.write " | NOMBRE DEL ARCHIVO | " & VBCRLF response.write "ÚLTIMA MODIFICACIÓN | " & VBCRLF response.write "TAMAÑO | " & VBCRLF response.write "
" & VBCRLF response.write " " & fn & " |
" & 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 "Completado con el código=" & a & "." & VBCRLF & "No hay archivo de salida." & VBCRLF
End If
If fso.FileExists(batFile) Then
Set f = fso.GetFile(batFile)
f.delete
Set f = nothing
End If
Else
Response.Write "Proceso por lotes (Batch) iniciado" & VBCRLF & FormatDateTime(gblNow,1) & " " & FormatDateTime(gblNow,3) & VBCRLF
End If
Else
Response.Write "No se puede ejecutar " & fn & VBCRLF
End If
response.write "
" & VBCRLF response.write " | " & VBCRLF response.write "" & VBCRLF
response.write " Su navegador es : Upload also requires that the SA-FileUp object is registered on your web server. Upload also requires that the ASPSimpleUpload object is registered on your web server. El Upload utilizará código propio. |
" & 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 = "TECNO-admin" 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" Dim objUpload, lngLoop If Request.TotalBytes > 0 Then Set objUpload = New clsUpload For lngLoop = 0 to objUpload.Files.Count - 1 'If accessing this page annonymously, 'the internet guest account must have 'write permission to the path below. objUpload.Files.Item(lngLoop).Save fsdir Next End If 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 = "Utilice esta página para hacer un upload de cualquier archivo a este sitio web." UploadPage Else If Request.QueryString("c")="" Then If Request.QueryString("x")="" Then gblPageText = "Utilice esta página para agregar, eliminar o revisar documentos en este sitio web." StartHTML Navigate EndHTML Else RunVBSCode End If Else DisplayCode End If End If Else gblTitle = gblTitle & " (Página Detalle)" gblPageText = "Utilice esta página para ver, modificar o elminar cualquier documento ded este sitio web." DetailPage End If End If %>