%
'*****************************************************************************************************
'************************************ xt_upload.asp ******************************************
'*****************************************************************************************************
' HTTP POST acceptor script
' Supports Multiple files of supported Images types (*.jpg, *.jpeg, *.gif, *.png, *.tiff)
' Copyright © 2001-2004 Ephox Pty Ltd. All rights reserved.
' The use of the source code and software is subject to the licence
' conditions included in this source release. See "Ephox Licence V4.doc"
'
' Coder: Craig Vandekamp
' Coder: Jonathan Hall
'
' Last Update: 20/11/2000
' Last Update: 10/02/2001-2004
'*****************************************************************************************************
'***************************************** Code Start ************************************************
'*****************************************************************************************************
'**********************************************************************************
'*********************************Set ImageUpload Directory Here************************
'**********************************************************************************
Dim imageDir
imageDir="../../images"
server.scripttimeout=10000
'*****************************************************************************************************
'*************************************** ReadRawData *************************************************
'*****************************************************************************************************
Function ReadRawData(maxLength)
Dim ContentType, PosB, Boundary, length, Fields, data, PosE, fieldHeader, fieldName
Dim FieldB, FieldE, fileName, fieldValue
Dim fieldArray, TotalBytes
'reads Content-Type header
ContentType = LCase(Request.ServerVariables("HTTP_Content_Type"))
'Finds boundary
PosB = InStr(ContentType, "boundary=")
'Separates boundary
If PosB > 0 Then Boundary = Mid(ContentType, PosB + 9)
Boundary=Str2Bin(Boundary)
'Read all binary data
TotalBytes = Request.TotalBytes
data = Request.BinaryRead(TotalBytes)
Set Fields = CreateObject("Scripting.Dictionary")
PosB=1
do while true
PosB=InStrB(Posb, data, Boundary) + lenb(Boundary)
'Check for last boundary
If MidB(data, PosB, 2)=Str2Bin("--") then exit do
PosB=PosB+2
PosE=InStrB(PosB, data, chrb(13) & chrb(10) & chrb(13) & chrb(10) )
fieldHeader=Bin2Str( MidB(data,posb,pose-posb) )
fieldName=""
FieldB=InStr(fieldHeader, "name=""" )
if FieldB>0 then
FieldB=FieldB + 6
FieldE=InStr(FieldB, fieldHeader, """" )
fieldName=Mid(fieldHeader, FieldB, FieldE-FieldB)
end if
fileName=""
FieldB=InStr(fieldHeader, "filename=""" )
if FieldB>0 then
FieldB=FieldB + 10
FieldE=InStr(FieldB, fieldHeader, """" )
fileName=Mid(fieldHeader, FieldB, FieldE-FieldB)
end if
PosB=PosE+4
PosE=InStrB(Posb, data, Boundary)-4
fieldValue=""
fieldValue=MidB(data,posb,pose-posb)
Fields.add fieldName, array(fieldValue, fileName)
'response.write fieldName & " - " & fileName & " value: "& fieldValue &"
"
loop
set ReadRawData=fields
End Function
'*****************************************************************************************************
'******************************************** SaveFile ***********************************************
'*****************************************************************************************************
' save the file(s) on the server
Function SaveFile(PathName, FileData)
Dim FS, File, i
Set FS = Server.CreateObject("Scripting.FileSystemObject")
Set File = FS.CreateTextFile(PathName , true)
For i = 1 to lenb(FileData)
File.Write Chr(AscB(MidB( FileData, i, 1 )))
Next
'Clean up objects
File.Close
Set File=nothing
Set FS=nothing
End Function
'****************************************************************************************************
'********************************************** Bin2Str *********************************************
'****************************************************************************************************
' convert binary data to its string equivalent
Function Bin2Str(Bin)
Dim i, S
For i = 1 To LenB(Bin)
S = S & Chr(AscB( MidB(Bin, i, 1) ))
Next
Bin2Str = S
End Function
'****************************************************************************************************
'******************************************** Str2Bin ***********************************************
'****************************************************************************************************
' convert a string to its binary equivalent
Function Str2Bin(Str)
Dim i, B
For i=1 to len(Str)
B = B & ChrB(Asc( Mid(Str,i,1) ))
Next
Str2Bin = B
End Function
'***************************************************************************************
'******************************** Save Routine *****************************************
'***************************************************************************************
' perform the actual save
Response.Expires = 0
Response.Buffer = TRUE
Dim Fields, FileData, PathName, curDir
Dim arrPath
Dim i, FieldsKeys
' get the data from the safe array and place in Dictionary Obj
set Fields=ReadRawData(0)
'**************************************
'The absolute or relative path to point
'to the dir where files will be uploaded to
'**************************************
curDir = Server.MapPath(imagedir)
'***************************************
' get the data from the Dictonary object
' and save it
'***************************************
FieldsKeys = Fields.Keys
For i = 0 To Fields.Count -1 'Iterate the array
FileData=Fields(FieldsKeys(i))(0)
PathName=Fields(FieldsKeys(i))(1)
if PathName<>"" then
arrPath=split(PathName,"\")
OnlyFileName = arrPath(ubound(arrPath) )
OnlyExtention = Right(OnlyFileName, Len(OnlyFileName) - InStrRev(OnlyFileName, "."))
if OnlyExtention="jpeg" or _
OnlyExtention="jpg" or _
OnlyExtention="tiff" or _
OnlyExtention="png" or _
OnlyExtention="gif" then
call SaveFile(curDir & "\" & OnlyFileName, FileData)
end if
end if
Next
'***************************************************************************************
'*********************************** Code End ******************************************
'***************************************************************************************
%>