<%@ Language=VBScript %>
<% 
option explicit 
Response.Expires = -1
Server.ScriptTimeout = 300
%>
<!-- #include file="freeASPUpload.asp" -->
<%

' Change the value of the variable below to the pathname
' of a directory with write permissions, for example "C:\Inetpub\wwwroot"
  Dim uploadsDirVar
  uploadsDirVar = "C:\Inetpub\wwwroot\test"

   dim Mail_smtpServer, Mail_smtpServerPort, Mail_SendUsing, Mail_smtpConnectionTimeout
   Mail_smtpServer            = "smtp.mail.com"
   Mail_smtpServerPort        = 25
   Mail_SendUsing             = 2 ' (1=localhost 2=network)
   Mail_smtpConnectionTimeout = 300 

   dim Mail_smtpAuthenticate, Mail_smtpAuthenticate_SendUserName, Mail_smtpAuthenticate_SendPassword   
   Mail_smtpAuthenticate = false
   Mail_smtpAuthenticate_SendUserName = ""
   Mail_smtpAuthenticate_SendPassword = ""

  dim Email_From, Email_To, Email_Bcc, Email_Cc, Email_Attachment_Path, Email_Attachment_File1, Email_Attachment_File2, Email_Attachment_File3, Email_Attachment_File4, Email_Subject, Email_HTML_Body, i
   Email_From            = "one@mail.com"
   Email_To              = "second@mail.com"
   Email_Bcc             = ""
   Email_Cc              = ""
   Email_Attachment_File1 = ""
   Email_Attachment_File2 = ""
   Email_Attachment_File3 = ""
   Email_Attachment_File4 = ""
   Email_Subject         = "Upload Test !"
   Email_HTML_Body       = "Another test..."

function OutputForm()
%>
    <form name="frmSend" method="POST" enctype="multipart/form-data" action="uploadTester.asp" onSubmit="return onSubmitForm();">
	<B>File names:</B><br>
    File 1: <input name="F_Email_Attachment_File1" type="file" size=35><br>
    File 2: <input name="F_Email_Attachment_File2" type="file" size=35><br>
    File 3: <input name="F_Email_Attachment_File3" type="file" size=35><br>
    File 4: <input name="F_Email_Attachment_File4" type="file" size=35><br>
    <br> 
	<!-- These input elements are obviously optional and just included here for demonstration purposes
	<B>Additional fields (demo):</B><br>
	Enter a number: <input type="text" name="enter_a_number"><br>
    Checkbox values: <input type="checkbox" value="1" name="checkbox_values">-1 <input type="checkbox" value="2" name="checkbox_values">-2<br>
	End of additional elements -->
    <input style="margin-top:4" type=submit value="Upload">
    </form>
<%
end function

function TestEnvironment()
    Dim fso, fileName, testFile, streamTest
    TestEnvironment = ""
    Set fso = Server.CreateObject("Scripting.FileSystemObject")
    if not fso.FolderExists(uploadsDirVar) then
        TestEnvironment = "<B>Folder " & uploadsDirVar & " does not exist.</B><br>The value of your uploadsDirVar is incorrect. Open uploadTester.asp in an editor and change the value of uploadsDirVar to the pathname of a directory with write permissions."
        exit function
    end if
    fileName = uploadsDirVar & "\test.txt"
    on error resume next
    Set testFile = fso.CreateTextFile(fileName, true)
    If Err.Number<>0 then
        TestEnvironment = "<B>Folder " & uploadsDirVar & " does not have write permissions.</B><br>The value of your uploadsDirVar is incorrect. Open uploadTester.asp in an editor and change the value of uploadsDirVar to the pathname of a directory with write permissions."
        exit function
    end if
    Err.Clear
    testFile.Close
    fso.DeleteFile(fileName) 'Do we want to delete the file ? YES we do !
    If Err.Number<>0 then
        TestEnvironment = "<B>Folder " & uploadsDirVar & " does not have delete permissions</B>, although it does have write permissions.<br>Change the permissions for IUSR_<I>computername</I> on this folder."
        exit function
    end if
    Err.Clear
    Set streamTest = Server.CreateObject("ADODB.Stream")
    If Err.Number<>0 then
        TestEnvironment = "<B>The ADODB object <I>Stream</I> is not available in your server.</B><br>Check the Requirements page for information about upgrading your ADODB libraries."
        exit function
    end if
    Set streamTest = Nothing
