Results 1 to 4 of 4
  1. #1
    Join Date
    Aug 2006
    Location
    Athens - Greece
    Posts
    22

    Unhappy Unanswered: Upload files and send e-mail using CDOSYS

    What I am trying to do is to upload 4 files to my server (Windows 2003 Server Edition , IIS 6.0) and then e-mail them to my e-mail account.
    I use 2 files. The first is uploadTester.asp...

    Code:
    <%@ 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>
    Visit...
    http://kanenas.net
    News and Ideas about programming

  2. #2
    Join Date
    Aug 2006
    Location
    Athens - Greece
    Posts
    22
    ...and the second file is the one I include... freeASPUpload.asp
    Code:
    <%
    '  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
    %>
    As you all may see it is a tested set...
    http://www.freeaspupload.net
    with a few changes and addons !
    The problem is that the email I get has 4 attachment files...
    noname1 1KB
    noname2 1KB
    noname3 1KB
    noname4 1KB
    although the files have been uploaded smoothly in the server and are 800 KB !!!

    Any suggestions what might be wrong ???
    Thanks
    Visit...
    http://kanenas.net
    News and Ideas about programming

  3. #3
    Join Date
    Nov 2003
    Posts
    6

    The same happens to me!

    Hi,

    When ao try to get the images that are in a informix table (binary field) to a file. The result file only have 1 KB.
    Did you find a way to workarround? thanks in Advance.
    Antonio.

  4. #4
    Join Date
    Aug 2006
    Location
    Athens - Greece
    Posts
    22
    My problem was the conversion BinaryToString of the files so...
    How many KB's or MB's are your files ???
    If they are MB's try this...
    Code:
    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
    And in a few seconds you are done !
    ;-)
    Visit...
    http://kanenas.net
    News and Ideas about programming

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •