Evo koju ja koristim, nadjoh nekad na netu:
Code:
<%
function AddSlash(Path)
if Right(Path, 1) = "\" then AddSlash = Path else AddSlash = Path & "\"
end function
function RemoveSlash(Path)
if Right(Path, 1) = "\" and Mid(Path, len(Path) - 1, 1) <> ":" then RemoveSlash = Left(Path, len(Path) - 1) else RemoveSlash = Path
end function
function GetParentPath(Path)
dim I, J
I = InStrRev(Path, "\")
J = InStrRev(Path, "\", I - 1)
if I - J = 1 or J < 1 then GetParentPath = Left(Path, I) else GetParentPath = Left(Path, I - 1)
end function
function MapPath(Path)
if InStr(Path, ":") > 0 or Left(Path, 2) = "\\" then
MapPath = Path
else
MapPath = Server.MapPath(Path)
if Right(Path, 1) = "\" then MapPath = AddSlash(MapPath)
end if
end function
function MakeDir(Path)
dim I, J, S, FSO, Paths()
set FSO = Server.CreateObject("Scripting.FileSystemObject")
I = 0
S = Path
do
redim preserve Paths(I)
Paths(I) = S
S = FSO.GetParentFolderName(S)
I = I + 1
loop while S <> ""
J = 0
do while J < I
if FSO.FolderExists(Paths(J)) then exit do
J = J + 1
loop
J = J - 1
do while J > -1
FSO.CreateFolder Paths(J)
J = J - 1
loop
end function
function GetNextNumberedFilename(Filename, Digits)
dim FSO, PathAndBaseName, ExtentionName, Count, S, I
set FSO = Server.CreateObject("Scripting.FileSystemObject")
ExtentionName = FSO.GetExtensionName(Filename)
if ExtentionName <> "" then ExtentionName = "." & ExtentionName
PathAndBaseName = Left(Filename, len(Filename) - len(ExtentionName))
Count = 0
do
Count = Count + 1
GetNextNumberedFilename = PathAndBaseName & string(Digits - len(cstr(Count)), "0") & Count & ExtentionName
loop while FSO.FileExists(GetNextNumberedFilename)
end function
function DeunixPath(Path)
if InStr(Path, "/") > 0 then Path = Replace(Path, "\", "_")
Path = Replace(Path, "/", "\")
Path = Replace(Path, ":", "_")
Path = Replace(Path, "*", "_")
Path = Replace(Path, "?", "_")
Path = Replace(Path, """", "_")
Path = Replace(Path, "<", "_")
Path = Replace(Path, ">", "_")
Path = Replace(Path, "|", "_")
DeunixPath = Path
end Function
function ByteArrayConcat(byref A1, byref A2)
const adTypeBinary = 1
dim S
set S = Server.CreateObject("ADODB.Stream")
S.Type = adTypeBinary
S.Open
S.Write A1
S.Write A2
S.Position = 0
ByteArrayConcat = S.Read
S.Close
end Function
function ByteArrayMid(byref A, Start, Size)
dim S
const adTypeBinary = 1
if IsNull(A) then
ByteArrayMid = null
else
set S = Server.CreateObject("ADODB.Stream")
S.Type = adTypeBinary
S.Open
S.Write A
S.Position = Start
ByteArrayMid = S.Read(Size)
S.Close
end if
end Function
function StrToBin(byref Str)
dim I, B
B = ""
for I = 1 to len(Str)
B = B & ChrB(Asc(Mid(Str, I, 1)))
next
StrToBin = B
end function
function BinToStr(byref Bin)
dim I, S
S = ""
for I = 1 to lenb(Bin)
S = S & Chr(AscB(MidB(Bin, I, 1)))
next
BinToStr = S
end function
function BinToStrC(byref Bin, Charset)
dim Stream
const adTypeText = 2
const adTypeBinary = 1
if IsNull(Bin) then
BinToStrC = ""
else
set Stream = Server.CreateObject("ADODB.Stream")
Stream.Type = adTypeBinary
Stream.Open
Stream.Write Bin
Stream.Position = 0
Stream.Type = adTypeText
Stream.Charset = Charset
BinToStrC = Stream.ReadText
Stream.Close
end if
end Function
class BinaryToString
private Recordset
private FirstTime
private sub Class_Initialize
const adUseClient = 3
set Recordset = Server.CreateObject("ADODB.Recordset")
Recordset.CursorLocation = adUseClient
FirstTime = true
end sub
private sub Class_Terminate
const adStateOpen = 1
if not IsEmpty(Recordset) then if Recordset.State and adStateOpen then Recordset.Close
end sub
public function Convert(byref Binary, Size)
const adLongVarChar = 201
Recordset.Fields.Append "A", adLongVarChar, Size
Recordset.Open
Recordset.AddNew
Recordset(0).AppendChunk Binary
Recordset.Update
Convert = Recordset(0).Value
Recordset.Close
if FirstTime then
if len(Convert) <> Size then Raise("Codepage not supported - see Troubleshooting in Manual")
FirstTime = false
end if
end function
end class
private sub Raise(Msg)
Err.Raise vbObjectError + 1, "ASPUploader", Msg
end sub
class UploadFile
public Owner
public UserDefined
public DestType
public InputName
public Name
public Size
public ContentType
public ClientPath
public Stream
public MaxSize
public ValidFileTypes
public Overwrite
public DeleteIncomplete
public Destination
private sub Class_Terminate
const adStateOpen = 1
if not IsEmpty(Stream) then if Stream.State and adStateOpen then Stream.Close
end sub
private function FSO
set FSO = Server.CreateObject("Scripting.FileSystemObject")
end function
public sub Delete
const dtDirectory = 0
if DestType <> dtDirectory then Owner.Raise "Invalid operation"
FSO.DeleteFile AddSlash(Destination) & Name, true
Owner.Files.Remove InputName
end sub
private sub RenameMoveCopy(NewDestination, Copy)
dim Path
const dtDirectory = 0
if DestType <> dtDirectory then Owner.Raise "Invalid operation"
if Right(NewDestination, 1) = "\" then NewDestination = NewDestination & Name
NewDestination = MapPath(NewDestination)
MakeDir GetParentPath(NewDestination)
if FSO.FileExists(NewDestination) then if Overwrite then FSO.DeleteFile NewDestination, true else NewDestination = GetNextNumberedFilename(NewDestination, 3)
Path = AddSlash(Destination) & Name
if Copy then FSO.CopyFile Path, NewDestination, true else FSO.MoveFile Path, NewDestination
Destination = GetParentPath(NewDestination)
Name = Right(NewDestination, len(NewDestination) - InStrRev(NewDestination, "\"))
end sub
public sub Rename(NewName)
RenameMoveCopy AddSlash(Destination) & NewName, false
end sub
public sub Move(NewDestination)
RenameMoveCopy NewDestination, false
end sub
public sub Copy(NewDestination)
RenameMoveCopy NewDestination, true
end sub
end class
class ASPUploader
private File, FSO, FileStream, Converter, ProgressTable, TotalReadSize, Boundary, BoundaryBegin, Ending
private ChunkSize
private MaxHeaderSize
private MaxInputValueSize
public MaxTotalBytes
public ValidFileTypes
public Destination
public Overwrite
public DeleteIncomplete
public Charset
public ID
public Files
public Form
private sub Class_Initialize
ChunkSize = 65792
MaxHeaderSize = 4096
MaxInputValueSize = 8388608
MaxTotalBytes = 2147400000
ValidFileTypes = ""
Overwrite = false
DeleteIncomplete = true
Charset = "us-ascii"
ID = ""
set Files = Server.CreateObject("Scripting.Dictionary")
set Form = Server.CreateObject("Scripting.Dictionary")
end sub
private function IsValidName(File)
dim I
if File.ValidFileTypes = "" then
IsValidName = true
else
IsValidName = false
I = InStrRev(File.Name, ".")
if (I > 0) then if InStr(1, "," & File.ValidFileTypes & ",", "," & Right(File.Name, len(File.Name) - I) & ",", vbTextCompare) > 0 then IsValidName = true
end if
end function
private function GetBoundary
const BadContentType = "Bad or missing CONTENT_TYPE"
const BadEnctype = "Enctype attribute of HTML form must be "
const Enctype = "multipart/form-data"
dim ConstBegin, RawStr, RawStrSize, I, Obj
ConstBegin = "boundary="
set Obj = Request.ServerVariables("CONTENT_TYPE")
if Obj.Count > 0 then RawStr = Obj(1) else RawStr = ""
if RawStr = "" then Raise BadContentType
if InStr(1, RawStr, Enctype, vbTextCompare) < 1 then Raise BadEnctype & Enctype
I = InStr(1, RawStr, ConstBegin, vbTextCompare)
if I < 1 then Raise BadContentType
GetBoundary = Mid(RawStr, I + len(ConstBegin))
end function
private function ReadChunk
dim Size
Size = ChunkSize
ReadChunk = Request.BinaryRead(Size)
if Size = 0 then Raise "Unexpected end of request"
TotalReadSize = TotalReadSize + Size
if TotalReadSize > MaxTotalBytes then Raise "Total upload size out of limit"
end function
private sub WriteChunk(byref BinChunk, Size)
const dtDirectory = 0, dtDatabase = 1
if not IsNull(BinChunk) then
select case File.DestType
case dtDirectory FileStream.Write Converter.Convert(BinChunk, Size)
case dtDatabase File.Destination.AppendChunk BinChunk
case else File.Stream.Write BinChunk
end select
File.Size = File.Size + Size
if not IsEmpty(File.MaxSize) then if File.Size > File.MaxSize then Raise "Velicina slike nije dozvoljena!"
end if
end sub
private function ProcessChunks(byref OldBinChunk, byref NewBinChunk, byref OldChunk, byref NewChunk)
dim I, BinChunk
Ending = RightB(OldChunk, lenb(Boundary))
BoundaryBegin = InStrB(Ending & NewChunk, Boundary)
if BoundaryBegin < 1 then
WriteChunk OldBinChunk, lenb(OldChunk)
if ID <> "" then
Application.Lock
ProgressTable.MoveFirst
ProgressTable.Find "ID = " & ID
ProgressTable("LastUpdate").Value = Now
ProgressTable("UploadedBytes").Value = TotalReadSize
ProgressTable("CurrentFileBytes").Value = File.Size
ProgressTable.Update
Application.UnLock
end if
OldBinChunk = ReadChunk
OldChunk = cstr(OldBinChunk)
ProcessChunks = false
else
I = BoundaryBegin - lenb(Ending) + lenb(OldChunk) - lenb(StrToBin(VbCrLf)) - 1
if I > lenb(OldChunk) then
WriteChunk OldBinChunk, lenb(OldChunk)
I = I - lenb(OldChunk)
BinChunk = ByteArrayMid(NewBinChunk, 0, I)
WriteChunk BinChunk, I
else
BinChunk = ByteArrayMid(OldBinChunk, 0, I)
WriteChunk BinChunk, I
end if
ProcessChunks = true
end if
end function
private sub ParseAndSave
const adTypeBinary = 1, adReadAll = -1, adUseClient = 3, adDate = 7, adInteger = 3, adVarChar = 200
const UploadProgressTable = "ASPUploaderProgressTable", dtDirectory = 0, dtDatabase = 1, dtMemory = 2
dim StartTime, TotalBytes
dim CrLf, Quote, ConstInputName, ConstFileName, ConstContentType, ConstBoundaryAddon, ConstHeaderEnd
dim Header, BinHeader, HeaderBegin, HeaderEnd, WordBegin, WordEnd, InputName, InputValue
dim Chunk, Chunk1, Chunk2, BinChunk, BinChunk1, BinChunk2, I, S
StartTime = Now
TotalBytes = Request.TotalBytes
TotalReadSize = 0
if TotalBytes > MaxTotalBytes then Raise("Total upload size out of limit")
if ID <> "" then
Application.Lock
if IsEmpty(Application(UploadProgressTable)) then
set ProgressTable = Server.CreateObject("ADODB.Recordset")
set Application(UploadProgressTable) = ProgressTable
ProgressTable.CursorLocation = adUseClient
ProgressTable.Fields.Append "ID", adInteger
ProgressTable.Fields.Append "FirstUpdate", adDate
ProgressTable.Fields.Append "LastUpdate", adDate
ProgressTable.Fields.Append "TotalBytes", adInteger
ProgressTable.Fields.Append "UploadedBytes", adInteger
ProgressTable.Fields.Append "CurrentFile", adVarChar, 128
ProgressTable.Fields.Append "CurrentFileBytes", adInteger
ProgressTable.Open
ProgressTable("ID").Properties("Optimize") = true
else
set ProgressTable = Application(UploadProgressTable)
end if
ProgressTable.AddNew
ProgressTable("ID").Value = clng(ID)
ProgressTable("FirstUpdate").Value = StartTime
ProgressTable("LastUpdate").Value = StartTime
ProgressTable("TotalBytes").Value = TotalBytes
ProgressTable("UploadedBytes").Value = 0
ProgressTable("CurrentFile").Value = ""
ProgressTable("CurrentFileBytes").Value = 0
ProgressTable.Update
Application.UnLock
end if
Quote = StrToBin(Chr(34))
CrLf = StrToBin(VbCrLf)
ConstInputName = StrToBin("name=")
ConstFileName = StrToBin("filename=")
ConstContentType = StrToBin("Content-Type: ")
ConstBoundaryAddon = StrToBin("--")
ConstHeaderEnd = CrLf & CrLf
Boundary = ConstBoundaryAddon & StrToBin(GetBoundary)
BinChunk = ReadChunk
Chunk = cstr(BinChunk)
BoundaryBegin = InStrB(Chunk, Boundary)
if BoundaryBegin < 1 then Raise "Boundary not found"
do while true
HeaderBegin = BoundaryBegin + lenb(Boundary) + lenb(CrLf)
HeaderEnd = InStrB(HeaderBegin, Chunk, ConstHeaderEnd)
do while HeaderEnd < 1
if lenb(Chunk) - HeaderBegin > MaxHeaderSize then Raise "End of header not found"
BinChunk = ByteArrayConcat(BinChunk, ReadChunk)
Chunk = cstr(BinChunk)
HeaderEnd = InStrB(HeaderBegin, Chunk, ConstHeaderEnd)
loop
BinHeader = ByteArrayMid(BinChunk, HeaderBegin - 1, HeaderEnd - HeaderBegin)
Header = cstr(BinHeader)
I = InStrB(Header, ConstInputName)
if I < 1 then Raise "Input name not found"
WordBegin = I + lenb(ConstInputName) + lenb(Quote)
WordEnd = InStrB(WordBegin, Header, Quote)
if WordEnd < 1 then Raise "Unterminated input name"
InputName = BinToStrC(ByteArrayMid(BinHeader, WordBegin - 1, WordEnd - WordBegin), Charset)
I = InStrB(WordEnd, Header, ConstFileName)
if I < 1 then
WordBegin = HeaderEnd + lenb(ConstHeaderEnd)
BoundaryBegin = InStrB(WordBegin, Chunk, Boundary)
do while BoundaryBegin < 1
if lenb(Chunk) - WordBegin > MaxInputValueSize then Raise "Input value size out of limit"
BinChunk = ByteArrayConcat(BinChunk, ReadChunk)
Chunk = cstr(BinChunk)
BoundaryBegin = InStrB(WordBegin, Chunk, Boundary)
loop
WordEnd = BoundaryBegin - lenb(CrLf)
InputValue = BinToStrC(ByteArrayMid(BinChunk, WordBegin - 1, WordEnd - WordBegin), Charset)
if Form.Exists(InputName) then Form(InputName) = Form(InputName) & "," & InputValue else Form.Add InputName, InputValue
else
WordBegin = I + lenb(ConstFileName) + lenb(Quote)
WordEnd = InStrB(WordBegin, Header, Quote)
if WordEnd < 1 then Raise "Unterminated filename"
if WordEnd = WordBegin then
BoundaryBegin = HeaderEnd + lenb(ConstHeaderEnd) + lenb(CrLf)
else
if Files.Exists(InputName) then
set File = Files(InputName)
if not File.UserDefined then Raise "Duplicate InputName of file"
else
set File = new UploadFile
Files.Add InputName, File
set File.Owner = me
File.UserDefined = false
File.InputName = InputName
end if
if IsEmpty(File.ValidFileTypes) then File.ValidFileTypes = ValidFileTypes
if IsEmpty(File.DeleteIncomplete) then File.DeleteIncomplete = DeleteIncomplete
if IsEmpty(File.Overwrite) then File.Overwrite = Overwrite
if IsEmpty(File.Destination) then
if IsEmpty(Destination) then Raise "Missing Destination"
if IsObject(Destination) then set File.Destination = Destination else File.Destination = Destination
end if
File.ClientPath = BinToStrC(ByteArrayMid(BinHeader, WordBegin - 1, WordEnd - WordBegin), Charset)
S = DeunixPath(File.ClientPath)
if IsEmpty(File.Name) then File.Name = Right(S, len(S) - InStrRev(S, "\"))
if not IsValidName(File) then Raise "Invalid filename: " & File.Name
I = InStrB(WordEnd, Header, ConstContentType)
if I < 1 then
File.ContentType = ""
else
WordBegin = I + lenb(ConstContentType)
WordEnd = InStrB(WordBegin, Header, CrLf)
if WordEnd < 1 then WordEnd = HeaderEnd
File.ContentType = BinToStr(MidB(Header, WordBegin, WordEnd - WordBegin))
end if
if IsObject(File.Destination) then
if File.Overwrite then File.Destination.Value = null
File.DestType = dtDatabase
elseif File.Destination = "" then
set File.Stream = Server.CreateObject("ADODB.Stream")
File.Stream.Open
File.Stream.Type = adTypeBinary
File.DestType = dtMemory
else
set Converter = new BinaryToString
set FSO = Server.CreateObject("Scripting.FileSystemObject")
File.Destination = MapPath(File.Destination)
MakeDir File.Destination
S = AddSlash(File.Destination)
if not File.Overwrite then if FSO.FileExists(S & File.Name) then File.Name = FSO.GetFileName(GetNextNumberedFilename(S & File.Name, 3))
set FileStream = FSO.CreateTextFile(S & File.Name, true)
File.DestType = dtDirectory
end if
if ID <> "" then
Application.Lock
ProgressTable.MoveFirst
ProgressTable.Find "ID = " & ID
ProgressTable("CurrentFile").Value = File.Name
ProgressTable.Update
Application.UnLock
end if
File.Size = 0
BinChunk1 = ByteArrayMid(BinChunk, HeaderEnd + lenb(ConstHeaderEnd) - 1, adReadAll)
BinChunk = null
BinChunk2 = null
Chunk1 = cstr(BinChunk1)
Chunk = ""
Chunk2 = ""
do while true
if ProcessChunks(BinChunk2, BinChunk1, Chunk2, Chunk1) then
BinChunk = BinChunk1
Chunk = Chunk1
exit do
end if
if ProcessChunks(BinChunk1, BinChunk2, Chunk1, Chunk2) then
BinChunk = BinChunk2
Chunk = Chunk2
exit do
end if
loop
BinChunk1 = null
Chunk1 = ""
BinChunk2 = null
Chunk2 = ""
BoundaryBegin = BoundaryBegin - lenb(Ending)
select case File.DestType
case dtDirectory
Converter = empty
FileStream.Close
FileStream = empty
case dtMemory
File.Stream.Position = 0
end select
end if
end if
if lenb(Chunk) < BoundaryBegin + lenb(Boundary) + lenb(ConstBoundaryAddon) - 1 then
BinChunk = ByteArrayConcat(BinChunk, ReadChunk)
Chunk = cstr(BinChunk)
end if
if MidB(Chunk, BoundaryBegin + lenb(Boundary), lenb(ConstBoundaryAddon)) = ConstBoundaryAddon then exit do
loop
if ID <> "" then
Application.Lock
ProgressTable.MoveFirst
ProgressTable.Find "ID = " & ID
ProgressTable.Delete
if ProgressTable.RecordCount = 0 then
ProgressTable.Close
Application.Contents.Remove UploadProgressTable
end if
Application.UnLock
end if
end sub
public function AddFile(InputName)
if Files.Exists(InputName) then Raise "Duplicate InputName of file"
set AddFile = new UploadFile
Files.Add InputName, AddFile
set AddFile.Owner = me
AddFile.UserDefined = true
AddFile.InputName = InputName
end function
public sub Upload
const adStateClosed = 0, adStateOpen = 1
const UploadProgressTable = "ASPUploaderProgressTable", dtDirectory = 0, dtDatabase = 1
dim ErrNum, ErrSrc, ErrMsg, F, I
on error resume next
ParseAndSave
if Err then
ErrNum = Err.Number
ErrSrc = Err.Source
ErrMsg = Err.Description
if not IsEmpty(FileStream) then FileStream.Close
Converter = empty
if not IsEmpty(Application(UploadProgressTable)) then
set ProgressTable = Application(UploadProgressTable)
Application.Lock
if ProgressTable.State and adStateOpen then
if ProgressTable.RecordCount > 0 then
ProgressTable.MoveFirst
ProgressTable.Find "ID = " & ID
if not ProgressTable.EOF then ProgressTable.Delete
if ProgressTable.RecordCount > 0 then
ProgressTable.MoveFirst
do
I = ProgressTable("LastUpdate").Value
if IsEmpty(I) then
ProgressTable.Delete
elseif DateDiff("n", I, Now) > 30 then
ProgressTable.Delete
end if
ProgressTable.MoveNext
loop until ProgressTable.EOF
end if
end if
if ProgressTable.RecordCount = 0 then ProgressTable.Close
end if
if ProgressTable.State = adStateClosed then Application.Contents.Remove UploadProgressTable
Application.UnLock
end if
for each F in Files.Items
if F.DeleteIncomplete then
if not IsEmpty(F.DestType) then
select case F.DestType
case dtDirectory FSO.DeleteFile AddSlash(F.Destination) & F.Name, true
case dtDatabase F.Destination.Value = null
case else
F.Stream.Close
F.Stream = empty
end select
F.Size = empty
end if
end if
next
on error goto 0
Err.Raise ErrNum, ErrSrc, ErrMsg
end if
end sub
end class
function GetASPUploader
set GetASPUploader = new ASPUploader
end function
%>
Poziva se:
Code:
<%
dim Uploader, File
set Uploader = GetASPUploader
Uploader.Charset = "windows-1250"
Uploader.Destination = "C:\Inetpub\vhosts\"
set File = Uploader.AddFile("thumb") ' Naziv forme koja nosi fajl
File.ValidFileTypes = "jpg,gif,bmp,jpeg" 'Dozvoljeni fajlovi za upload
File.MaxSize = 72 * 77 ' Maximalna velicina fotografije
File.Overwrite = false 'Prebrisi ako postoji
Server.ScriptTimeout = 900
Uploader.Upload
if Err then 'ako ima greski
'Pisi greski
Else
NazivFajla = File.Name
End If
%>