Code:
Public Property Let UploadID(inUploadID)
if isempty(FS) then Set fs = CreateObject("Scripting.FileSystemObject")
TempFolder = fs.GetSpecialFolder(2)
m_UploadID = inUploadID
TempFileName = TempFolder & "\pu" & m_UploadID & ".~tmp"
Dim DateLastModified
on error resume next
DateLastModified = fs.GetFile(TempFileName).DateLastModified
on error goto 0
if isempty(DateLastModified) then 'OK
elseif Now-DateLastModified>1 Then 'I think upload duration will be less than one day
FS.DeleteFile TempFileName
end if
End Property
Private Function GetFile(Byref FileName)
Dim InStream
On Error Resume Next
Set InStream = fs.OpenTextFile(FileName, 1)
GetFile = InStream.ReadAll
On Error Goto 0
End Function
Private Function WriteFile(Byref FileName, Byref Contents)
'wscript.echo "WriteFile", FileName, Contents
Dim OutStream
On Error Resume Next
Set OutStream = fs.OpenTextFile(FileName, 2, True)
OutStream.Write Contents
End Function
Private Sub Class_Initialize()
End Sub
End Class 'cProgressFile
'******************************************************************************
'Emulates ScriptUtilities FormField object
'See http://www.pstruh.cz
Class cFormField
'Used properties
Public ContentDisposition, ContentType, FileName, FilePath, FileExt, Name
Public ByteArray
'non-used properties.
Public CharSet, HexString, InProgress, SourceLength, RAWHeader, Index, ContentTransferEncoding
Public Default Property Get String()
'wscript.echo "**Field-String", Name, LenB(ByteArray)
String = BinaryToString(ByteArray)
End Property
Public Property Get IsFile()
IsFile = not isempty(FileName)
End Property
Public Property Get Length()
Length = LenB(ByteArray)
End Property
Public Property Get Value()
Set Value = Me
End Property
Public Sub Save(Path)
'2.06 - and len(FileName)>0
if IsFile and len(FileName)>0 Then
Dim fullFileName
fullFileName = Path & "\" & FileName
SaveAs fullFileName
Else
'response.write "<br>" & typename(Name)
'Err.Raise 1, "Text field " & Name & " does not have a file name"
End If
End Sub
Public Sub SaveAs(newFileName)
'2.06 - removed if len(ByteArray)>0 then
SaveBinaryData newFileName, ByteArray
End Sub
End Class
Function StringToBinary(String)
Dim I, B
For I=1 to len(String)
B = B & ChrB(Asc(Mid(String,I,1)))
Next
StringToBinary = B
End Function
Function BinaryToString(Binary)
'2001 Antonin Foller, PSTRUH Software
'Optimized version of PureASP conversion function
'Selects the best algorithm to convert binary data to String data
Dim TempString
On Error Resume Next
'Recordset conversion has a best functionality
TempString = RSBinaryToString(Binary)
If Len(TempString) <> LenB(Binary) then'Conversion error
'We have to use multibyte version of BinaryToString
TempString = MBBinaryToString(Binary)
end if
BinaryToString = TempString
End Function
Function MBBinaryToString(Binary)
'1999 Antonin Foller, PSTRUH Software
'MultiByte version of BinaryToString function
'Optimized version of simple BinaryToString algorithm.
dim cl1, cl2, cl3, pl1, pl2, pl3
Dim L', nullchar
cl1 = 1
cl2 = 1
cl3 = 1
L = LenB(Binary)
Do While cl1<=L
pl3 = pl3 & Chr(AscB(MidB(Binary,cl1,1)))
cl1 = cl1 + 1
cl3 = cl3 + 1
if cl3>300 then
pl2 = pl2 & pl3
pl3 = ""
cl3 = 1
cl2 = cl2 + 1
if cl2>200 then
pl1 = pl1 & pl2
pl2 = ""
cl2 = 1
End If
End If
Loop
MBBinaryToString = pl1 & pl2 & pl3
End Function
Function RSBinaryToString(xBinary)
'1999 Antonin Foller, PSTRUH Software
'This function converts binary data (VT_UI1 | VT_ARRAY or MultiByte string)
'to string (BSTR) using ADO recordset
'The fastest way - requires ADODB.Recordset
'Use this function instead of MBBinaryToString if you have ADODB.Recordset installed
'to eliminate problem with PureASP performance
Dim Binary
'MultiByte data must be converted to VT_UI1 | VT_ARRAY first.
if vartype(xBinary) = 8 then Binary = MultiByteToBinary(xBinary) else Binary = xBinary
Dim RS, LBinary
Const adLongVarChar = 201
Set RS = CreateObject("ADODB.Recordset")
LBinary = LenB(Binary)
if LBinary>0 then
RS.Fields.Append "mBinary", adLongVarChar, LBinary
RS.Open
RS.AddNew
RS("mBinary").AppendChunk Binary
RS.Update
RSBinaryToString = RS("mBinary")
Else
RSBinaryToString = ""
End If
End Function
Function MultiByteToBinary(MultiByte)
' This function converts multibyte string to real binary data (VT_UI1 | VT_ARRAY)
' Using recordset
Dim RS, LMultiByte, Binary
Const adLongVarBinary = 205
Set RS = CreateObject("ADODB.Recordset")
LMultiByte = LenB(MultiByte)
if LMultiByte>0 then
RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte
RS.Open
RS.AddNew
RS("mBinary").AppendChunk MultiByte & ChrB(0)
RS.Update
Binary = RS("mBinary").GetChunk(LMultiByte)
End If
MultiByteToBinary = Binary
End Function
'************** Upload Utilities
'Separates header fields from upload header
Function GetHeadFields(ByVal Head, Name, FileName, Content_Disposition, Content_Type)
'Get name of the field. Name is separated by name= and ;
Name = (SeparateField(Head, "name=", ";")) 'ltrim
'Remove quotes (if the field name is quoted)
If Left(Name, 1) = """" Then Name = Mid(Name, 2, Len(Name) - 2)
'Same for source filename
FileName = (SeparateField(Head, "filename=", ";")) 'ltrim
If Left(FileName, 1) = """" Then FileName = Mid(FileName, 2, Len(FileName) - 2)
'Separate content-disposition and content-type header fields
Content_Disposition = LTrim(SeparateField(Head, "content-disposition:", ";"))
Content_Type = LTrim(SeparateField(Head, "content-type:", ";"))
End Function
'Separates one field between sStart and sEnd
Function SeparateField(From, ByVal sStart, ByVal sEnd)
Dim PosB, PosE, sFrom
sFrom = LCase(From)
PosB = InStr(sFrom, sStart)
If PosB > 0 Then
PosB = PosB + Len(sStart)
PosE = InStr(PosB, sFrom, sEnd)
If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf)
If PosE = 0 Then PosE = Len(sFrom) + 1
SeparateField = Mid(From, PosB, PosE - PosB)
Else
SeparateField = Empty
End If
End Function
Function SplitFileName(FullPath)
Dim Pos, PosF
PosF = 0
For Pos = Len(FullPath) To 1 Step -1
Select Case Mid(FullPath, Pos, 1)
Case ":", "/", "\": PosF = Pos + 1: Pos = 0
End Select
Next
If PosF = 0 Then PosF = 1
SplitFileName = PosF
End Function
Function GetPath(FullPath)
GetPath = left(FullPath, SplitFileName(FullPath)-1)
End Function
'Separetes file name from the full path of file
Function GetFileName(FullPath)
GetFileName = Mid(FullPath, SplitFileName(FullPath))
End Function
'Separetes file name from the full path of file
Function GetFileExt(FullPath)
Dim Pos: Pos = InStrRev(FullPath,".")
if Pos>0 then GetFileExt = Mid(FullPath, Pos)
End Function
Function RecurseMKDir(ByVal Path)
Dim FS: Set FS = CreateObject("Scripting.FileSystemObject")
Path = Replace(Path, "/", "\")
If Right(Path, 1) <> "\" Then Path = Path & "\" '"
Dim Pos, n
Pos = 0: n = 0
Pos = InStr(Pos + 1, Path, "\") '"
Do While Pos > 0
On Error Resume Next
FS.CreateFolder Left(Path, Pos - 1)
If Err = 0 Then n = n + 1
Pos = InStr(Pos + 1, Path, "\") '"
Loop
RecurseMKDir = n
End Function
Function SaveBinaryData(FileName, ByteArray)
SaveBinaryData = SaveBinaryDataStream(FileName, ByteArray)
End Function
Function SaveBinaryDataTextStream(FileName, ByteArray)
Dim FS : Set FS = CreateObject("Scripting.FileSystemObject")
On error Resume next
Dim TextStream
Set TextStream = FS.CreateTextFile(FileName)
if Err = &H4c then 'Path not found.
On error Goto 0
RecurseMKDir GetPath(FileName)
On error Resume next
Set TextStream = FS.CreateTextFile(FileName)
end if
TextStream.Write BinaryToString(ByteArray) 'BinaryToString is in upload.inc.
TextStream.Close
Dim ErrMessage, ErrNumber
ErrMessage = Err.Description
ErrNumber = Err
On Error Goto 0
if ErrNumber<>0 then Err.Raise ErrNumber, "SaveBinaryData", FileName & ":" & ErrMessage
End Function
Function SaveBinaryDataStream(FileName, ByteArray)
Dim BinaryStream
Set BinaryStream = createobject("ADODB.Stream")
BinaryStream.Type = 1 'Binary
BinaryStream.Open
'2.06 - zero byte file is legal
if lenb(ByteArray)>0 then BinaryStream.Write ByteArray
On error Resume next
'response.Write(FileName)
BinaryStream.SaveToFile FileName, 2 'Overwrite
if Err = &Hbbc then 'Path not found.
On error Goto 0
RecurseMKDir GetPath(FileName)
On error Resume next
BinaryStream.SaveToFile FileName, 2 'Overwrite
end if
Dim ErrMessage, ErrNumber
ErrMessage = Err.Description
ErrNumber = Err
On Error Goto 0
if ErrNumber<>0 then Err.Raise ErrNumber, "SaveBinaryData", FileName & ":" & ErrMessage
End Function
'************** Upload Utilities - end
'Emulates response object
Class cResponse
Public Property Get IsClientConnected
randomize
IsClientConnected = cbool(clng(rnd * 4))
IsClientConnected = True
End Property
End Class
Class cRequest
Private Readed
Private BinaryStream
public function ServerVariables(Name)
select case UCase(Name)
Case "CONTENT_TYPE":
Case "HTTP_CONTENT_TYPE":
ServerVariables = "multipart/form-data; boundary=---------------------------7d21960404e2"
Case "CONTENT_LENGTH":
Case "HTTP_CONTENT_LENGTH":
ServerVariables = "" & TotalBytes
Case "REQUEST_METHOD":
ServerVariables = "POST"
End Select
End Function
public function BinaryRead(ByRef Bytes)
If Bytes<=0 then Exit Function
if Readed + Bytes > TotalBytes Then Bytes = TotalBytes - Readed
BinaryRead = BinaryStream.Read(Bytes)
End Function
Public Property Get TotalBytes
TotalBytes = BinaryStream.Size
End Property
Private Sub Class_Initialize()
Set BinaryStream = createobject("ADODB.Stream")
BinaryStream.Type = 1 'Binary
BinaryStream.Open
BinaryStream.LoadFromFile "F:\InetPub\Pstruh\pureupload\2.txt"
BinaryStream.Position = 0
Readed = 0
End Sub
end Class
%>
LinkBack URL
About LinkBacks
Reply With Quote
Bookmarks