NewMedia Express KB
June 18, 2021, 02:48:05 AM *
Welcome, Guest. Please login or register.

Login with username, password and session length
   Home   Help Search Login Register  
Pages: [1]
Author Topic: ASP File upload sample (pure upload)  (Read 41297 times)
Full Member
Posts: 101

« on: September 09, 2009, 08:51:26 AM »

Option Explicit
'Stores only files with size less than MaxFileSize

Dim DestinationPath
DestinationPath = Server.mapPath("UploadFolder")

'Create upload form
'Using Huge-ASP file upload
'Dim Form: Set Form = Server.CreateObject("ScriptUtils.ASPForm")
'Using Pure-ASP file upload
Dim Form: Set Form = New ASPForm %><!--#INCLUDE FILE="_upload.asp"--><%

Server.ScriptTimeout = 2000
Form.SizeLimit = &H100000

If Form.State = 0 Then 'Completted
   Form.Files.Save DestinationPath
   response.write "<br><Font Color=green>Files (" &Form.TotalBytes \1024 & "kB) was saved to " & DestinationPath& " folder.</Font>"
ElseIf Form.State > 10 then
  Const fsSizeLimit = &HD
  Select case Form.State
    case fsSizeLimit: response.write  "<br><FontColor=red>Source form size (" & Form.TotalBytes & "B)exceeds form limit (" & Form.SizeLimit &"B)</Font><br>"
    case else response.write "<br><Font Color=red>Some form error.</Font><br>"
  end Select
End If'Form.State = 0 then

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<TITLE>ASP huge file upload - base upload.</TITLE>
<STYLE TYPE="text/css"><!--TD  {font-family:Arial,Helvetica,sans-serif }TH  {font-family:Arial,Helvetica,sans-serif }TABLE  {font-size:10pt;font-family:Arial,Helvetica,sans-serif}--></STYLE>
<meta name="robots" content="noindex,nofollow">
<BODY BGColor=white>

<Div style=width:600>
<TABLE cellSpacing=0 cellPadding=0 width="100%" border=0>
    <TH noWrap align=left width="20%" bgColor=khaki> <A
    href="">Power ASP
    file upload</A> - base upload. </TH>
    <TD> </TD></TR></TABLE>
<TABLE cellSpacing=2 cellPadding=1 width="100%" bgColor=white border=0>
    <TD colSpan=2>
   <P>    Thissample demonstrates shortes possible server-side code.
       ASP code specifies only Form.SizeLimit (maximum size ofupload), Server.ScriptTimeout (maximum time to do upload) andDestinationPath (folder to store uploaded files).

<br>Upload timeout is <%=Server.ScriptTimeout%>s
<br>Form size limit is <%=Form.SizeLimit \ 1024 %>kB
<br>Destination folder is <%=DestinationPath%>


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

   File 1 : <input type="file" name="File1"><br>
   File 2 : <input type="file" name="File2"><br>
   File 3 : <input type="file" name="File3">
<input Name=SubmitButton Value="Upload files >>" Type=submit><br>


<HR COLOR=silver Size=1>
<FONT SIZE=1> 1996 <%=year(date)%> Antonin Foller,<a href="">Motobit Software</a>,e-mail <A href="" ></A>
<br>To monitor current running uploads/downloads, see <AHref="">IISTracer- IIS real-time monitor</A>.


_upload.asp (class file)

'Pure-ASP upload v. 2.06 (with progress bar)
'This software is a FreeWare with limitted use.
'1. You can use this software to upload files with size up to 10MB for free
' if you want to upload bigger files, please register ScriptUtilities and Huge-ASP upload
' See license info at
'2. I'll be glad if you include <A Href="">Pure ASP file upload</A>
' or similar text link to on the web site using Pure-ASP upload.

'Feel free to send comments/suggestions to

Const adTypeBinary = 1
Const adTypeText = 2

Const xfsCompleted    = &H0 '0  Form was successfully processed.
Const xfsNotPost    = &H1 '1  Request method is NOT post
Const xfsZeroLength   = &H2 '2  Zero length request (there are no data in a source form)
Const xfsInProgress   = &H3 '3  Form is in a middle of process.
Const xfsNone       = &H5 '5  Initial form state
Const xfsError      = &HA '10 
Const xfsNoBoundary   = &HB '11  Boundary of multipart/form-data is not specified.
Const xfsUnknownType  = &HC '12  Unknown source form (Content-type must be multipart/form-data)
Const xfsSizeLimit    = &HD '13  Form size exceeds allowed limit (ScriptUtils.ASPForm.SizeLimit)
Const xfsTimeOut    = &HE '14  Upload time exceeds allowed limit (ScriptUtils.ASPForm.ReadTimeout)
Const xfsNoConnected  = &HF '15  Client was disconnected before upload was completted.
Const xfsErrorBinaryRead = &H10 '16  Unexpected error from Request.BinaryRead method (ASP error).