end function

Dim Upload
 Set Upload = New FreeASPUpload

  Send_CDOSYS_Email Email_From, Email_To, Email_Bcc, Email_Cc, Email_Attachment_Path, Email_Attachment_File1, Email_Attachment_File2, Email_Attachment_File3, Email_Attachment_File4, Email_Subject, Email_HTML_Body


function SaveFiles(Upload)
    Dim fileName, fileSize, ks, i, fileKey ,attachment


    Upload.Save(uploadsDirVar)

	' If something fails inside the script, but the exception is handled
	If Err.Number<>0 then Exit function

    SaveFiles = ""
    ks = Upload.UploadedFiles.keys
    if (UBound(ks) <> -1) Then
		attachment= ""
        SaveFiles = "<B>Files uploaded:</B> "
        i=0
		for each fileKey in Upload.UploadedFiles.keys
			i=i+1
			Email_Attachment_Path = uploadsDirVar & "\"		

			Select Case i
			Case 1
				Email_Attachment_File1 = Upload.UploadedFiles(fileKey).FileName
			Case 2
				Email_Attachment_File2 = Upload.UploadedFiles(fileKey).FileName
			Case 3
				Email_Attachment_File3 = Upload.UploadedFiles(fileKey).FileName
			Case 4
				Email_Attachment_File4 = Upload.UploadedFiles(fileKey).FileName
			End Select
			
            SaveFiles = SaveFiles & Upload.UploadedFiles(fileKey).FileName & " (" & Upload.UploadedFiles(fileKey).Length & "B) "
        next
    else
        SaveFiles = "The file name specified in the upload form does not correspond to a valid file in the system."
    end if
'	SaveFiles = SaveFiles & "<br>Enter a number = " & Upload.Form("enter_a_number") & "<br>"
'	SaveFiles = SaveFiles & "Checkbox values = " & Upload.Form("checkbox_values") & "<br>"
end function

 ' Send_CDOSYS_Email
  '-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
   sub Send_CDOSYS_Email(F_Email_From, F_Email_To, F_Email_Bcc, F_Email_Cc, F_Email_Attachment_Path, F_Email_Attachment_File1 , F_Email_Attachment_File2 , F_Email_Attachment_File3, F_Email_Attachment_File4, F_Email_Subject, F_Email_HTML_Body)
    dim objCDOSYSCon, objCDOSYSMail,b

    set objCDOSYSMail = CreateObject("CDO.Message")
    set objCDOSYSCon  = CreateObject("CDO.Configuration")

    if Mail_smtpAuthenticate then
       objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 
       objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername")     = Mail_smtpAuthenticate_SendUserName
       objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword")     = Mail_smtpAuthenticate_SendPassword
    end if

    objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver")            = Mail_smtpServer
    objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport")        = Mail_smtpServerPort
    objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing")             = Mail_SendUsing
    objCDOSYSCon.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = Mail_smtpConnectionTimeout
    objCDOSYSCon.Fields.Update 

    set objCDOSYSMail.Configuration = objCDOSYSCon 
    set b = objCDOSYSMail.bodypart 
    b.charset = "utf-8"
    objCDOSYSMail.From = F_Email_From
    objCDOSYSMail.To = F_Email_To
    objCDOSYSMail.CC = F_Email_Cc
    objCDOSYSMail.BCC = F_Email_Bcc

    objCDOSYSMail.AddAttachment F_Email_Attachment_Path & F_Email_Attachment_File1, "", ""
    objCDOSYSMail.AddAttachment F_Email_Attachment_Path & F_Email_Attachment_File2, "", ""
    objCDOSYSMail.AddAttachment F_Email_Attachment_Path & F_Email_Attachment_File3, "", ""
    objCDOSYSMail.AddAttachment F_Email_Attachment_Path & F_Email_Attachment_File4, "", ""
	objCDOSYSMail.Subject = F_Email_Subject
    objCDOSYSMail.HTMLBody = F_Email_HTML_Body

    objCDOSYSMail.Send

    set objCDOSYSMail = Nothing 
    set objCDOSYSCon = Nothing
   end sub
