<SCRIPT LANGUAGE="VBSCRIPT" RUNAT="SERVER">
'*** Pure ASP File Upload -----------------------------------------------------
' Copyright 2001-2003 (c) George Petrov, www.DMXzone.com
' Version: 2.13
'------------------------------------------------------------------------------

Function getPureUploadVersion()
  getPureUploadVersion = 2.13
End Function

Sub PureUploadSetup()
  If (CStr(Request.QueryString("GP_upload")) <> "") Then
    UploadQueryString = Replace(Request.QueryString,"GP_upload=true","")
    if left(UploadQueryString,1) = "&" or left(UploadQueryString,1) = "?" then
    	UploadQueryString = Mid(UploadQueryString,2)
    end if
    if right(UploadQueryString,1) = "&" then
    	UploadQueryString = Mid(UploadQueryString,1,len(UploadQueryString)-1)
    end if	
  else  
	UploadQueryString = Request.QueryString
    If (UploadQueryString <> "") Then  
		UploadQueryString = UploadQueryString & "&GP_upload=true"
	else
		UploadQueryString = "GP_upload=true"
	end if	
    GP_uploadAction = CStr(Request.ServerVariables("URL")) & "?" & UploadQueryString
  end if  
End Sub

Sub ProcessUpload(pau_thePath,pau_Extensions,pau_Redirect,pau_storeType,pau_sizeLimit,pau_nameConflict,pau_requireUpload,pau_minWidth,pau_minHeight,pau_maxWidth,pau_maxHeight,pau_saveWidth,pau_saveHeight,pau_timeout)

  Server.ScriptTimeout = pau_timeout
  
  pau_doPreUploadChecks pau_sizeLimit
  RequestBin = Request.BinaryRead(Request.TotalBytes)
  Set UploadRequest = CreateObject("Scripting.Dictionary")  
  pau_BuildUploadRequest RequestBin, pau_thePath, pau_storeType, pau_sizeLimit, pau_nameConflict
  
  If pau_Redirect <> "" Then
    If UploadQueryString <> "" Then
      pau_Redirect = pau_Redirect & "?" & UploadQueryString
    End If
    Response.Redirect(pau_Redirect)  
  end if  

End Sub

Sub pau_doPreUploadChecks(sizeLimit)
  Dim checkADOConn, AdoVersion, Length
  'Check ADO Version
	set checkADOConn = Server.CreateObject("ADODB.Connection")
  on error resume next
	adoVersion = CSng(checkADOConn.Version)
	if err then 
		adoVersion = Replace(checkADOConn.Version,".",",")  
		adoVersion = CSng(adoVersion)
	end if	
	err.clear
  on error goto 0	
	set checkADOConn = Nothing
	if adoVersion < 2.5 then
    Response.Write "<b>You don't have ADO 2.5 installed on the server.</b><br>"
    Response.Write "The File Upload extension needs ADO 2.5 or greater to run properly.<br>"
    Response.Write "You can download the latest MDAC (ADO is included) from <a href=""www.microsoft.com/data"">www.microsoft.com/data</a><br>"
    Response.End
	end if		
  'Check content length if needed
	Length = CLng(Request.ServerVariables("HTTP_Content_Length")) 'Get Content-Length header
	If sizeLimit <> "" Then
    sizeLimit = CLng(sizeLimit) * 1024
    If Length > sizeLimit Then
      Response.Write "Upload size " & FormatNumber(Length, 0) & "B exceeds limit of " & FormatNumber(sizeLimit, 0) & "B<br>"
      Response.Write "Please correct and <A HREF=""javascript:history.back(1)"">try again</a>"      
      Response.End
    End If
  End If

End Sub


