 |
|
 |
Technowave always encourages our consultants to share their knowledge and experience on a regular basis to various publications. The following is a selection of some of their presentation.
<%
Option Explicit
Dim action
Dim a,b,c,i,item,j
Dim f,fso
Dim arr,tstr
'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
gblRed = """#FF0000"""
Dim gblReverse
gblReverse = """#E0E0E0"""
'global variables
Dim gblTitle,gblPageText
gblTitle = " * * * TITLE NOT SET * * * "
gblPageText = " "
'global constants
Dim gblScriptName
gblScriptName = Request.ServerVariables("Script_Name")
gblScriptName = Mid(gblScriptName,InstrRev(gblScriptName,"/") + 1)
Dim gblRoot
gblRoot = Replace(Request.ServerVariables("Script_Name"),"/" & gblScriptName,"")
'--
' DisplayFileName
Sub DisplayFileName(dirfile,fhandle)
Dim newgif,linktarget
Dim fsize
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 "ASP","HTM","HTML","ASA","TXT","CFM","PHP3"
newgif = newgif & " " & MockIcon("view") & ""
tstr = webbase & replace(fhandle.name," ","%20")
Case "URL"
tstr = ShortCutURL
Case Else
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
tstr = "" & LCase(fhandle.name) & "" & newgif
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
'--
' 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"
d = 255
Case "file"
d = 51
Case "fldr"
d = 48
Case "htm","html","asa","asp","cfm","php3"
d = 182
Case "pdf"
d = 38
Case "txt","ini","inc"
d = 52
Case "xls"
d = 252
Case "zip","arc","sit"
d = 59
Case "newicon"
tstr = ""
d = 171
Case "view"
d = 52
Case Else
d = 51
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 "| " & chr(199) & " | " & VBCRLF
response.write "" & UCASE(fso.GetParentfolderName(fsDir) & "\") & " | " & 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 "Additional Folders | " & VBCRLF
response.write " " & VBCRLF
response.write "| | " & VBCRLF
response.write "FOLDER NAME | " & VBCRLF
response.write " " & VBCRLF
End If
DisplayFileName "DIR",fn
Next 'fn
response.write "| | " & VBCRLF
response.write "" & fsDir & " | " & VBCRLF
response.write " " & VBCRLF
response.write "| | " & VBCRLF
response.write "WHITEPAPER LIST | " & VBCRLF
response.write "LAST UPDATE | " & VBCRLF
response.write "FILE SIZE | " & 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
End If
End Sub 'Navigate
'--
' 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
'--
' 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
Set fso = CreateObject("Scripting.FileSystemObject")
'dynamically find out where the documents and web pages are located
fsDir = replace(LCase(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
'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
gblPageText = "Use this page to add, delete or revise documents on this web site."
Navigate
Else
DisplayCode
End If
End If
Else
End If
%>
| |
© 2005 Technowave. All Rights Reserved
|
|
|