%>

<HTML>
<HEAD>
<TITLE>ASP Upload</TITLE>
<style>
BODY {background-color: white;font-family:arial; font-size:12}
</style>
<script>
function onSubmitForm() {
    var formDOMObj = document.frmSend;
    if (formDOMObj.F_Email_Attachment_File1.value == "" && formDOMObj.F_Email_Attachment_File2.value == "" && formDOMObj.F_Email_Attachment_File3.value == "" && formDOMObj.F_Email_Attachment_File4.value == "" )
        alert("Please press the browse button and pick a file.")
    else
        return true;
    return false;
}
</script>

</HEAD>

<BODY>

<br><br>
<div style="border-bottom: #A91905 2px solid;font-size:16">Upload files to your server</div>
<%
Dim diagnostics
if Request.ServerVariables("REQUEST_METHOD") <> "POST" then
    diagnostics = TestEnvironment()
    if diagnostics<>"" then
        response.write "<div style=""margin-left:20; margin-top:30; margin-right:30; margin-bottom:30;"">"
        response.write diagnostics
        response.write "<p>After you correct this problem, reload the page."
        response.write "</div>"
    else
        response.write "<div style=""margin-left:150"">"
        OutputForm()
        response.write "</div>"
    end if
else
    response.write "<div style=""margin-left:150"">"
    OutputForm()
    response.write SaveFiles(Upload)
    response.write "<br><br></div>"
end if

%>

<br><br>
</BODY>
</HTML>

<%
'  http://www.freeaspupload.net

