<%
'### Check if IIS app has application/session
On error resume next
If NOT Application("AppIsInitialized") OR NOT Session("SessionIsInitialized") Then Response.redirect("diags.asp")
On Error Goto 0
Server.ScriptTimeout=Application("ScriptTimeout")
'### Prevent caching
'Response.ExpiresAbsolute = #2000-01-01#
'Response.AddHeader "pragma", "no-cache"
'Response.AddHeader "cache-control", "private, no-cache, must-revalidate"
Response.AddHeader "P3P","CP=CAO PSA OUR'"
%>
<!--
#############################################################
Powerful ASP applications for IIS
© 2006 - http://www.iisworks.com
#############################################################
-->
<%
Const Delim1="@¶@" 'Separates items
Const Delim2="#¶#" 'Separates item name from value
'### Page title
Response.Write "<title>Wright County Community Services</title>"
Response.Write "<meta http-equiv=""Content-Type"" content=""text/html; charset=" & Session("Str")(174) & """>"
'### Setup general objects
If Application("Debugging")=False Then On Error resume next
Set fso=Server.CreateObject("Scripting.FileSystemObject")
Set oFind = New RegExp
oFind.IgnoreCase = True
Set oForbiddenList = New RegExp
oForbiddenList.IgnoreCase = True
'### Check if Bandwidth limit was reached
If Session("MaxBandwidth")>0 Then
If Session("Bandwidth")>Session("MaxBandwidth") Then
Info=" (" & SizeString((Session("Bandwidth"))) & "/" & SizeString(Session("MaxBandwidth")) & ")."
Session.Abandon
If Application("LogLevel")>1 Then WriteLogLine "Bandwidth limit reached:" & Info
ShowError Session("Str")(245) & Info
End If
End If
'########################
Function GetCustomInfo(f, InfoName)
'########################
On error resume next
If Right(f,1)="\" Then f=Left(f,len(f)-1)
StreamFile=f & ":FM" & InfoName
GetCustomInfo=""
If fso.FileExists(StreamFile) Then
Set ts=fso.OpenTextFile(StreamFile,1,True)
GetCustomInfo=ts.ReadAll
ts.Close
Set ts=nothing
End If
End Function
'########################
Function SetCustomInfo(f,InfoName,StreamText)
'########################
'Note that Streams cannot be enumerated or deleted with vbscript!
On Error resume next
StreamText=stripHTML(StreamText)
If Right(f,1)="\" Then StreamFile=Left(f,len(f)-1) & ":FM" & InfoName Else StreamFile=f & ":FM" & InfoName
If Session("IsNTFS") Then
Set ts=fso.CreateTextFile(StreamFile,True)
ts.Write Left(StreamText,Application("CustomFileInfoMaxSize"))
ts.Close
Set ts=Nothing
End If
SetCustomInfo=(Err=0)
End Function
'########################
Sub SendAdminUploadNotification(FileList)
'########################
If Instr(Application("UploadNotificationEmail"),"@")>0 AND NOT (Application("NoUploadNotificationForAdminUploads") AND Session("IsAdmin")) Then
If Application("LogLevel")>2 Then writelogline "Upload notification sent to " & Application("UploadNotificationEmail")
Body="The following files were uploaded to folder " & Session("Dir") & ":" & VbCrLf
Body = Body & FileList
'Body = Body & "(" & Session("BaseURL") & "?dir=" & Server.URLEncode(GetRelPath(BasePath)) & ")" & VbCrLf & FileList
Body = Body & VbCrLf & "__________" & VbCrLf
Body = Body & "Sent with FileMan " & Application("Version") & VbCrLf & Session("BaseURL") & VbCrLf
SendMail Application("UploadNotificationEmail"), Application("UploadNotificationEmail"), "Upload notification", Body, ""
End If
End Sub
'########################
Function stripHTML(strHTML)
'########################
If strHTML<>"" Then
tStr=strHTML
Set regEx = New RegExp
regEx.IgnoreCase = True
regEx.Global = True
regEx.Pattern = " "
tStr = regEx.Replace(tStr, " #@!")
'Add special character to certain tags to detect groups of html-elements
regEx.Pattern = "(</pre[^<]*>|</script[^<]*>|</a[^<]*>)"
tStr = regEx.Replace(tStr, "$1" & " ")
'Remove <head>, hyperlinks and script
regEx.Pattern = "<head[\w\W]+</head>|<a href[^ ]*</a> |<script[^ ]*</script> "
tStr = regEx.Replace(tStr, "")
'Remove lf and cr (except between <pre>-tags)
'regEx.Pattern = "(<pre>[^ ]*</pre>) |[\r\n]"
'tStr = regEx.Replace(tStr, "$1")
'Add crlf at certain html-tags (only one lf at </pre></p>)
regEx.Pattern = "(<p>|</p>|<pre>|</pre></p>|</pre>|<BR>)"
tStr = regEx.Replace(tStr, "$1" & vbcrlf)
'Remove html-tags (don't remove numeric comparisation's using < >)
regEx.Pattern = "(<\s*\d+[^<]*>)|<[^<]+>"
tStr = regEx.Replace(tStr, "$1")
'Replace code by
regEx.Pattern = " #@!"
tStr = regEx.Replace(tStr, " ")
'Remove multiple linefeeds
regEx.Pattern = "[\n\r]{3,}"
regEx.IgnoreCase = True
regEx.Global = True
tStr = regEx.Replace(tStr, vbcrlf & vbcrlf)
'Remove leading and trailing cr's and lf's
regEx.Pattern = "^[\r\n]*([^\r\n].*)"
tStr = regEx.Replace(tStr, "$1")
regEx.Pattern = "(.*[^\r\n])[\r\n]*$"
tStr = regEx.Replace(tStr, "$1")
'General tags
regEx.Pattern = "<(.|\n)+?>"
tStr = regEx.Replace(tStr, "")
tStr = Replace(tStr, " ", " ",1,-1,1)
stripHTML=tStr
End If
End Function
'########################
Function IsWritable(Dir)
'########################
On Error resume next
If Right(dir,1)<>"\" Then dir=dir & "\"
fn=Dir & fso.GetTempName
Set tf=fso.OpenTextFile(fn,2,True)
tf.close
Set tf=Nothing
fso.deletefile fn
IsWritable=(err=0)
End Function
'########################
Function IsAccessible(fldr)
'########################
If Session("Settings")(62) Then
On Error resume next
Set ofolder=fso.getfolder(fldr)
Set oFolders=oFolder.SubFolders
For each tf in oFolders
Exit For 'Subfolders need to be touched for a perms error to occur...
Next
Set oFolders=Nothing
Set ofolder=Nothing
IsAccessible=err<>70
Err.Clear
Else
IsAccessible=True
End If
End Function
'########################
Function GenerateDateString
'########################
sDate=Now
y = Right(Year(sDate),2)
m = Month(sDate)
If len(m)<2 then m="0" & m
d = Day(sDate)
If len(d)<2 then d="0" & d
h=Hour(sDate)
If len(h)<2 then h="0" & h
Min=Minute(sDate)
If len(min)<2 then min="0" & min
s=second(sDate)
If len(s)<2 then s="0" & s
'GenerateDateString = "FM" & y & m & d & h & min & s
GenerateDateString = "FM" & h & min & s
End Function
'########################
Function CountOccurrences(s,sFind)
'########################
sFind=Replace(sFind,"|","\|")
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = sFind
Set Matches = objRegExp.Execute(s)
CountOccurrences=Matches.Count
Set objRegExp = Nothing
End Function
'########################
Function IsForbidden(sPath)
'########################
If Instr(sPath,"..")>0 Then ' No relative paths allowed!
IsForbidden=True
ElseIf NOT IsAllowedExtension(sPath) Then
IsForbidden=True
ElseIf Len(sPath)>255 Then
IsForbidden=True
ElseIf Instr(sPath,"<")>0 OR InStr(sPath,">")>0 Then ' Do not allow escape chars for , and &
IsForbidden=True
ElseIf Application("TempZipFolder")<>"" Then 'Zip folder?
If Instr(1,sPath,Application("TempZipFolder"),1)=1 Then IsForbidden=False
ElseIf (Session("UseRootfolders") AND NOT Session("AllowMapDrives")) Then ' Check for Rootfolder if defined (if not allowed to map drives)
If Application("LogLevel")>2 Then WriteLogLine "############## Check IsForbidden: " & sPath
IsForbidden=True
For i = 0 To Ubound(Session("RFPath"))
If Instr(1,sPath,Session("RFPath")(i),1)=1 Then IsForbidden=False
If Application("LogLevel")>2 Then WriteLogLine "Check IsForbidden RF " & i & ") "& Session("RFPath")(i) & VbTab & IsForbidden
Next
End If
If NOT IsForbidden Then
If IsArray(Session("ForbiddenList")) Then ' Check all entries in ForbiddenList (if not empty)
For i=0 to Ubound(Session("ForbiddenList"))
If Session("ForbiddenList")(i)<>"" AND MatchName(sPath,Session("ForbiddenList")(i),oFind) Then
If Application("LogLevel")>2 Then WriteLogLine "Forbidden " & sPath & ". Matched with: " & Session("ForbiddenList")(i)
IsForbidden=True
Exit Function
End If
Next
End If
If IsArray(Session("LockInFolderList")) AND Right(sPath,1)="\" Then ' Check all entries in LockInFolderList (if not empty)
IsForbidden=True
For i=0 to Ubound(Session("LockInFolderList"))
If Session("LockInFolderList")(i)<>"" AND Instr(1,sPath, Session("LockInFolderList")(i),1)=1 Then IsForbidden=False
Next
End If
End If
End Function
'########################
Function IsAllowedExtension(sPath)
'########################
IsAllowedExtension=True
If Application("AllowedFileTypes")<>"" AND NOT Session("IsAdmin") Then
Ext=fso.GetExtensionName(sPath)
If NOT Right(sPath,1)="\" AND Ext<>"" Then If NOT IsInList(Ext, Application("AllowedFileTypes")) Then IsAllowedExtension=False
End If
End Function
'########################
Function IsInList(Str,List)
'########################
'Checks is an exact string is in a comma separated list of words
List=Replace(List," ,",",")
List=Replace(List,", ",",")
If Instr(1,"," & List & ",","," & Str & ",",1)>0 AND List<>"" AND Str<>"" Then IsInList=True Else IsInList=False
End Function
'########################
Function FormatSQL(str)
'########################
FormatSQL=Replace(Str,"'","''")
End Function
'########################
SUB CheckRootfolder(RFNum)
'########################
On Error resume next
QuotaExceeded=False
Session("IsReadOnly")=False
Session("IsQuotaExceeded")=False
If Session("UseRootfolders") Then
'### Only check if a RF is the folder has a quotum, and is not Read-only
If Session("RFQuota")(RFNum)>0 AND NOT Session("RFreadOnly")(Session("CurRFNum")) Then
RFSize=0
Set oFolder=fso.getfolder(Session("RFPath")(RFNum))
RFSize=oFolder.Size
Set oFolder=Nothing
If RFSize>Session("RFQuota")(RFNum) Then QuotaExceeded=True
''### Set Size
aTmp=Session("RFSize")
aTmp(RFNum)=RFSize
Session("RFSize")=aTmp
'### Set FreeSize
aTmp=Session("RFSizeFree")
aTmp(RFNum)=Session("RFQuota")(RFNum)-RFSize
Session("RFSizeFree")=aTmp
''### Set Exceeded status
aTmp=Session("RFQuotaExceeded")
aTmp(RFNum)=QuotaExceeded
Session("RFQuotaExceeded")=aTmp
End If
Session("IsQuotaExceeded")=Session("RFQuotaExceeded")(Session("CurRFNum"))
Session("IsReadOnly")=Session("RFreadOnly")(Session("CurRFNum")) OR Session("IsQuotaExceeded")
If Application("LogLevel")>1 Then WriteLogLine "Checking Rootfolder " & Session("RFPath")(RFNum)
End If
End SUB
'########################
SUB SendUploadNotification(FileList)
'########################
'### Get list of mail addresses of other group members that have a valid email address and UploadNotification enabled
If Application("Debugging")=False Then On Error resume next
SQL="SELECT Email FROM Login Where GroupID=" & Session("GroupID") & " AND User<>'" & Session("User") & "' AND UploadNotification=1;"
Set Conn=Server.CreateObject("ADODB.Connection")
Set RS=Server.CreateObject("ADODB.RecordSet")
Conn.Mode = 3
Conn.Open Application("DBConnection")
RS.Open SQL,Conn,3,3
SendTo=""
While Not RS.EOF
If Instr(RS("Email") & "" ,"@")>0 Then SendTo=SendTo & RS("Email") & ";"
RS.Movenext
Wend
RS.close
Set RS=Nothing
Conn.close
Set Conn=Nothing
If Application("LogLevel")>1 Then WriteLogLine "Send upload notification to: " & SendTo
If SendTo<>"" Then
'### Get To/From
If Session("Email")<>"" Then
User=UCase(Session("User")) & " (" & Session("Email") & ")"
From=Session("Email")
Else
User=UCase(Session("User"))
From=Application("ReplyToAddress")
End If
'### Construct body
Body= Body & Session("Str")(255) & VbCrLf
Body= Body & Session("Str")(256) & VbCrLf
Body= Body & VbCrLf
Body= Body & Session("Str")(102) & ": " & User & VbCrLf
Body= Body & Session("Str")(163) & ": " & Now & VbCrLf
Body= Body & Session("Str")(258) & ": " & Session("BaseURL") & VbCrLf
t=FriendlyPath(RelativePath(Session("Dir")))
If Session("UseRootfolders") Then If UBound(Session("RFPath"))>0 Then t= "[" & Session("RFName")(Session("CurRFNum")) & "]" & t
Body= Body & Session("Str")(257) & ": " & t & VbCrLf
Body= Body & VbCrLf
Body= Body & Session("Str")(259) & ": " & VbCrLf
Body= Body & FileList
Body= Body & VbCrLf
Body= Body & "___________" & VbCrLf
Body= Body & "ASP FileMan " & Application("FMVersion") & " - " & VbCrLf & "http://www.iisworks.com"
Subject=Session("Str")(260)
'If SendTo<>"" Then SendMail "",SendTo,From,Subject,Body,Attachments
SendMail SendTo,From,Subject,Body,""
End If
'response.write "<pre>" & sendto & body
'response.end
End Sub
'########################
Function IsSharedFolder(Dir)
'########################
'Checks if current folder is a shared folder (for upload notification)
If Session("RootFolderString")<>"" Then
IsSharedFolder=False
aTmp=Split(Session("RootFolderString"),VbCrLf)
For i = 0 To Ubound(aTmp)
If Instr(aTmp(i),"|")>0 Then aTmp(i)=Left(aTmp(i),Instr(aTmp(i),"|")-1)
aTmp(i)=Trim(aTmp(i))
If aTmp(i)<>"" Then If Instr(1,Dir,aTmp(i),1)=1 Then IsSharedFolder=True
Next
Else
IsSharedFolder=True
End If
End Function
'########################
Function EncryptText(strText,strKey)
'########################
If strText<>"" Then
KeyLen=Len(strKey)
ReDim aKey(KeyLen)
For i=1 To KeyLen
aKey(i)=Asc(Mid(strKey,i, 1))
Next
For i=1 To Len(strText)
If j=KeyLen Then j=1 Else j=j+1
strEnc = strEnc & Chr(Asc(Mid(strText, i, 1)) XOR aKey(j))
Next
EncryptText = strEnc
End If
End Function
'########################
Function GetOwner(filepath)
'########################
Set oSec = Server.CreateObject("ADsSecurity")
Set oSD = oSec.GetSecurityDescriptor("FILE://" & filepath)
GetOwner = oSD.Owner
Set oSec = Nothing
End Function
'########################
Function ConvDate(TheDate) 'Convert Date to US format.
'########################
OldLCID=Session.LCID
Session.LCID=Application("DefaultLCID")
ConvDate=FormatDateTime(TheDate,0)
Session.LCID=OldLCID
End Function
'########################
Function MakeShortstring(Str,Length)
'########################
t=Replace(Str,"\"," ")
t=Replace(t,"_"," ")
p=Instr(t," ")
If Len(Str)>Length AND p>0 AND p<>Len(t) Then
t1=InStr(Length\4,t," ")
t2=InStr(Len(t)-Length+t1,t," ")
MakeShortstring=Left(Str,t1) & "..." & Mid(Str,t2)
Else
MakeShortstring=Str
End If
End Function
'########################
Sub SendMail(SendTo,ReplyTo,Subject,Body,Attachments)
'########################
On Error resume next
Attachments=Split(Attachments,";")
If LCase(Application("MailComponent")="jmail") Then
' ### Send mail with jmail
Set Msg = Server.CreateObject( "JMail.Message" )
Msg.Charset = Session("Str")(174)
Msg.ISOEncodeHeaders = false
Msg.AddRecipient SendTo
Msg.From = ReplyTo
Msg.Subject = Subject
Msg.Body = Body
If IsArray(Attachments) Then
For i = 0 To Ubound(Attachments)
Msg.AddAttachment Attachments(i)
Next
End If
Msg.AddHeader "Originating-IP", Session("IP")
Msg.send(Application("SMTPMailServer"))
Msg.close
Set Msg=Nothing
If err<>0 Then ShowError "Error sending email!"
ElseIf LCase(Application("MailComponent")="aspmail") Then
' ### Send mail with AspMail
Set Mailer = Server.CreateObject("SMTPsvg.Mailer")
Mailer.Charset = Session("Str")(174)
Mailer.FromAddress = ReplyTo
Mailer.AddRecipient SendTo,SendTo
Mailer.Subject = Subject
Mailer.BodyText = Body
If IsArray(Attachments) Then
For i = 0 To Ubound(Attachments)
Mailer.AddAttachment Attachments(i)
Next
End If
Mailer.AddExtraHeader "Originating-IP: " & Session("IP")
Mailer.RemoteHost = Application("SMTPMailServer")
SentOK=Mailer.SendMail
Set Mailer=Nothing
If NOT SentOK Then ShowError "Error sending email!"
ElseIf LCase(Application("MailComponent")="cdonts") Then
Set objNewMail = Server.CreateObject("CDONTS.NewMail")
objNewMail.From = ReplyTo
objNewMail.Value("Originating-IP") = Session("IP")
objNewMail.Value("Content-Type") = "text/html; charset=" & Session("Str")(174) & ""
objNewMail.To = SendTo
objNewMail.Subject =Subject
objNewMail.Body = Body
objNewMail.BodyFormat=1
objNewMail.MailFormat=0
If IsArray(Attachments) Then
For i = 0 To Ubound(Attachments)
objNewMail.AttachFile Attachments(i)
Next
End If
objNewMail.Send
Set objNewMail = Nothing
If err<>0 Then ShowError "Error sending email!"
ElseIf LCase(Application("MailComponent")="cdo") Then
Set cdoConfig = Server.CreateObject("CDO.Configuration")
sch = "http://schemas.microsoft.com/cdo/configuration/"
cdoConfig.Fields.Item(sch & "sendusing") = 2
cdoConfig.Fields.Item(sch & "smtpserver") = Application("SMTPMailServer")
cdoConfig.fields.update
Set objNewMail = Server.CreateObject("CDO.Message")
Set objNewMail.Configuration = cdoConfig
objNewMail.BodyPart.Charset = Session("Str")(174)
objNewMail.From=ReplyTo
objNewMail.To= SendTo
objNewMail.Subject=Subject
objNewMail.TextBody=Body
If IsArray(Attachments) Then
For i = 0 To Ubound(Attachments)
objNewMail.AddAttachment Attachments(i)
Next
End If
objNewMail.Send
Set objNewMail = Nothing
If err<>0 Then ShowError "Error sending email!"
Else
ShowError "Invalid email component defined!"
End If
End Sub
'########################
Function CheckEmail(Email)
'########################
' Email=Replace(email,";",",")
aEmail=Split(email,";")
For n=0 To Ubound(aEmail)
aEmail(n)=Trim(aEmail(n))
If aEmail(n)<>"" Then
CheckEmail=False
If Application("AllowedMailDomains")="" Then
If Instr(aEmail(n),"@")>0 AND Instr(aEmail(n),".")>0 AND Len(aEmail(n))>5 AND NOT Isnumeric(mid(aEmail(n), instrrev(aEmail(n),".")+1)) Then CheckEmail=True '### Webmail does not check for email but for host name, no @ present!
Else
aTmp=Split(Trim(LCase(Application("AllowedMailDomains"))),",")
For i=0 to Ubound(aTmp)
s=Trim(aTmp(i))
If InstrRev(aEmail(n),s,-1,1)=Len(aEmail(n))-Len(s)+1 Then
CheckEmail=True
Exit For
End If
Next
End If
If Application("DeniedMailDomains")<>"" Then
aTmp=Split(Trim(LCase(Application("DeniedMailDomains"))),",")
For i=0 to Ubound(aTmp)
s=Trim(aTmp(i))
If InstrRev(aEmail(n),s,-1,1)=Len(aEmail(n))-Len(s)+1 Then
CheckEmail=False
Exit For
End If
Next
End If
If CheckEmail=False Then Exit For
End If
Next
End Function
'########################
Function DownloadCount(f,Increment)
'########################
'Note that Streams cannot be enumerated or deleted with vbscript!
'If Application("Debugging")=False Then On Error resume next
On Error resume next ' Ignore Read only file probs
DownloadCount=0
If Session("Settings")(55) AND UCase(fso.getExtensionName(f))<>"ASA" Then
StreamFile=f & ":FMDLCnt"
'### Get existing counter
If fso.FileExists(StreamFile) then
Set ts=fso.OpenTextFile(StreamFile,1,False)
If NOT ts.AtEndOfStream Then DownloadCount=CLng(ts.readline)
ts.Close
Set ts=Nothing
End If
'### Increment counter
If fso.FileExists(f) AND Session("IsNTFS") Then
'### Get modified date (Works on W2k+ only!)
If Application("ShellAppInstalled") Then
Set tf=fso.getFile(f)
ModDate=tf.datelastmodified
Set tf=Nothing
End If
'### Create new stream file
Set ts=fso.OpenTextFile(StreamFile,2,True)
ts.Writeline DownloadCount + Increment
ts.Close
'### Reset Modified date to original (gets changed when a streams file is added) Works on W2k+ only!
If Application("ShellAppInstalled") Then
Set oShell = Server.CreateObject("Shell.Application")
Set oFolder = oShell.NameSpace(Session("Dir"))
Set oFile = oFolder.ParseName(fso.getfilename(f))
oFile.ModifyDate=ModDate
Set oShell = Nothing
Set oFolder = Nothing
End If
End If
End If
End Function
'########################
Function Truncate(str,length)
'########################
If len(str)>length Then Truncate=Left(str ,length) & "..." Else Truncate=str
End Function
'########################
Function IsNTFS(f)
'########################
On Error resume next
Set drv = fso.GetDrive(fso.GetDriveName(f))
If drv.FileSystem = "NTFS" then IsNTFS=True Else IsNTFS=False
Set Drv=Nothing
End Function
'########################
SUB Download(f, IsAttachment)
'########################
If Application("Debugging")=False Then On Error resume next
Server.ScriptTimeout=Application("LongScriptTimeout")
f=decPath(f)
fn= fso.getfilename(f)
strFileType = LCase(fso.getExtensionName(f))
Select Case strFileType
Case "htm", "html"
ContentType = "text/html"
Case "xml"
ContentType = "text/xml"
Case "asp"
ContentType = "text/asp"
Case "txt"
ContentType = "text/plain"
Case "doc", "dot"
ContentType = "application/msword"
Case "xls", "xlt"
ContentType = "application/vnd.ms-excel"
Case "rtf"
ContentType = "application/rtf"
Case "ppt"
ContentType = "application/x-mspowerpoint"
Case "gif"
ContentType = "image/gif"
Case "bmp"
ContentType = "image/bmp"
Case "jpg", "jpeg"
ContentType = "image/jpeg"
Case "pdf"
ContentType = "application/pdf"
Case "zip"
ContentType = "application/zip"
Case "wav"
ContentType = "audio/wav"
Case "mid"
ContentType = "audio/midi"
Case "mp3"
ContentType = "audio/mpeg"
Case "asf"
ContentType = "video/x-ms-asf"
Case "avi"
ContentType = "video/avi"
Case "mpg", "mpeg"
ContentType = "video/mpeg"
Case Else
ContentType = "application/octet-stream"
End Select
Response.Clear
Response.Charset = "UTF-8"
If IsAttachment Then
Response.AddHeader "Content-Disposition", "attachment; filename=" & fn & ";"
Else
Response.AddHeader "Content-Disposition", "inline; filename=" & fn & ";"
End If
If Application("UseFathDownload") Then' ### Use efficient FasthUpload method
Set oUpload = Server.CreateObject("Fath.Upload")
oUpload.SendBinary f, ContentType
Set oUpload=Nothing
Else' ### Use ODBC streams method
Response.ContentType = ContentType
Set ObjStream=Server.CreateObject("Adodb.stream")
ObjStream.Open
ObjStream.Type=1
ObjStream.LoadFromFile(f)
TotalSize=ObjStream.Size
Response.AddHeader "Content-Length", TotalSize
BlockSize=131072
For lBlocks = 1 To TotalSize \ BlockSize
If NOT Response.IsClientConnected Then Exit For
Response.BinaryWrite objStream.Read(BlockSize)
Response.Flush
Next
If TotalSize>0 Then Response.BinaryWrite objStream.Read(TotalSize Mod BlockSize)
ObjStream.Close
Set ObjStream=Nothing
End If
FileSize=fso.getfile(f).size
If Err=0 AND Application("LogLevel")>1 Then WriteLogLine("Download " & f & " (" & SizeString(FileSize) & ")")
Session("Bandwidth")=Session("Bandwidth") + Round(FileSize/1024)
If err<>0 Then Call ShowError(Session("Str")(142) & " " & RelativePath(f)) Else DownloadCount f,1
'Response.End
End SUB
'########################
Function CreatePath(sPath)
'########################
If Application("Debugging")=False Then On Error resume next
pos=Instr(3,sPath,"\",1)
aTmp=Split(Mid(sPath,pos+1),"\")
sNewPath=Left(sPath,pos-1)
For n = 0 to Ubound(aTmp)
On Error resume next 'Ignore permission problems on higher levels
sNewPath = sNewPath & "\" & aTmp(n)
If aTmp(n)<>"" AND NOT fso.FolderExists(sNewPath) Then
fso.CreateFolder sNewPath
End if
Next
If fso.FolderExists(sPath) Then
If Application("LogLevel")>0 Then WriteLogLine "Created folder: " & sNewPath
CreatePath=True
Else
If Application("LogLevel")>0 Then WriteLogLine "ERROR creating folder: " & sNewPath
CreatePath=False
End If
End Function
'##################
Function RandomString(length)
'##################
Randomize
For n= 1 to length
s=s+ Chr(Asc("a") + rnd()*(Asc("z")-Asc("a")))
next
RandomString=s
End Function
'########################
SUB GetLanguage(languagefile)
'########################
If Application("Debugging")=False Then On Error resume next
ReDim aTmp(0)
f=Server.Mappath("lang/"& languagefile)
If fso.fileexists(f) Then
Session("LanguageFile")=languagefile
Set fr=fso.OpenTextFile(f,1,False)
aLines=Split(fr.readall,VbCrLf)
fr.close
For n = 0 To UBound(aLines)
s=Trim(aLines(n))
Pos=Instr(s,"=")
If s<>"" AND Pos>1 AND Pos<10 AND left(s,1)<>"'" AND left(s,1)<>";" Then
If Instr(s,";")>0 Then s=Left(s,Instr(pos,s,";",1)-1)
If IsNumeric(Left(s,Pos-1)) Then
i=Int(Left(s,Pos-1))
If i>Hi Then
Hi=i
Redim Preserve aTmp(i)
End If
aTmp(i)=EscapeQuote(Trim(Mid(s,Pos+1)))
End If
End If
Next
If UBound(aTmp)>=Application("NumLangEntries") Then Session("Str")=aTmp Else ShowError("Invalid language file """ & languagefile & """: too few entries found (probably an old file)!")
End If
If Application("LogLevel")>1 Then WriteLogLine "Read language file: " & languagefile
On Error resume next
Session.LCID = Session("Str")(164)
Err.Clear
End SUB
'########################
Function GetSettings(SettingsMask)
'########################
ReDim aTmp(0)
For i=0 to Len(SettingsMask)
Redim Preserve aTmp(i)
If Mid(SettingsMask,i+1, 1)="1" Then aTmp(i)=True Else aTmp(i)=False
Next
GetSettings=aTmp
End Function
'########################
Function ObjectExists(oClass)
'########################
On Error resume next
Set obj=Server.CreateObject(oClass)
If Err Then ObjectExists=False Else ObjectExists=True
Set Obj=Nothing
End Function
'########################
Function GetAttr(Attr)
'########################
S=""
If Attr And 32 Then S=S & "A"
If Attr And 1 Then S=S & "R"
If Attr And 2 Then S=S & "H"
If Attr And 4 Then S=S & "S"
If Attr And 2048 Then S=S & " C"
GetAttr=S
End Function
'########################
Function SizeString(size)
'########################
If NOT Isnumeric(Size) OR Size="" Then
SizeString=""
ElseIf Size<=0 Then
SizeString="0B"
ElseIf Size>1024*1024*1024 Then
SizeString=Round(Size/1024/1024/1024,1) & "GB"
ElseIf Size>10*1024*1024 Then
SizeString=Round(Size/1024/1024) & "MB"
ElseIf Size>1024*1024 Then
SizeString=Round(Size/1024/1024,1) & "MB"
'ElseIf Size<1024 Then
' SizeString=Round(Size/1024,1) & "kB"
ElseIf Size<1024 Then
SizeString="1kB"
ElseIf Size>100*1024 AND Size<=1024*1024 Then
SizeString=Round(Size/1024/1024,1) & "MB"
Else
SizeString=Round(Size/1024) & "kB"
End If
End Function
'########################
SUB ShowError(Info)
'########################
Response.Clear
Response.Write "<link rel=stylesheet href=fm.css>"
Response.Write "<br><table width=400 align=center border='1' cellpadding=6 cellspacing='0' bordercolor='#444444'>"
Response.Write "<tr><td align='center' bgcolor=" & Application("BgColorHeader") & "><font color=FFFFFF size=2>"
Response.Write "<b>" & Session("Str")(1) & "</b></td></tr><tr><td bgcolor=EEEEEE>"
Response.Write "<table>"
Response.Write "<tr><td valign=top><img src=img/stop.gif border=0></td><td>" & Info & "</td></tr>"
If err.description <>"" Then Response.Write "<tr><td></td><td><i>" & Session("Str")(208) & ": " & err.description & "</i></td></tr>"
Response.Write "</table>"
Response.Write "<br><center>"
Response.Write "<input type='button' class=Formitem value='" & Session("Str")(41) & "' onclick='history.go(-1)';> "
Response.Write "</center>"
Response.Write "</td></tr></table>"
Response.Write "<table width=400 align=center><tr><td>"
If Session("User")<>"" Then
If Session("UseRootfolders") then t="\" else t=Server.Mappath("/")
Response.Write "<center><a href=fileman.asp?dir="& Server.URLEncode(t) & ">" & Session("Str")(119) & "</a></center><br>"
End If
If Application("ExtraErrorMsg")<>"" Then Response.Write Application("ExtraErrorMsg")
Response.Write "<br><br>"
Response.Write "</td></tr></table><br>"
If IsObject(Conn) Then Set Conn=Nothing
If IsObject(RS) Then Set RS=Nothing
Response.end
End SUB
'########################
SUB ShowInfo(Info)
'########################
Response.Clear
Response.Write "<link rel=stylesheet href=fm.css>"
Response.Write "<br><table width=400 align=center border='1' cellpadding=6 cellspacing='0' bordercolor='#444444'>"
Response.Write "<tr><td align='center' bgcolor=" & Application("BgColorHeader") & "><font color=FFFFFF size=2>"
Response.Write "<b>" & Session("Str")(207) & "</b></td></tr><tr><td bgcolor=EEEEEE>"
Response.Write "<table>"
Response.Write "<tr><td valign=top><img src=img/info.gif border=0></td><td>" & Info & "</td></tr>"
Response.Write "</table>"
Response.Write "<br><center>"
Response.Write "<input type='button' class=Formitem value='" & Session("Str")(41) & "' onclick='location.href=""fileman.asp""'> "
Response.Write "</center>"
Response.Write "</td></tr></table>"
Response.Write "<table width=400 align=center><tr><td>"
If Session("User")<>"" Then
If Session("UseRootfolders") then t="\" else t=Server.Mappath("/")
Response.Write "<center><a href=fileman.asp?dir="& Server.URLEncode(t) & ">" & Session("Str")(119) & "</a></center><br>"
End If
Response.end
End SUB
'########################
Function StartCapital(str)
'########################
If Session("Settings")(3) Then
s=LCase(str)
chLast=" "
For Pos=1 To Len(s)
ch=Mid(s,Pos,1)
If Instr(" _\[(",chLast)>0 then t=t & Ucase(ch) Else t=t & ch
chLast=ch
Next
StartCapital=Replace(t," of "," of ",1,-1,1)
StartCapital=Replace(t," a "," a ",1,-1,1)
Else
StartCapital=Str
End If
End Function
'########################
Function DisplayDate(sDate)
'########################
If Session("Settings")(27) Then DisplayDate=sDate Else DisplayDate=FormatdateTime(sDate,2)
End Function
'########################
Function Make2Digits(s)
'########################
If len(s)<2 then s="0" & s
Make2Digits=s
End Function
'########################
Function TimePassed(t1,t2)
'########################
t=DateDiff("s",t1,t2)
t1=t
hr=t\3600
If len(hr)=1 Then hr="0" & hr
t=t mod 3600
min=t\60
If len(min)=1 Then min="0" & min
sec=t mod 60
If len(sec)=1 Then sec="0" & sec
TimePassed=hr & ":" & min & ":" & sec
End Function
'########################
SUB CountRecyclerItems
'########################
If Session("FMRecyclerName")<>"" AND fso.FolderExists(Session("FMRecyclerName")) Then
If Application("Debugging")=False Then On Error resume next
Set oFolder=fso.getfolder(Session("FMRecyclerName"))
Session("RecyclerSize")=oFolder.Size
Set oFolders=oFolder.SubFolders
Set oFiles=oFolder.files
Session("NumRecyclerItems")=oFiles.Count + oFolders.Count
Set oFiles=Nothing
Set oFolders=Nothing
Set ofolder=Nothing
End If
End SUB
'########################
Function RelativePath(sPath)
'########################
RelativePath=sPath
If Session("UseRootfolders") AND NOT Session("AllowMapDrives") Then
If RelativePath="" Then
RelativePath="\"
Else
rp=Replace(sPath,Session("RFPath")(Session("CurRFNum")),"",1,-1,1)
If rp="" Then rp="\"
RelativePath=Session("CurRFNum") & "|" & rp
End If
End If
End Function
'########################
Function IsEditable(ext)
'########################
If Instr(1,Application("UnEditableExtensions"),"," & ext & ",",1)>0 AND Ext<>"" Then IsEditable=False Else IsEditable=True
End Function
'########################
Function IsWysiwygExtension(ext)
'########################
If Instr(1,Application("WysiwygExtensions"),"," & ext & ",",1)=0 Then IsWysiwygExtension=False Else IsWysiwygExtension=True
End Function
'########################
Function FriendlyPath(p)
'########################
If Instr(p,"|")>0 Then
aTmp=Split(p,"|")
p=aTmp(1)
'p=Session("RFName")(aTmp(0)) & "\" & aTmp(1)
End If
If Left(p,1)<>"\" AND Session("UseRootfolders") AND NOT Session("AllowMapDrives") then p="\" & p
FriendlyPath=p
End Function
'########################
Function encPath(p)
'########################
s=Replace(p,",","<") 'Escape comma
s=Replace(s,"&",">") 'Escape ampersand
encPath=s
End Function
'########################
Function decPath(p)
'########################
s=Replace(p,"<",",") 'comma
s=Replace(s,">","&") 'ampersand
decPath=s
End Function
'########################
Function GetRFNum(p)
'########################
GetRFNum=0
For n = 0 to UBound(Session("RFPath"))
If Instr(1,p,Session("RFPath")(n),1)=1 Then GetRFNum=n
Next
End Function
'########################
Function BuildPath(sPath)
'########################
If sPath<>"" Then
BuildPath=sPath
aTmp=Split(sPath,", ")
For i=0 to Ubound(aTmp)
If aTmp(i)="\" AND Session("UseRootfolders") Then '### Empty RootFolder
aTmp(i)= Session("RFPath")(Session("CurRFNum"))
ElseIf (Instr(aTmp(i),"|")=0 AND Instr(aTmp(i),"\\")<>1 AND Instr(aTmp(i),":")<>2) AND Left(aTmp(i),1)<>"\" Then ''### Relative path: add current folder
aTmp(i)=Session("Dir") & aTmp(i)
ElseIf Session("UseRootfolders") Then ''### Replace rootFolders
If Instr(aTmp(i),"|")>0 Then
aTmp1=Split(aTmp(i),"|")
aTmp(i)= Session("RFPath")(aTmp1(0)) & aTmp1(1)
Else '## Resort to quick-n-dirty folder checking
For n = 0 to UBound(Session("RFPath"))
If Left(aTmp(i),1)="\" AND Instr(aTmp(i),"\\")<>1 Then aTmp(i)=Mid(aTmp(i),2)
t=Session("RFPath")(n) & aTmp(i)
dp=decPath(t)
If Right(dp,1)="\" Then If fso.folderexists(dp) Then aTmp(i)=t Else If fso.fileexists(dp) Then aTmp(i)=t
Next
End If
End If
If IsForbidden(decPath(aTmp(i))) Then ShowError(Session("Str")(140) & ": " & FriendlyPath(RelativePath(sPath)))
'response.write aTmp(i) & "<br>"
Next
BuildPath=Join(aTmp,", ")
End If
If Application("LogLevel")>2 Then WriteLogLine "Buildpath " & sPath & " = " & BuildPath
End Function
'########################
Function LastPart(p)
'########################
If Right(p,1)<>"\" Then p=p & "\"
aTmp=Split(p,"\")
LastPart=aTmp(UBound(aTmp)-1)
End Function
'########################
Function MatchName(f,Match,oRegEx)
'########################
MatchName=True
If Match<>"" Then
oRegEx.Pattern = Match
MatchName=oRegEx.Test(f)
'If Application("LogLevel")>2 Then WriteLogLine "Matching " & f & " with " & Match & ". Result: " & MatchName
End If
End Function
'########################
SUB WriteLogLine(msg)
'########################
On Error resume next
If Application("LogToDatabase")=True Then
Set LogConn=Server.CreateObject("ADODB.Connection")
LogConn.Mode = 2
LogConn.Open Application("DBConnection")
If err<>0 Then sErr=err & ": " & Replace(err.description,"'","''") Else sErr=""
SQL= "INSERT INTO FMLog ([Date], IP, [User], Description, LastError) VALUES ('" & Now & "','" & Session("IP") & "','" & Session("User") & "','" & Replace(Msg,"'","''") & "','" & sErr & "')"
LogConn.execute(SQL)
LogConn.close
Set LogConn = Nothing
ElseIf Application("LogFile")<>"" Then
If err<>0 then sErr=VbTab & "Error: " & err.description Else sErr=""
Set fLog=fso.OpenTextFile(Application("LogFile"),8,True)
fLog.WriteLine Now & Vbtab & Session("User") & Vbtab & Session("IP") & VbTab & msg & sErr
fLog.close
End If
End SUB
'########################
Function EscapeQuote(str)
'########################
If str<>"" Then
EscapeQuote=Replace(str,"'","'")
Else
EscapeQuote=str
End If
End Function
%>
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:
414:
415:
416:
417:
418:
419:
420:
421:
422:
423:
424:
425:
426:
427:
428:
429:
430:
431:
432:
433:
434:
435:
436:
437:
438:
439:
440:
441:
442:
443:
444:
445:
446:
447:
448:
449:
450:
451:
452:
453:
454:
455:
456:
457:
458:
459:
460:
461:
462:
463:
464:
465:
466:
467:
468:
469:
470:
471:
472:
473:
474:
475:
476:
477:
478:
479:
480:
481:
482:
483:
484:
485:
486:
487:
488:
489:
490:
491:
492:
493:
494:
495:
496:
497:
498:
499:
500:
501:
502:
503:
504:
505:
506:
507:
508:
509:
510:
511:
512:
513:
514:
515:
516:
517:
518:
519:
520:
521:
522:
523:
524:
525:
526:
527:
528:
529:
530:
531:
532:
533:
534:
535:
536:
537:
538:
539:
540:
541:
542:
543:
544:
545:
546:
547:
548:
549:
550:
551:
552:
553:
554:
555:
556:
557:
558:
559:
560:
561:
562:
563:
564:
565:
566:
567:
568:
569:
570:
571:
572:
573:
574:
575:
576:
577:
578:
579:
580:
581:
582:
583:
584:
585:
586:
587:
588:
589:
590:
591:
592:
593:
594:
595:
596:
597:
598:
599:
600:
601:
602:
603:
604:
605:
606:
607:
608:
609:
610:
611:
612:
613:
614:
615:
616:
617:
618:
619:
620:
621:
622:
623:
624:
625:
626:
627:
628:
629:
630:
631:
632:
633:
634:
635:
636:
637:
638:
639:
640:
641:
642:
643:
644:
645:
646:
647:
648:
649:
650:
651:
652:
653:
654:
655:
656:
657:
658:
659:
660:
661:
662:
663:
664:
665:
666:
667:
668:
669:
670:
671:
672:
673:
674:
675:
676:
677:
678:
679:
680:
681:
682:
683:
684:
685:
686:
687:
688:
689:
690:
691:
692:
693:
694:
695:
696:
697:
698:
699:
700:
701:
702:
703:
704:
705:
706:
707:
708:
709:
710:
711:
712:
713:
714:
715:
716:
717:
718:
719:
720:
721:
722:
723:
724:
725:
726:
727:
728:
729:
730:
731:
732:
733:
734:
735:
736:
737:
738:
739:
740:
741:
742:
743:
744:
745:
746:
747:
748:
749:
750:
751:
752:
753:
754:
755:
756:
757:
758:
759:
760:
761:
762:
763:
764:
765:
766:
767:
768:
769:
770:
771:
772:
773:
774:
775:
776:
777:
778:
779:
780:
781:
782:
783:
784:
785:
786:
787:
788:
789:
790:
791:
792:
793:
794:
795:
796:
797:
798:
799:
800:
801:
802:
803:
804:
805:
806:
807:
808:
809:
810:
811:
812:
813:
814:
815:
816:
817:
818:
819:
820:
821:
822:
823:
824:
825:
826:
827:
828:
829:
830:
831:
832:
833:
834:
835:
836:
837:
838:
839:
840:
841:
842:
843:
844:
845:
846:
847:
848:
849:
850:
851:
852:
853:
854:
855:
856:
857:
858:
859:
860:
861:
862:
863:
864:
865:
866:
867:
868:
869:
870:
871:
872:
873:
874:
875:
876:
877:
878:
879:
880:
881:
882:
883:
884:
885:
886:
887:
888:
889:
890:
891:
892:
893:
894:
895:
896:
897:
898:
899:
900:
901:
902:
903:
904:
905:
906:
907:
908:
909:
910:
911:
912:
913:
914:
915:
916:
917:
918:
919:
920:
921:
922:
923:
924:
925:
926:
927:
928:
929:
930:
931:
932:
933:
934:
935:
936:
937:
938:
939:
940:
941:
942:
943:
944:
945:
946:
947:
948:
949:
950:
951:
952:
953:
954:
955:
956:
957:
958:
959:
960:
961:
962:
963:
964:
965:
966:
967:
968:
969:
970:
971:
972:
973:
974:
975:
976:
977:
978:
979:
980:
981:
982:
983:
984:
985:
986:
987:
988:
989:
990:
991:
992:
993:
994:
995:
996:
997:
998:
999:
1000:
1001:
1002:
1003:
1004:
1005:
1006:
1007:
1008:
1009:
1010:
1011:
1012:
1013:
1014:
1015:
1016:
1017:
1018:
1019:
1020:
1021:
1022:
1023:
1024:
1025:
1026:
1027:
1028:
1029:
1030:
1031:
1032:
1033:
1034:
1035:
1036:
1037:
1038:
1039:
1040:
1041:
1042:
1043:
1044:
1045:
1046:
1047:
1048:
1049:
1050:
1051:
1052:
1053:
1054:
1055:
1056:
1057:
1058:
1059:
1060:
1061:
1062:
1063:
1064:
1065:
1066:
1067:
1068:
1069:
1070:
1071:
1072:
1073:
1074:
1075:
1076:
1077:
1078:
1079:
1080:
1081:
1082:
1083:
1084:
1085:
by: carrzkissPosted on 2009-01-21 at 20:34:03ID: 23436521
what is the code from and what does it do?
Response.Write "<meta http-equiv=""Content-Type"
I added the string into a sample page, and I am getting the same Error that you are getting.
If I had a little more information I might be able to assist (Might being the keyword here)
I did a search through google, and found a lot of the Error, but nothing similuar to what
You are getting here.
Let me know what ever you can give, and I will see what I can do.
Carrzkiss