'This class emulates ASPForm Class of Huge-ASP upload,
'See ScriptUtilities and Huge-ASP file upload help (ScptUtl.chm)

Class ASPForm
   Private m_ReadTime
   Public ChunkReadSize, BytesRead, TotalBytes, UploadID

   'non-used properties.
   Public TempPath, MaxMemoryStorage, CharSet, FormType, SourceData, ReadTimeout

   public Default Property Get Item(Key)
    Set Item = m_Items.Item(Key)
   End Property

   public Property Get Items
    Set Items = m_Items
   End Property

   public Property Get Files
    Set Files = m_Items.Files
   End Property

   public Property Get Texts
    Set Texts = m_Items.Texts
   End Property

   public Property Get NewUploadID
    NewUploadID = clng(rnd * &H7FFFFFFF)
   End Property

   Public Property Get ReadTime
    if isempty(m_ReadTime) then
       if not isempty(StartUploadTime) then ReadTime = Clng((Now() - StartUploadTime) * 86400 * 1000)
    else ' For progress window.
       ReadTime = m_ReadTime
    end if
   End Property

   Public Property Get State
    if m_State = xfsNone Then Read
    State = m_State
   End Property

   Private Function CheckRequestProperties
    'Wscript.Echo "**CheckRequestProperties"
   If UCase(Request.ServerVariables("REQUEST_METHOD")) <> "POST" Then 'Request method must be "POST"
       m_State = xfsNotPost
       Exit Function
    End If 'If Request.ServerVariables("REQUEST_METHOD") = "POST" Then
    Dim CT
    CT = Request.ServerVariables("HTTP_Content_Type") 'reads Content-Type header
    if len(CT) = 0 then CT = Request.ServerVariables("CONTENT_TYPE") 'reads Content-Type header UNIX/Linux
   If LCase(Left(CT, 19)) <> "multipart/form-data" Then 'Content-Type header must be "multipart/form-data"
       m_State = xfsUnknownType
       Exit Function
    End If 'If LCase(Left(CT, 19)) <> "multipart/form-data" Then

    Dim PosB 'help position variable
    'This is upload request.
    'Get the boundary and length from Content-Type header
    PosB = InStr(LCase(CT), "boundary=") 'Finds boundary
    If PosB = 0 Then
       m_State = xfsNoBoundary
       Exit Function
    End If 'If PosB = 0 Then
    If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 'Separetes boundary

    '****** Error of IE5.01 - doubbles http header
    PosB = InStr(LCase(CT), "boundary=")
    If PosB > 0 then 'Patch for the IE error
       PosB = InStr(Boundary, ",")
       If PosB > 0 Then Boundary = Left(Boundary, PosB - 1)
    end if
    '****** Error of IE5.01 - doubbles http header

    On Error Resume next
    TotalBytes = Request.TotalBytes
    If Err<>0 Then
       'For UNIX/Linux
       TotalBytes = CLng(Request.ServerVariables("HTTP_Content_Length")) 'Get Content-Length header
       if len(TotalBytes)=0 then TotalBytes = CLng(Request.ServerVariables("CONTENT_LENGTH")) 'Get Content-Length header
    End If
    If TotalBytes = 0 then
       m_State = xfsZeroLength
       Exit Function
    End If

    If IsInSizeLimit(TotalBytes) Then 'Form data are in allowed limit
       CheckRequestProperties = True
       m_State = xfsInProgress
    Else   'Form data are in allowed limit
       'Form data exceeds the limit.
       m_State = xfsSizeLimit   
    End if 'Form data are in allowed limit

   End Function

   'reads source data using BinaryRead and store them in SourceData stream
   Public Sub Read()
    if m_State <> xfsNone Then Exit Sub
    'Wscript.Echo "**Read"
    If Not CheckRequestProperties Then
       Exit Sub
    End If

    'Initialize binary store stream
    if isempty(bSourceData) then Set bSourceData = createobject("ADODB.Stream")
    bSourceData.Type = 1 'Binary

    'Initialize Read variables.
    Dim DataPart, PartSize
    BytesRead = 0
    StartUploadTime = Now

    'read source data stream in chunks of ChunkReadSize
    Do While BytesRead < TotalBytes
       'Read chunk of data
       PartSize = ChunkReadSize
       if PartSize + BytesRead > TotalBytes Then PartSize = TotalBytes - BytesRead
       DataPart = Request.BinaryRead(PartSize)
       BytesRead = BytesRead + PartSize
       'Wscript.Echo PartSize

       'Store the part size in our stream
       bSourceData.Write DataPart

       'Write progress info for secondary window.

       'Check if the client is still connected
       If Not Response.IsClientConnected Then
        m_State = xfsNoConnected 
        Exit Sub
       End If
    m_State = xfsCompleted

    'We have all source data in bSourceData stream
   End Sub

   Private Sub ParseFormData
    Dim Binary
    bSourceData.Position = 0
    Binary = bSourceData.Read
    'wscript.echo "Binary", LenB(Binary)
    m_Items.mpSeparateFields Binary, Boundary
   End Sub

   'This function reads progress info data from a temporary file.
   Public Function getForm(FormID)
    if isempty(ProgressFile.UploadID) Then 'Was UploadID of ProgressFile set?
       ProgressFile.UploadID = FormID
    End If

    'Get progress data
    Dim ProgressData
    ProgressData = ProgressFile
    if len(ProgressData) > 0 then 'There are some progress data
       if ProgressData = "DONE" Then 'Upload was done.
        Err.Raise 1, "getForm", "Upload was done"
       Else ' if ProgressData = "DONE" Then 'Upload was done.
        'm_State & vbCrLf & TotalBytes & vbCrLf & BytesRead & vbCrLf & ReadTime
        ProgressData = Split (ProgressData, vbCrLf)
        if ubound(ProgressData) = 3 Then
         m_State = clng(ProgressData(0))
         TotalBytes = clng(ProgressData(1))
         BytesRead = clng(ProgressData(2))
         m_ReadTime = clng(ProgressData(3))
        End If'if ubound(ProgressData) = 3 Then
       End If'if ProgressData = "DONE" Then 'Upload was done.
    end if'if len(ProgressData) > 0 then 'There are some progress data
    Set getForm = Me
   End Function

   'This function writes progress info data to a temporary file.
   Private Sub WriteProgressInfo
    If UploadID > 0 Then ' Is the upload ID defined? (Upload is using progress)
       if isempty(ProgressFile.UploadID) Then 'Was UploadID of ProgressFile set?
        ProgressFile.UploadID = UploadID
       End If

       Dim ProgressData, FileName
       ProgressData = m_State & vbCrLf & TotalBytes & vbCrLf & BytesRead & vbCrLf & ReadTime
       ProgressFile.Contents = ProgressData
    End If
   End Sub

   'ASPForm Constructor
   Private Sub Class_Initialize()
    ChunkReadSize = &H10000 '64 kB
    SizeLimit = &H100000 '1MB

    BytesRead = 0
    m_State = xfsNone
    TotalBytes = Request.TotalBytes

    Set ProgressFile = New cProgressFile
    Set m_Items = New cFormFields
   End Sub

   'ASPForm Destructor
   Private Sub Class_Terminate()
    If UploadID > 0 Then ' Is the upload ID defined? (Upload is using progress)
       'We have to close info about upload.
       ProgressFile.Contents = "DONE"
    End If
   End Sub

   Private Function IsInSizeLimit(TotalBytes)
    IsInSizeLimit = (m_SizeLimit = 0 or m_SizeLimit > TotalBytes) and (MaxLicensedLimit > TotalBytes)
   End Function

   Public Property Get SizeLimit
    SizeLimit = m_SizeLimit
   End Property

   'Pure - ASP upload is a free script, but with 10MB upload limit
  ' if you want to upload bigger files, please register ScriptUtilities and Huge-ASP upload
   ' at
   Public Property Let SizeLimit(NewLimit)
   if NewLimit > MaxLicensedLimit Then
       Err.Raise 1, "ASPForm - SizeLimit", "This version of Pure-ASPupload is licensed with maximum limit of 10MB (" & MaxLicensedLimit& "B)"
       m_SizeLimit = MaxLicensedLimit
       m_SizeLimit = NewLimit
    end if
   End Property

   Public Boundary
   Private m_Items
   Private m_State
   Private m_SizeLimit 'Defined form size limit.
   Private bSourceData 'ADODB.Stream
   Private StartUploadTime , TempFiolder
   Private ProgressFile 'File with info about current progress