Class FreeASPUpload
	Public UploadedFiles
	Public FormElements

	Private VarArrayBinRequest
	Private StreamRequest
	Private uploadedYet

	Private Sub Class_Initialize()
		Set UploadedFiles = Server.CreateObject("Scripting.Dictionary")
		Set FormElements = Server.CreateObject("Scripting.Dictionary")
		Set StreamRequest = Server.CreateObject("ADODB.Stream")
		StreamRequest.Type = 1 'adTypeBinary
		StreamRequest.Open
		uploadedYet = false
	End Sub
	
	Private Sub Class_Terminate()
		If IsObject(UploadedFiles) Then
			UploadedFiles.RemoveAll()
			Set UploadedFiles = Nothing
		End If
		If IsObject(FormElements) Then
			FormElements.RemoveAll()
			Set FormElements = Nothing
		End If
		StreamRequest.Close
		Set StreamRequest = Nothing
	End Sub

	Public Property Get Form(sIndex)
		Form = ""
		If FormElements.Exists(LCase(sIndex)) Then Form = FormElements.Item(LCase(sIndex))
	End Property

	Public Property Get Files()
		Files = UploadedFiles.Items
	End Property

	'Calls Upload to extract the data from the binary request and then saves the uploaded files
	Public Sub Save(path)
		Dim streamFile, fileItem

		if Right(path, 1) <> "\" then path = path & "\"

		if not uploadedYet then Upload

		For Each fileItem In UploadedFiles.Items
			Set streamFile = Server.CreateObject("ADODB.Stream")
			streamFile.Type = 1
			streamFile.Open
			StreamRequest.Position=fileItem.Start
			StreamRequest.CopyTo streamFile, fileItem.Length
			streamFile.SaveToFile path & fileItem.FileName, 2
			streamFile.close
			Set streamFile = Nothing
			fileItem.Path = path & fileItem.FileName
		 Next
	End Sub

	Public Function SaveBinRequest(path) ' For debugging purposes
		StreamRequest.SaveToFile path & "\debugStream.bin", 2
	End Function

	Public Sub DumpData() 'only works if files are plain text
		Dim i, aKeys, f
		response.write "Form Items:<br>"
		aKeys = FormElements.Keys
		For i = 0 To FormElements.Count -1 ' Iterate the array
			response.write aKeys(i) & " = " & FormElements.Item(aKeys(i)) & "<BR>"
		Next
		response.write "Uploaded Files:<br>"
		For Each f In UploadedFiles.Items
			response.write "Name: " & f.FileName & "<br>"
			response.write "Type: " & f.ContentType & "<br>"
			response.write "Start: " & f.Start & "<br>"
			response.write "Size: " & f.Length & "<br>"
		 Next
   	End Sub

	Private Sub Upload()
		Dim nCurPos, nDataBoundPos, nLastSepPos
		Dim nPosFile, nPosBound
		Dim sFieldName, osPathSep, auxStr

		'RFC1867 Tokens
		Dim vDataSep
		Dim tNewLine, tDoubleQuotes, tTerm, tFilename, tName, tContentDisp, tContentType
		tNewLine = Byte2String(Chr(13))
		tDoubleQuotes = Byte2String(Chr(34))
		tTerm = Byte2String("--")
		tFilename = Byte2String("filename=""")
		tName = Byte2String("name=""")
		tContentDisp = Byte2String("Content-Disposition")
		tContentType = Byte2String("Content-Type:")

		uploadedYet = true

		on error resume next
		VarArrayBinRequest = Request.BinaryRead(Request.TotalBytes)
		if Err.Number <> 0 then 
			response.write "<br><br><B>System reported this error:</B><p>"
			response.write Err.Description & "<p>"
			response.write "The most likely cause for this error is the incorrect setup of AspMaxRequestEntityAllowed in IIS MetaBase. Please see instructions in the <A HREF='http://www.freeaspupload.net/freeaspupload/requirements.asp'>requirements page of freeaspupload.net</A>.<p>"
			Exit Sub
		end if
		on error goto 0 'reset error handling

		nCurPos = FindToken(tNewLine,1) 'Note: nCurPos is 1-based (and so is InstrB, MidB, etc)

		If nCurPos <= 1  Then Exit Sub
		 
		'vDataSep is a separator like -----------------------------21763138716045
		vDataSep = MidB(VarArrayBinRequest, 1, nCurPos-1)

		'Start of current separator
		nDataBoundPos = 1

		'Beginning of last line
		nLastSepPos = FindToken(vDataSep & tTerm, 1)

		Do Until nDataBoundPos = nLastSepPos
			
			nCurPos = SkipToken(tContentDisp, nDataBoundPos)
			nCurPos = SkipToken(tName, nCurPos)
			sFieldName = ExtractField(tDoubleQuotes, nCurPos)

			nPosFile = FindToken(tFilename, nCurPos)
			nPosBound = FindToken(vDataSep, nCurPos)
			
			If nPosFile <> 0 And  nPosFile < nPosBound Then
				Dim oUploadFile
				Set oUploadFile = New UploadedFile
				
				nCurPos = SkipToken(tFilename, nCurPos)
				auxStr = ExtractField(tDoubleQuotes, nCurPos)
                ' We are interested only in the name of the file, not the whole path
                ' Path separator is \ in windows, / in UNIX
                ' While IE seems to put the whole pathname in the stream, Mozilla seem to 
                ' only put the actual file name, so UNIX paths may be rare. But not impossible.
                osPathSep = "\"
                if InStr(auxStr, osPathSep) = 0 then osPathSep = "/"
				oUploadFile.FileName = Right(auxStr, Len(auxStr)-InStrRev(auxStr, osPathSep))

				if (Len(oUploadFile.FileName) > 0) then 'File field not left empty
					nCurPos = SkipToken(tContentType, nCurPos)
					
                    auxStr = ExtractField(tNewLine, nCurPos)
                    ' NN on UNIX puts things like this in the streaa:
                    '    ?? python py type=?? python application/x-python
					oUploadFile.ContentType = Right(auxStr, Len(auxStr)-InStrRev(auxStr, " "))
					nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line
					
					oUploadFile.Start = nCurPos-1
					oUploadFile.Length = FindToken(vDataSep, nCurPos) - 2 - nCurPos
					
					If oUploadFile.Length > 0 Then UploadedFiles.Add LCase(sFieldName), oUploadFile
				End If
			Else
				Dim nEndOfData
				nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line
				nEndOfData = FindToken(vDataSep, nCurPos) - 2
				If Not FormElements.Exists(LCase(sFieldName)) Then 
					FormElements.Add LCase(sFieldName), String2Byte(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos))
				else
                    FormElements.Item(LCase(sFieldName))= FormElements.Item(LCase(sFieldName)) & ", " & String2Byte(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos)) 
                end if 

			End If

			'Advance to next separator
			nDataBoundPos = FindToken(vDataSep, nCurPos)
		Loop
		StreamRequest.Write(VarArrayBinRequest)
	End Sub

	Private Function SkipToken(sToken, nStart)
		SkipToken = InstrB(nStart, VarArrayBinRequest, sToken)
		If SkipToken = 0 then
			Response.write "Error in parsing uploaded binary request."
			Response.End
		end if
		SkipToken = SkipToken + LenB(sToken)
	End Function

	Private Function FindToken(sToken, nStart)
		FindToken = InstrB(nStart, VarArrayBinRequest, sToken)
	End Function

	Private Function ExtractField(sToken, nStart)
		Dim nEnd
		nEnd = InstrB(nStart, VarArrayBinRequest, sToken)
		If nEnd = 0 then
			Response.write "Error in parsing uploaded binary request."
			Response.End
		end if
		ExtractField = String2Byte(MidB(VarArrayBinRequest, nStart, nEnd-nStart))
	End Function

	'String to byte string conversion
	Private Function Byte2String(sString)
		Dim i
		For i = 1 to Len(sString)
		   Byte2String = Byte2String & ChrB(AscB(Mid(sString,i,1)))
		Next
	End Function

	'Byte string to string conversion
	Private Function String2Byte(bsString)
		Dim i
		String2Byte =""
		For i = 1 to LenB(bsString)
		   String2Byte = String2Byte & Chr(AscB(MidB(bsString,i,1))) 
		Next
	End Function