Sub CheckPureUploadVersion(pau_version)
  Dim foundPureUploadVersion
  foundPureUploadVersion = getPureUploadVersion()
  if err or reqPureUploadVersion > foundPureUploadVersion then
    Response.Write "<b>You don't have latest version of ScriptLibrary/incPureUpload.asp uploaded on the server.</b><br>"
    Response.Write "This library is required for the current page. It is fully backwards compatible so old pages will work as well.<br>"
    Response.End    
  end if
End Sub

Sub pau_BuildUploadRequest(RequestBin,UploadDirectory,storeType,sizeLimit,nameConflict)

  Dim PosBeg, PosEnd, boundary, boundaryPos, Pos
  Dim PosFile, Name, PosBound, FileName, ContentType, Value, ValueBeg, ValueEnd, ValueLen
  
  'Get the boundary
  PosBeg = 1
  PosEnd = InstrB(PosBeg,RequestBin,pau_getByteString(chr(13)))
  if PosEnd = 0 then
    Response.Write "<b>Form was submitted with no ENCTYPE=""multipart/form-data""</b><br>"
    Response.Write "Please correct and <A HREF=""javascript:history.back(1)"">try again</a>"    
    Response.End
  end if
  boundary = MidB(RequestBin,PosBeg,PosEnd-PosBeg)
  boundaryPos = InstrB(1,RequestBin,boundary)
  'Get all data inside the boundaries
  Do until (boundaryPos=InstrB(RequestBin,boundary & pau_getByteString("--")))
    'Members variable of objects are put in a dictionary object
    Dim UploadControl
    Set UploadControl = CreateObject("Scripting.Dictionary")
    'Get an object name
    Pos = InstrB(BoundaryPos,RequestBin,pau_getByteString("Content-Disposition"))
    Pos = InstrB(Pos,RequestBin,pau_getByteString("name="))
    PosBeg = Pos+6
    PosEnd = InstrB(PosBeg,RequestBin,pau_getByteString(chr(34)))
    Name = LCase(pau_getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg)))
    PosFile = InstrB(BoundaryPos,RequestBin,pau_getByteString("filename="))
    PosBound = InstrB(PosEnd,RequestBin,boundary)
    'Test if object is of file type
    If  PosFile<>0 AND (PosFile<PosBound) Then
      'Get Filename, content-type and content of file
      PosBeg = PosFile + 10
      PosEnd =  InstrB(PosBeg,RequestBin,pau_getByteString(chr(34)))
      FileName = pau_getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
      FileName = pau_RemoveInvalidChars(Mid(FileName,InStrRev(FileName,"\")+1))
      'Add filename to dictionary object
      UploadControl.Add "FileName", FileName
      Pos = InstrB(PosEnd,RequestBin,pau_getByteString("Content-Type:"))
      PosBeg = Pos+14
      PosEnd = InstrB(PosBeg,RequestBin,pau_getByteString(chr(13)))
      'Add content-type to dictionary object
      ContentType = pau_getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
      UploadControl.Add "ContentType",ContentType
      'Get content of object
      PosBeg = PosEnd+4
      PosEnd = InstrB(PosBeg,RequestBin,boundary)-2
      Value = FileName
      ValueBeg = PosBeg-1
      ValueLen = PosEnd-Posbeg
    Else
      'Get content of object
      Pos = InstrB(Pos,RequestBin,pau_getByteString(chr(13)))
      PosBeg = Pos+4
      PosEnd = InstrB(PosBeg,RequestBin,boundary)-2
      Value = pau_getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
      ValueBeg = 0
      ValueEnd = 0
    End If
    'Add content to dictionary object
    UploadControl.Add "Value" , Value	
    UploadControl.Add "ValueBeg" , ValueBeg
    UploadControl.Add "ValueLen" , ValueLen	
    'Add dictionary object to main dictionary
    if UploadRequest.Exists(name) then
      UploadRequest(name).Item("Value") = UploadRequest(name).Item("Value") & "," & Value
    else
      UploadRequest.Add name, UploadControl 
    end if    
    'Loop to next object
    BoundaryPos=InstrB(BoundaryPos+LenB(boundary),RequestBin,boundary)
  Loop

  Dim GP_keys, GP_i, GP_curKey, GP_value, GP_valueBeg, GP_valueLen, GP_curPath, GP_FullPath
  Dim GP_CurFileName, GP_FullFileName, fso, GP_BegFolder, GP_RelFolder, GP_FileExist, Begin_Name_Num
  Dim orgUploadDirectory
    
  if InStr(UploadDirectory,"""") > 0 then 
    on error resume next
    orgUploadDirectory = UploadDirectory
    UploadDirectory = eval(UploadDirectory)  
    if err then
      Response.Write "<B>Upload folder is invalid</B><br><br>"      
      Response.Write "Upload Folder: " & Trim(orgUploadDirectory) & "<br>"
      Response.Write "Please correct and <A HREF=""javascript:history.back(1)"">try again</a>"
		  err.clear
 	    response.End
    end if    
    on error goto 0
  end if  
  
  GP_keys = UploadRequest.Keys
  for GP_i = 0 to UploadRequest.Count - 1
    GP_curKey = GP_keys(GP_i)
    'Save all uploaded files
    if UploadRequest.Item(GP_curKey).Item("FileName") <> "" then
      GP_value = UploadRequest.Item(GP_curKey).Item("Value")
      GP_valueBeg = UploadRequest.Item(GP_curKey).Item("ValueBeg")
      GP_valueLen = UploadRequest.Item(GP_curKey).Item("ValueLen")

      'Get the path
      if InStr(UploadDirectory,"\") > 0 then
        GP_curPath = UploadDirectory
        if Mid(GP_curPath,Len(GP_curPath),1)  <> "\" then
          GP_curPath = GP_curPath & "\"
        end if         
        GP_FullPath = GP_curPath
      else
        GP_curPath = Request.ServerVariables("PATH_INFO")
        GP_curPath = Trim(Mid(GP_curPath,1,InStrRev(GP_curPath,"/")) & UploadDirectory)
        if Mid(GP_curPath,Len(GP_curPath),1)  <> "/" then
          GP_curPath = GP_curPath & "/"
        end if 
        GP_FullPath = Trim(Server.mappath(GP_curPath))
      end if

      
      if GP_valueLen = 0 then
        Response.Write "<B>An error has occured saving uploaded file!</B><br><br>"
        Response.Write "Filename: " & Trim(GP_curPath) & UploadRequest.Item(GP_curKey).Item("FileName") & "<br>"
        Response.Write "File does not exists or is empty.<br>"
        Response.Write "Please correct and <A HREF=""javascript:history.back(1)"">try again</a>"
	  	  response.End
	    end if
      
      'Create a Stream instance
      Dim GP_strm1, GP_strm2
      Set GP_strm1 = Server.CreateObject("ADODB.Stream")
      Set GP_strm2 = Server.CreateObject("ADODB.Stream")
      
      'Open the stream
      GP_strm1.Open
      GP_strm1.Type = 1 'Binary
      GP_strm2.Open
      GP_strm2.Type = 1 'Binary
        
      GP_strm1.Write RequestBin
      GP_strm1.Position = GP_ValueBeg
      GP_strm1.CopyTo GP_strm2,GP_ValueLen
    
      'Create and Write to a File
      GP_CurFileName = UploadRequest.Item(GP_curKey).Item("FileName")      
      GP_FullFileName = GP_FullPath & "\" & GP_CurFileName
      Set fso = CreateObject("Scripting.FileSystemObject")
      pau_AutoCreatePath GP_FullPath
      'Check if the file already exist
      GP_FileExist = false
      If fso.FileExists(GP_FullFileName) Then
        GP_FileExist = true
      End If      
      if nameConflict = "error" and GP_FileExist then
        Response.Write "<B>File already exists!</B><br><br>"
        Response.Write "Please correct and <A HREF=""javascript:history.back(1)"">try again</a>"
				GP_strm1.Close
				GP_strm2.Close
	  	  response.End
      end if
      if ((nameConflict = "over" or nameConflict = "uniq") and GP_FileExist) or (NOT GP_FileExist) then
        if nameConflict = "uniq" and GP_FileExist then
          Begin_Name_Num = 0
          while GP_FileExist    
            Begin_Name_Num = Begin_Name_Num + 1
            GP_FullFileName = Trim(GP_FullPath)& "\" & fso.GetBaseName(GP_CurFileName) & "_" & Begin_Name_Num & "." & fso.GetExtensionName(GP_CurFileName)
            GP_FileExist = fso.FileExists(GP_FullFileName)
          wend  
          UploadRequest.Item(GP_curKey).Item("FileName") = fso.GetBaseName(GP_CurFileName) & "_" & Begin_Name_Num & "." & fso.GetExtensionName(GP_CurFileName)
					UploadRequest.Item(GP_curKey).Item("Value") = UploadRequest.Item(GP_curKey).Item("FileName")
        end if
        on error resume next
        GP_strm2.SaveToFile GP_FullFileName,2
        if err then
          Response.Write "<B>An error has occured saving uploaded file!</B><br><br>"
          Response.Write "Filename: " & Trim(GP_curPath) & UploadRequest.Item(GP_curKey).Item("FileName") & "<br>"
          Response.Write "Maybe the destination directory does not exist, or you don't have write permission.<br>"
          Response.Write "Please correct and <A HREF=""javascript:history.back(1)"">try again</a>"
    		  err.clear
  				GP_strm1.Close
  				GP_strm2.Close
  	  	  response.End
  	    end if
  			GP_strm1.Close
  			GP_strm2.Close
  			if storeType = "path" then
  				UploadRequest.Item(GP_curKey).Item("Value") = GP_curPath & UploadRequest.Item(GP_curKey).Item("Value")
  			end if
        on error goto 0
      end if
    end if
  next

End Sub

Sub pau_AutoCreatePath(PAU_FullPath)
  Dim FL_fso, FL_EndPos, PAU_NewPath
  Set FL_fso = CreateObject("Scripting.FileSystemObject")  
  if not FL_fso.FolderExists(PAU_FullPath) then
    FL_EndPos = InStrRev(PAU_FullPath,"\")
    if FL_EndPos > 0 then
      PAU_NewPath = Left(PAU_FullPath,FL_EndPos-1)
      pau_AutoCreatePath PAU_NewPath
      on error resume next
  	  FL_fso.CreateFolder PAU_FullPath
      if err.number <> 0 then
        Response.Write "<B>Can not create upload folder path: " & PAU_FullPath & "!</B><br>"
        Response.Write "Maybe you don't have enough permissions<br><br>"        
        Response.Write "Please correct and <A HREF=""javascript:history.back(1)"">try again</a>"
	  	Response.End        
      end if
	  on error goto 0
    end if  
  end if
  Set FL_fso = nothing
End Sub

'String to byte string conversion
Function pau_getByteString(StringStr)
  Dim i, char
  For i = 1 to Len(StringStr)
 	  char = Mid(StringStr,i,1)
	  pau_getByteString = pau_getByteString & chrB(AscB(char))
  Next
End Function

'Byte string to string conversion (with double-byte support now)
Function pau_getString(StringBin)
  Dim intCount,get1Byte
  pau_getString = ""
  For intCount = 1 to LenB(StringBin)
    get1Byte = MidB(StringBin,intCount,1)
    pau_getString = pau_getString & chr(AscB(get1Byte)) 
  Next
End Function

Function UploadFormRequest(name)
  Dim keyName
  keyName = LCase(name)
  if IsObject(UploadRequest) then
    if UploadRequest.Exists(keyName) then
      if UploadRequest.Item(keyName).Exists("Value") then
        UploadFormRequest = UploadRequest.Item(keyName).Item("Value")
      end if  
    end if  
  end if  
End Function

Function pau_RemoveInvalidChars(str)
  Dim newStr, ci, curChar
  for ci = 1 to Len(str)
    curChar = Asc(LCase(Mid(str,ci,1)))
    if curChar = 95 or curChar >= 97 or (curChar >= 45 and curChar <= 57) then
      newStr = newStr & Mid(str,ci,1)
    end if
  next
  pau_RemoveInvalidChars = newStr
End Function

Function FixFieldsForUpload(GP_fieldsStr, GP_columnsStr)
  Dim GP_counter, GP_Fields, GP_Columns, GP_FieldName, GP_FieldValue, GP_CurFileName, GP_CurContentType

  GP_Fields = Split(GP_fieldsStr, "|")
  GP_Columns = Split(GP_columnsStr, "|") 
  GP_fieldsStr = ""
  ' Get the form values
  For GP_counter = LBound(GP_Fields) To UBound(GP_Fields) Step 2
    GP_FieldName = LCase(GP_Fields(GP_counter))
    GP_FieldValue = GP_Fields(GP_counter+1)
  	if UploadRequest.Exists(GP_FieldName) then
      GP_CurFileName = UploadRequest.Item(GP_FieldName).Item("FileName")
      GP_CurContentType = UploadRequest.Item(GP_FieldName).Item("ContentType")
  	else  
	    GP_CurFileName = ""
	    GP_CurContentType = ""
  	end if	
    if (GP_CurFileName = "" and GP_CurContentType = "") or (GP_CurFileName <> "" and GP_CurContentType <> "") then
      GP_fieldsStr = GP_fieldsStr & GP_FieldName & "|" & GP_FieldValue & "|"
    end if 
  Next
  if GP_fieldsStr <> "" then
    GP_fieldsStr = Mid(GP_fieldsStr,1,Len(GP_fieldsStr)-1)
  else  
    Response.Write "<B>An error has occured during record update!</B><br><br>"
    Response.Write "There are no fields to update ...<br>"
    Response.Write "If the file upload field is the only field on your form, you should make it required.<br>"
    Response.Write "Please correct and <A HREF=""javascript:history.back(1)"">try again</a>"
    Response.End
  end if
  
  FixFieldsForUpload = GP_fieldsStr    
End Function

Function FixColumnsForUpload(GP_fieldsStr, GP_columnsStr)
  Dim GP_counter, GP_Fields, GP_Columns, GP_FieldName, GP_ColumnName, GP_ColumnValue,GP_CurFileName, GP_CurContentType

  GP_Fields = Split(GP_fieldsStr, "|")
  GP_Columns = Split(GP_columnsStr, "|") 
  GP_columnsStr = "" 
  ' Get the form values
  For GP_counter = LBound(GP_Fields) To UBound(GP_Fields) Step 2
    GP_FieldName = LCase(GP_Fields(GP_counter))  
    GP_ColumnName = GP_Columns(GP_counter)  
    GP_ColumnValue = GP_Columns(GP_counter+1)
  	if UploadRequest.Exists(GP_FieldName) then
  	  GP_CurFileName = UploadRequest.Item(GP_FieldName).Item("FileName")
  	  GP_CurContentType = UploadRequest.Item(GP_FieldName).Item("ContentType")	  
  	else  
  	  GP_CurFileName = ""
  	  GP_CurContentType = ""
  	end if  
    if (GP_CurFileName = "" and GP_CurContentType = "") or (GP_CurFileName <> "" and GP_CurContentType <> "") then
      GP_columnsStr = GP_columnsStr & GP_ColumnName & "|" & GP_ColumnValue & "|"
    end if 
  Next
  if GP_columnsStr <> "" then
    GP_columnsStr = Mid(GP_columnsStr,1,Len(GP_columnsStr)-1)    
  end if
  FixColumnsForUpload = GP_columnsStr
End Function

</SCRIPT>