End Class 'ASPForm
Const MaxLicensedLimit = &HA00000

'Emulates ScriptUtilities FormFields object
'We must have such class because of multiselect fields.
Class cFormFields
   Dim m_Keys()
   Dim m_Items()
   Dim m_Count

   Public Default Property Get Item(ByVal Key)
    If vartype(Key) = vbInteger or vartype(Key) = vbLong then
       'Numeric index
       if Key<1 or Key>m_Count Then Err.raise "Index out of bounds"
       Set Item = m_Items(Key-1)
       Exit Property
    end if

    'wscript.echo "**Item", Key
    Dim Count
    Count = ItemCount(Key)
    Key = LCase(Key)
    If Count > 0 then
       If Count>1 Then
        'More items
        'Get them All as an cFormFields
        Dim OutItem, ItemCounter
        Set OutItem = New cFormFields
        ItemCounter = 0
        For ItemCounter = 0 To Ubound(m_Keys)
         If LCase(m_Keys(ItemCounter)) = Key then OutItem.Add Key, m_Items(ItemCounter)
        Set Item = OutItem
        'wscript.echo "***Item-More", Key
        For ItemCounter = 0 To Ubound(m_Keys)
         If LCase(m_Keys(ItemCounter)) = Key then exit for

        if isobject (m_Items(ItemCounter)) then
         Set Item = m_Items(ItemCounter)
         Item = m_Items(ItemCounter)
        end if
        'wscript.echo "***Item-One", Key
       End If
    Else'No item
       Set Item = New cFormField
    End if
   End Property

   Public Property Get MultiItem(ByVal Key)
    'returns an array of items with the same Key
    Dim Out: Set Out = New cFormFields
    Dim I, vItem
    Dim Count
    Count = ItemCount(Key)
    if Count = 1 then
       'one key - get it from Item
       Out.Add Key, Item(Key)
    elseif Count > 1 then
       'more keys - enumerate them using Items
       For Each I In Item(Key).Items
        Out.Add Key, I
    End If

    Set MultiItem = Out
   End Property

   'For multiitem (I'm sorry, VBS does not support optional parameters for Item property)
   Public Property Get Value
    Dim I, V
    For Each I in m_Items
       V = V & ", " & I
    V = Mid(V, 3)
    Value = V
   End Property

   Public Property Get xA_NewEnum
    Set xA_NewEnum = m_Items
   End Property

   Public Property Get Items()
    'Wscript.Echo "**cFormFields-Items"   
    Items = m_Items
   End Property

   Public Property Get Keys()
    Keys = m_Keys
   End Property

   public Property Get Files
    Dim cItem, OutItem, ItemCounter
    Set OutItem = New cFormFields
    ItemCounter = 0
    if m_Count > 0 then ' Enumerate only non-empty form
       For ItemCounter = 0 To Ubound(m_Keys)
        Set cItem = m_Items(ItemCounter)
        if cItem.IsFile then
         OutItem.Add m_Keys(ItemCounter), m_Items(ItemCounter)
        end if
    End If
    Set Files = OutItem
   End Property

   Public Property Get Texts
    Dim cItem, OutItem, ItemCounter
    Set OutItem = New cFormFields
    ItemCounter = 0
    For ItemCounter = 0 To Ubound(m_Keys)
       Set cItem = m_Items(ItemCounter)
       if Not cItem.IsFile then
        OutItem.Add m_Keys(ItemCounter), m_Items(ItemCounter)
       end if
    Set Texts = OutItem
   End Property

   Public Sub Save(Path)
    Dim Item
    For Each Item In m_Items
       If Item.isFile Then
        Item.Save Path
       End If
   End Sub

   'Count of dictionary items within specified key
   Public Property Get ItemCount(ByVal Key)
    'wscript.echo "ItemCount"
    Dim cKey, Counter
    Counter = 0
    Key = LCase(Key)
    For Each cKey In m_Keys
       'wscript.echo "ItemCount", "cKey"
       If LCase(cKey) = Key then Counter = Counter + 1
    ItemCount = Counter
   End Property

   'Count of all dictionary items
   Public Property Get Count()
    Count = m_Count
   End Property

   Public Sub Add(byval Key, Item)
    Key = "" & Key
    ReDim Preserve m_Items(m_Count)
    ReDim Preserve m_Keys(m_Count)
    m_Keys(m_Count) = Key
    Set m_Items(m_Count) = Item
    m_Count = m_Count + 1
   End Sub

   Private Sub Class_Initialize()
    Dim vHelp()
    ' I do not know why, but some of VBS verrsions declares m_Items and m_Keys as Empty,
    ' not as Variant() - see class variables.
    ' vHelp eliminates this problem. V. 2.03, 2.04
    On Error Resume Next
    m_Items = vHelp
    m_Keys = vHelp
    m_Count = 0
   End Sub

   '********************************** mpSeparateFields **********************************
   'This method retrieves the upload fields from binary data
   'Binary is safearray ( VT_UI1 | VT_ARRAY ) of all multipart document raw binary data from input.
   Public Sub mpSeparateFields(Binary, ByVal Boundary)
    Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary

    Boundary = "--" & Boundary      
    Boundary = StringToBinary(Boundary)

    PosOpenBoundary = InStrB(Binary, Boundary)
    PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary, 0)

    Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not isLastBoundary)
       'Header and file/source field data
       Dim HeaderContent, bFieldContent
       'Header fields
       Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type
       'Helping variables
       Dim TwoCharsAfterEndBoundary
       'Get end of header
       PosEndOfHeader = InStrB(PosOpenBoundary + Len(Boundary), Binary, StringToBinary(vbCrLf + vbCrLf))

       'Separates field header
       HeaderContent = MidB(Binary, PosOpenBoundary +LenB(Boundary) + 2, PosEndOfHeader - PosOpenBoundary - LenB(Boundary) -2)
       'Separates field content
       bFieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary - (PosEndOfHeader + 4) - 2)
       'Separates header fields from header
       GetHeadFields BinaryToString(HeaderContent), FormFieldName, SourceFileName, Content_Disposition, Content_Type

       'Create one field and assign parameters
       Dim Field      'All field values.
       Set Field = New cFormField

       Field.ByteArray = MultiByteToBinary(bFieldContent)

       Field.Name = FormFieldName
       Field.ContentDisposition = Content_Disposition
       if not isempty(SourceFileName) then
        Field.FilePath = SourceFileName
        Field.FileName = GetFileName(SourceFileName)
        Field.FileExt = GetFileExt(SourceFileName)
       else'if not isempty(SourceFileName) then
       End If'if not isempty(SourceFileName) then
       Field.ContentType = Content_Type
       Add FormFieldName, Field

       'Is this last boundary ?
       TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, PosCloseBoundary + LenB(Boundary), 2))
       isLastBoundary = TwoCharsAfterEndBoundary = "--"

       If Not isLastBoundary Then 'This is not last boundary - go to next form field.
        PosOpenBoundary = PosCloseBoundary
        PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary)
       End If
   End Sub