End Class

Class UploadedFile
	Public ContentType
	Public Start
	Public Length
	Public Path
	Private nameOfFile

    ' Need to remove characters that are valid in UNIX, but not in Windows
    Public Property Let FileName(fN)
        nameOfFile = fN
        nameOfFile = SubstNoReg(nameOfFile, "\", "_")
        nameOfFile = SubstNoReg(nameOfFile, "/", "_")
        nameOfFile = SubstNoReg(nameOfFile, ":", "_")
        nameOfFile = SubstNoReg(nameOfFile, "*", "_")
        nameOfFile = SubstNoReg(nameOfFile, "?", "_")
        nameOfFile = SubstNoReg(nameOfFile, """", "_")
        nameOfFile = SubstNoReg(nameOfFile, "<", "_")
        nameOfFile = SubstNoReg(nameOfFile, ">", "_")
        nameOfFile = SubstNoReg(nameOfFile, "|", "_")
    End Property

    Public Property Get FileName()
        FileName = nameOfFile
    End Property

    'Public Property Get FileN()ame
End Class


' Does not depend on RegEx, which is not available on older VBScript
' Is not recursive, which means it will not run out of stack space
Function SubstNoReg(initialStr, oldStr, newStr)
    Dim currentPos, oldStrPos, skip
    If IsNull(initialStr) Or Len(initialStr) = 0 Then
        SubstNoReg = ""
    ElseIf IsNull(oldStr) Or Len(oldStr) = 0 Then
        SubstNoReg = initialStr
    Else
        If IsNull(newStr) Then newStr = ""
        currentPos = 1
        oldStrPos = 0
        SubstNoReg = ""
        skip = Len(oldStr)
        Do While currentPos <= Len(initialStr)
            oldStrPos = InStr(currentPos, initialStr, oldStr)
            If oldStrPos = 0 Then
                SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, Len(initialStr) - currentPos + 1)
                currentPos = Len(initialStr) + 1
            Else
                SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, oldStrPos - currentPos) & newStr
                currentPos = oldStrPos + skip
            End If
        Loop
    End If
End Function
%>

Function RSBinaryToString(xBinary)
  'Antonin Foller, http://www.motobit.com
  'RSBinaryToString converts binary data (VT_UI1 | VT_ARRAY Or MultiByte string)
  'to a string (BSTR) using ADO recordset

  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