<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>

'True PureASP upload - enables save of uploaded text fields to the disk.

'c1997-1999 Antonin Foller, PSTRUH Software, http://www.pstruh.cz

'The file is part of ScriptUtilities library

'The file enables http upload to ASP without any components.

'But there is a small problem - ASP does not allow save binary data to the disk.

' So you can use the upload for :

' 1. Upload small text (or HTML) files to server-side disk (Save the data by filesystem object)

' 2. Upload binary/text files of any size to server-side database (RS("BinField") = Upload("FormField").Value

'All uploaded files and log file will be saved to the next folder :

Dim LogFolder

LogFolder = Server.MapPath(".")

'********************************** SaveUpload **********************************

'This function creates folder and saves contents of the source fields to the disk.

'The fields are saved as files with names of form-field names.

'Also writes one line to the log file with basic informations about upload.

Function SaveUpload(Fields, DestinationFolder, LogFolder)

if DestinationFolder = "" then DestinationFolder = Server.MapPath(".")

Dim UploadNumber, OutFileName, FS, OutFolder, TimeName, Field

Dim LogLine, pLogLine, OutLine

'Create unique upload folder

Application.Lock

if Application("UploadNumber") = "" then

Application("UploadNumber") = 1

else

Application("UploadNumber") = Application("UploadNumber") + 1

end if

UploadNumber = Application("UploadNumber")

Application.UnLock

TimeName = Right("0" & Year(Now), 2) & Right("0" & Month(Now), 2) & Right("0" & Day(Now), 2) & "_" & Right("0" & Hour(Now), 2) & Right("0" & Minute(Now), 2) & Right("0" & Second(Now), 2) & "-" & UploadNumber

Set FS = CreateObject("Scripting.FileSystemObject")