End Class 'cFormFields

'This class transfers data between primary (upload) and secondary (progress) window.
Class cProgressFile
   Private fs
   Public TempFolder
   Public m_UploadID
   Public TempFileName

   Public Default Property Get Contents()
    Contents = GetFile(TempFileName)
   End Property

   Public Property Let Contents(inContents)
    WriteFile TempFileName, inContents
   End Property

   Public Sub Done 'Delete temporary file when upload was done.
    FS.DeleteFile TempFileName
   End Sub

   Public Property Get UploadID()
    UploadID = m_UploadID
   End Property

   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
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
       '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)))
  StringToBinary = B
End Function

Function BinaryToString(Binary)
  '2001 Antonin Foller, Motobit 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, Motobit 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
  MBBinaryToString = pl1 & pl2 & pl3
End Function

Function RSBinaryToString(xBinary)
  '1999 Antonin Foller, Motobit 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("mBinary").AppendChunk Binary
    RSBinaryToString = RS("mBinary")
    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("mBinary").AppendChunk MultiByte & ChrB(0)
    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)
    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
  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, "\")   '"
  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

   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
   '2.06 - zero byte file is legal
   if lenb(ByteArray)>0 then BinaryStream.Write ByteArray
   On error Resume next
   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
    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":
        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.LoadFromFile "F:\InetPub\Motobit\pureupload\2.txt"
    BinaryStream.Position = 0
    Readed = 0
   End Sub
end Class

Pages: [1]
Jump to:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.8 | SMF © 2006-2008, Simple Machines LLC Valid XHTML 1.0! Valid CSS!