Set OutFolder = FS.CreateFolder(DestinationFolder + "\" + TimeName)

Dim TextStream

'Save the uploaded fields and create log line

For Each Field In Fields.Items

'Write content of the field to the disk

'!!!! This function uses FileSystemObject to save the file. !!!!!

'So you can only use text files to upload. Save binary files by the function takes undefined results.

'To upload binary files see ScriptUtilities, http://www.pstruh.cz

'You can save files with original file names :

'Set TextStream = FS.CreateTextFile(OutFolder & "\" & Field.FileName )

'Or with names of the fields

Set TextStream = FS.CreateTextFile(OutFolder & "\" & Field.Name & ".")

'And this is the problem why only short text files - BinaryToString uses char-to-char conversion. It takes a lot of computer time.

TextStream.Write BinaryToString(Field.Value) ' BinaryToString is in upload.inc.

TextStream.Close

'Create log line with info about the field

LogLine = LogLine & """" & LogF(Field.name) & LogSeparator & LogF(Field.Length) & LogSeparator & LogF(Field.ContentDisposition) & LogSeparator & LogF(Field.FileName) & LogSeparator & LogF(Field.ContentType) & """" & LogSeparator

'Creates line with global request info

pLogLine = pLogLine & Request.ServerVariables("REMOTE_ADDR") & LogSeparator

pLogLine = pLogLine & LogF(Request.ServerVariables("LOGON_USER")) & LogSeparator

pLogLine = pLogLine & Request.ServerVariables("HTTP_Content_Length") & LogSeparator

pLogLine = pLogLine & OutFolder & LogSeparator

pLogLine = pLogLine & LogLine

pLogLine = pLogLine & LogF(Request.ServerVariables("HTTP_USER_AGENT")) & LogSeparator

pLogLine = pLogLine & LogF(Request.ServerVariables("HTTP_COOKIE"))

'Create output line for the client

OutLine = OutLine & "Fields was saved to the <b>" & OutFolder & "</b> folder.<br>"

DoLog pLogLine, "UP"

OutFolder = Empty 'Clear variables.

SaveUpload = OutLine

End Function

'Writes one log line to the log file

Function DoLog(LogLine, LogPrefix)

if LogFolder = "" then LogFolder = Server.MapPath(".")

Const LogSeparator = ", "

Dim OutStream, FileName

FileName = LogPrefix & Right("0" & Year(Now), 2) & Right("0" & Month(Now), 2) & Right("0" & Day(Now), 2) & ".LOG"

Set OutStream = Server.CreateObject("Scripting.FileSystemObject").OpenTextFile(LogFolder & "\" & FileName, 8, True)

OutStream.WriteLine Now() & LogSeparator & LogLine

OutStream = Empty

End Function

'Returns field or "-" if field is empty

Function LogF(ByVal F)

If "" & F = "" Then LogF = "-" Else LogF = "" & F

End Function

'Returns field or "-" if field is empty

Function LogFn(ByVal F)

If "" & F = "" Then LogFn = "-" Else LogFn = formatnumber(F,0)

End Function

Dim Kernel, TickCount, KernelTime, UserTime

Sub BeginTimer()

on error resume next

Set Kernel = CreateObject("ScriptUtils.Kernel") 'Creates the Kernel object

'Get start times

TickCount = Kernel.TickCount

KernelTime = Kernel.CurrentThread.KernelTime

UserTime = Kernel.CurrentThread.UserTime

on error goto 0

End Sub

Sub EndTimer()

'Write times

on error resume next

Response.Write "<br>Script time : " & (Kernel.TickCount - TickCount) & " ms"

Response.Write "<br>Kernel time : " & CLng((Kernel.CurrentThread.KernelTime - KernelTime) * 86400000) & " ms"

Response.Write "<br>User time : " & CLng((Kernel.CurrentThread.UserTime - UserTime) * 86400000) & " ms"

on error goto 0

Kernel = Empty

End Sub

</SCRIPT>

下面的第一个例子为只是将客户端的文件上传到服务端的例子

第二个例子为将文件内容保存入数据库中。

文件fupload.asp

<%

dim ResultHTML

'Some value greater than default of 60s (According to upload size.)

'The maximum speed is about 100kB/s for IIS4, P200 and local upload, 4kB/s for modem users.

Server.ScriptTimeout = 400

If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'Request method must be "POST" for get the fields

' BeginTimer 'Starts timer.

'************************************************* Main Upload - start

Dim Fields

' on error resume next

'Set upload limit to 10M

UploadSizeLimit = 10000000

'Gets uploaded fields

Set Fields = GetUpload()

'There are all of form fields in the Fields object. Example :

'Fields("File1").ContentType - content type of File1 field

'Fields("File1").Value - Binary value of File1 field

ResultHTML = ""

If Err = 0 Then 'Upload was OK

'Write statistics about upload

dim Field

For Each Field In Fields.Items

ResultHTML = ResultHTML & "<br>Field : <b>" & LogF(Field.name) & "</b>, Length : <b>" & LogFn(Field.Length) & "</b>, Content-Type : <b>" & LogF(Field.ContentType) & "</b>, SourceFileName :?b>" & LogF(Field.FileName) & "</b>"

Next

'Saves the fields to the disk, writes result to the client and writes log.

'See utils.inc. You can change the function to save the files to another location.

ResultHTML = ResultHTML & "<BR>" & SaveUpload(Fields, Server.MapPath("."), LogFolder)

Else 'Error in upload. Write the error

ResultHTML = ResultHTML & "<br>Error : " & Err.Description

End If

On Error GoTo 0

Fields = Empty 'Clear the variable

'************************************************* Main Upload - end

' EndTimer 'Writes info about consumed time.

End If 'Request method must be "POST"

%>

<%'upload.inc, contains GetUpload function, Required for upload - only the one file%>

<!--#INCLUDE FILE="fupload.inc"-->

<%'utils.inc, contains SaveUpload function%>

<!--#INCLUDE FILE="futils.inc"-->

<%'format.inc, contains head and Foot function, optional.%>

<!--#INCLUDE FILE="fformat.inc"-->

<%=Head("Sample multiple binary files upload via ASP", "Demonstrates using of the ByteArray class for working with binary data from Request.BinaryRead.")%>

<Table>

<form method=post ENCTYPE="multipart/form-data">

<TR BGColor=Silver><TD></TD><TD Align=Right><input type="submit" Name="Action" value="Upload the files >>"></TD></TR>

<TR><TD ColSpan=2>

<Table Width=100% Border=0 cellpadding=0 cellspacing=0><tr><TD>

<Div ID=files>

File???input type="file" name="File1"><br>

File???input type="file" name="File2">

</Div>

<TD><TD Align=right VAlign=top>

<A style=cursor:hand onclick=return(Expand())><Font COlor=Blue><U>add a file</U></Font></a>

</TD></TR>

<TR><TD>Checkbox</TD><TD><input type="CHECKBOX" name="Check1" Checked></TD></TR>

<TR><TD>Password</TD><TD><input type="PASSWORD" name="PASSWORD"></TD></TR>

<TR><TD>Comments</TD><TD><input size="60" name="Comments" value="Some comments."></TD></TR>

<TR><TD>Description</TD><TD><textarea cols="60" rows="8" name="Description">Some long text of any size - without 80k limit of ASP Request.Form("...").</textarea></TD></TR>

</form>

</Table>

<HR>?%=ResultHTML%>

<Script>

var nfiles = 2;

function Expand(){

nfiles++

files.insertAdjacentHTML('BeforeEnd','<BR>File?+nfiles+'??input type="file" name="File'+nfiles+'">');

return false

}

</Script>

<%=Foot%>

文件fdbutl.asp将文件内容保存如数据库中

<%'upload.inc, contains GetUpload function, Required for upload - only the one file%>

<!--#INCLUDE FILE="fupload.inc"-->

<%'format.inc, contains head and Foot function, optional.%>

<!--#INCLUDE FILE="fformat.inc"-->

<%=Head("Sample database upload via ASP", "Demonstrates using of the ByteArray class for working with binary data from Request.BinaryRead.")%>

<Table>

<form method=post ENCTYPE="multipart/form-data">

<TR><TD></TD><TD Align=Right><input type="submit" Name="Action" value="Upload the file >>"></TD></TR>

<TR><TD>File to upload</TD><TD><input type="file" name="DBFile"></TD></TR>

<TR><TD>Title</TD><TD><input size="60" name="Title" value="Title of the file."></TD></TR>

<TR><TD>Description</TD><TD><textarea cols="60" rows="8" name="Description">Type description of the file.</textarea></TD></TR>

</form>

</Table>

<%=Foot%>

<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>

'Some value greater than default of 60s (According to upload size.)

'The maximum speed is about 100kB/s for IIS4, P200 and local upload, 4kB/s for modem users.

Server.ScriptTimeout = 200

If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'Request method must be "POST" for get the fields

'************************************************* Main Upload - start

Dim Fields

' on error resume next

'Gets uploaded fields

Set Fields = GetUpload()

'There are all of form fields in the Fields object. Example :

'Fields("File1").ContentType - content type of File1 field

'Fields("File1").Value.String - File1 field converted to a string

'Fields("File1").Value.ByteArray - File1 field as safearray to store in binary RS field or file

'Fields("Comments").Value.String - value of Comments field

If Err = 0 Then 'Upload was OK

'Saves fields to the database and returns result to the client.

Response.Write DBSaveUpload(Fields)

Else 'Error in upload. Write the error

Response.Write Err.Description

End If

On Error GoTo 0

Fields = Empty 'Clear the variable

'************************************************* Main Upload - end

End If 'Request method must be "POST"

function DBSaveUpload(Fields)

dim Conn, RS

Set Conn = GetConnection

Set RS = Server.CreateObject("ADODB.Recordset")

RS.Open "Upload", Conn, 2, 2

RS.AddNew

RS("UploadDT") = Now()

RS("RemoteIP") = Request.ServerVariables("REMOTE_ADDR")

RS("ContentType") = Fields("DBFile").ContentType

RS("SouceFileName") = Fields("DBFile").FileName

RS("Description") = BinaryToString(Fields("Description").Value)

RS("Title") = BinaryToString(Fields("Title").Value)

RS("Data").AppendChunk Fields("DBFile").Value

RS.Update

RS.Close

Conn.Close

DBSaveUpload = "<br>File <b>" & Fields("DBFile").FileName & "</b>, length : <b>" & Fields("DBFile").Length & " B</b> was saved to the database. "

end function

function GetConnection()

dim Conn, AuthConnectionString

Set Conn = Server.CreateObject("ADODB.Connection")

'MDB connection

AuthConnectionString = "DBQ=" & Server.MapPath(".") & "\fupload.mdb;DefaultDir=" & Server.MapPath("/") & ";" & _

"Driver={Microsoft Access Driver (*.mdb)}; DriverId=25;FIL=MS Access;MaxBufferSize=512;PageTimeout=5;UID=;"

Conn.open AuthConnectionString

'SQL connection

'Simply change connection and create table to upload to MS SQL

' Conn.Provider = "SQLOLEDB"

' Conn.Open "Server=(Local);Database=Auth", "sa", "password"

set GetConnection = Conn

end function

function CreateUploadTable(Conn)

dim SQL

SQL = SQL & "CREATE TABLE Upload ("

SQL = SQL & " UploadID int IDENTITY (1, 1) NOT NULL ,"

SQL = SQL & " UploadDT datetime NULL ,"

SQL = SQL & " RemoteIP char (15) NULL ,"

SQL = SQL & " ContentType char (64) NULL ,"

SQL = SQL & " SouceFileName varchar (255) NULL ,"

SQL = SQL & " Title varchar (255) NULL ,"

SQL = SQL & " Description text NULL ,"

SQL = SQL & " Data image NULL "

SQL = SQL & ")"

Conn.Execute SQL

end function

</SCRIPT>

文件fformat.inc

<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>

function Foot()

DIM HTML

HTML = "<hr><Table Border=0 Width=100%><TR><TD><font size=1>燬ample upload/download via ASP from <a href="http://www.pstruh.cz>PSTRUH" Software</a>.</font>"

HTML = HTML & "</td><td Align=right><Font Size=1><A HRef=http://www.pstruh.cz/help/ScptUtl/library.htm>Activex Upload</A>?A HRef=http://www.pstruh.cz/help/usrmgr/library.htm>ActiveX UserManager</A>?A HRef=http://www.pstruh.cz/help/RSConv/library.htm>DBF on-the-fly</A>?A HRef=http://www.pstruh.cz/help/tcpip/library.htm>ActiveX DNS+TraceRoute</A>?A HRef=http://www.pstruh.cz/help/urlrepl/library.htm>URL Replacer</A>?/Font>"

HTML = HTML & "</td></tr></table></Body></HTML>"

Foot = HTML

end function

function Head(Title, Description)

DIM HTML

HTML = "<HTML><Head>"

HTML = HTML & "<Title>" & Title & "</Title>"

HTML = HTML & "<Meta Content=""" & Description & """ Name=""Description"">"

HTML = HTML & Style()

HTML = HTML & "</Head>"

HTML = HTML & Body()

Head = HTML

end function

function Body()

DIM HTML

HTML = "<body ALINK=YELLOW bgcolor=White LeftMargin=0 TopMargin=0>" &vbCrLf

HTML = HTML & ClHead() &vbCrLf

HTML = HTML & Source()

Body = HTML

'<LeftMargin=0 TopMargin=0 Style="margin-right:0pt; margin-top:0pt; margin-left:0pt;">

end function

function Style()

Style = "<STYLE TYPE=""text/css""><--BODY{font-size:10pt;font-family:Arial,Arial CE,Helvetica,sans-serif }--></STYLE>"

'<LeftMargin=0 TopMargin=0 Style="margin-right:0pt; margin-top:0pt; margin-left:0pt;">

end function

function ClHead()

DIM HTML

HTML = HTML & "<TABLE width=100% border=1 cellpadding=1 cellspacing=0 BORDERCOLOR=WHITE><tr bgcolor=SILVER>"

HTML = HTML & "<th><a href="http://www.ziliaonet.com/tech/netprogramme/asp/200607/fupload.asp>Multiple" text files upload</a></th>"

HTML = HTML & "<th><a href=fdbupl.asp>Upload to database</a></th>"

HTML = HTML & "<th><a href="http://www.ziliaonet.com/tech/netprogramme/asp/200607/fdbdown.asp>Download" from database</a></th>"

HTML = HTML & "<th><a href=" & request.servervariables("script_name") & "?S=1>View source</a></th>"

HTML = HTML & "</tr></table>"

ClHead = HTML

end function

function Source()

DIM HTML

if request.querystring("S")<>"" then

HTML = HTML & "<pre>" & server.htmlencode(CreateObject("Scripting.FileSystemObject").OpenTextFile _

(server.mappath(request.servervariables("script_name")), 1, False, False).readall) & "</pre>"

end if

Source = BasicEncode(HTML)

Function BasicEncode(ByVal VBCode)

' Dim Pom, PosStart, PosEnd

' PosStart = InStr(VBCode, "'")

' Do While PosStart > 0

' PosEnd = InStr(PosStart + 1, VBCode, vbCrLf)

' If PosEnd = 0 Then PosEnd = Len(VBCode)

' Pom = Left(VBCode, PosStart - 1) & "<font color=green>"

' Pom = Pom & Mid(VBCode, PosStart, PosEnd - PosStart - 0) & "</font>"

' Pom = Pom & Mid(VBCode, PosEnd)

' VBCode = Pom

' PosStart = InStr(PosEnd + 1, VBCode, "'")

' Loop

VBCode = FilterBeginEnd(VBCode, "'", vbCrLf, "green")

VBCode = FilterBeginEnd(VBCode, """, """, "brown")

VBCode = FilterWord(VBCode, "Set ", "blue")

VBCode = FilterWord(VBCode, "If ", "blue")

VBCode = FilterWord(VBCode, "For ", "blue")

VBCode = FilterWord(VBCode, " Then", "blue")

VBCode = FilterWord(VBCode, " In ", "blue")

VBCode = FilterWord(VBCode, "Each ", "blue")

VBCode = FilterWord(VBCode, "Function ", "blue")

VBCode = FilterWord(VBCode, "End Function", "blue")

VBCode = FilterWord(VBCode, "MsgBox ", "blue")

VBCode = FilterWord(VBCode, "OutPut ", "blue")

VBCode = FilterWord(VBCode, "Empty", "blue")

VBCode = FilterWord(VBCode, "Debug.Print ", "darkblue")

VBCode = FilterWord(VBCode, "Print ", "blue")

VBCode = FilterWord(VBCode, " And ", "blue")

VBCode = FilterWord(VBCode, " Or ", "blue")

VBCode = FilterWord(VBCode, "Next" & vbcrlf, "blue")

VBCode = FilterWord(VBCode, "Next " , "blue")

VBCode = FilterWord(VBCode, "Response.Write", "darkblue")

VBCode = FilterWord(VBCode, "Response.BinaryWrite" , "darkblue")

VBCode = FilterWord(VBCode, "Response.ContentType" , "darkblue")

VBCode = FilterWord(VBCode, "Response.AddHeader" , "darkblue")

VBCode = FilterWord(VBCode, "Server.CreateObject" , "darkblue")

VBCode = FilterWord(VBCode, "CreateObject" , "darkblue")

' VBCode = FilterWord(VBCode," = ","red")

BasicEncode = VBCode

End Function

Function FilterBeginEnd(ByVal VBCode, ByVal sBegin, ByVal sEnd, ByVal Color)

Dim Pom, PosStart, PosEnd, FontColor

FontColor = "<font color=" & Color & ">"

PosStart = InStr(ucase(VBCode), ucase(sBegin))

Do While PosStart > 0

PosEnd = InStr(PosStart + Len(sBegin), ucase(VBCode), ucase(sEnd))

If PosEnd = 0 Then PosEnd = Len(VBCode)

Pom = Left(VBCode, PosStart - 1) & FontColor

Pom = Pom & Mid(VBCode, PosStart, PosEnd - PosStart + Len(sEnd)) & "</font>"

Pom = Pom & Mid(VBCode, PosEnd + Len(sEnd))

VBCode = Pom

PosStart = InStr(PosEnd + Len(FontColor) + Len("</font>") + Len(sEnd), ucase(VBCode), ucase(sBegin))

Loop

FilterBeginEnd = VBCode

End Function

Function FilterWord(ByVal VBCode, ByVal Word, ByVal Color)

Dim Pom, PosStart, PosEnd, FontWord

FontWord = "<font color=" & Color & ">" & Word & "</font>"

PosStart = InStr(ucase(VBCode), ucase(Word))

Do While PosStart > 0

Pom = Left(VBCode, PosStart - 1) & FontWord

Pom = Pom & Mid(VBCode, PosStart + Len(Word))

VBCode = Pom

PosStart = InStr(PosStart + Len(FontWord), ucase(VBCode), ucase(Word))

Loop

FilterWord = VBCode

End Function

</SCRIPT>