ASP发送邮件的CLASS
类别: ASP教程 
一. 程序思路
所有的程序，主要实现两个功能，一、发送邮件；二、上传附件。使用无组件上传程序来上传附件到服务器，在发送完后，将删除服务器上的邮件。实现这两个功能，需要一个数据库来存放邮件内容及附件信息（文件名）。邮件的发送有两种情况：一是，无附件的邮件；二是，有附件的邮件。
１.发送无附件的邮件。用户根据实际情况来填写收信人、发信人、抄送、密送、SMTP服务器地址、邮件主题、邮件内容等信息，这些信息中，收信人、发信人、邮件主题、邮件内容是必须填写的，否则将收不到邮件。如果ＳＭＴＰ服务器支持ＳＭＴＰ验证，那么你就把你在该邮局的用户名和密码填上。如，你填的发信人地址是xxxx@163.com，因为１６３的ＳＭＴＰ服务，支持ＳＭＴＰ验证，所以你就要需要你在１６３的用户名xxxx，密码****，这样才能顺利发送邮件；如，你发信人地址是xxxx@hotmail.com，因为hotmail是不需要ＳＭＴＰ验证的，所以你不用填写用户名和密码。只要记住一点，你的发信的ＳＭＴＰ服务器支持ＳＭＴＰ验证的话，你就要填写相应的用户名和密码。你在填写完表单后，点“发送”按钮就直接发送邮件了。这个过程是在mail.asp和inc_clsEmail.asp完成的。
２.发送带附件的邮件。这个过程，主要分三步，一、填写表单信息（同上），不过在点“发送”按钮前，需要转到第二步，发送附件。二、此步聚主要是上传附件到服务器。需要服务器支持FSO、Dictionary、Stream等组件。在进入上传附件界面前，先在数据库中创建一条记录，把刚成填的表单信息存在表里，然后选择本地需要本地的rar或zip文件，选好后点“上传”按钮就行了，传完后程序将更新数据库中存入附件文件名和字段的内容并自动跳转到发信页面，发信页面从数据库中读取邮件信息并显示出来，此时点“发送”，就将发送附件了。本过程主要由 mail.asp、inc_clsEmail.asp、inc_clsUpload.asp、Upload.asp和Uploadok.asp来完成。
在这个发信程序中用到的文件清单:
attachment.mdb \'邮件信息临时存放库
install.asp \'在数据库中创建邮件信息临时表
Mail.asp \'发送邮件
Upload.asp \'文件上传
Uploadok.asp \'文件上传成功
inc_clsEmail.asp \'邮件发送类
inc_clsUpload.asp \'无组件上传类
inc_set.asp \'一些表格颜色的设置
二.建立数据库
1.打开你的Access建立一个文件名为:attachment.mdb.添加以下字段:
(1). ID 类型为自动编号(存放邮件信息的ID编号)
(2). smtpcheck 类型为是／否字段(存放是否需要ＳＭＴＰ验证)
(3). from 类型为文本字段(存放发信人的Email地址)
(4). fromname 类型为文本字段(存放发信人的名字)
(5). to 类型为文本字段(存放收信人的Email地址)
(6). bcc 类型为文本字段(存放密送人的Email地址)
(7). cc 类型为文本字段(存放抄送人的Email地址)
(8). server 类型为文本字段(存放SMTP服务器地址)
(9). subject 类型为文本字段(存放邮件主题)
(10). body 类型为备注字段(存放邮件的内容)
(11). username 类型为文本字段(存放邮箱登录用户名)
(12). password 类型为文本字段(存放邮箱登录的密码)
(13). filenames 类型为文本字段(存放附件的文件名)
注意：可以把字段设置为允许为空。
当然你可以自己添加你认为需要的字段，如果你把字段名或表名换成其它名称，则对程序也要作出相应的更改，不然会出错。如果你不想手工建表及添加字段，那你可以在浏览器中运行Install.asp文件，它可以自动建表，你就可以偷懒了:)
2. 在开始编写之前你可以罗列一下要用到的SQL语句.
\'搜索出数据库中ID号为1的邮件信息
SQL = "SELECT * FROM attachment ORDER BY WHERE id=1"
\'这个语句是添加新的临时邮件信息时用到的.
SQL="INSERT INTO attachment(smtpcheck,from,fromname,to,bcc,cc,server,subject,body,username,
password,filenames) VALUES(true,\'cjj8110@hotmail.com\',cjj\',\'cjj8110@hotmail.com\',\'\',\'\',\'\',\'测试\',\'测试邮件件发送程序\',\'cjj8110\',\'********\',\'1,zip,1.rar\')"
\'删除表中全部数据。
SQL = "DELETE FROM attachment"
\'删除表中指定ＩＤ的记录
SQL = "DELETE FROM attachment WHERE id =" & id
\'更新表中，指定ＩＤ的filenames字段的内容
SQL = "UPDATE attachemnt SET filenames=\'" & filenames & "\' WHERE ID=" & id
三.编写代码
Install.asp：考虑到手工建表有点麻烦，所以写了这个文件。文件主要用到CREATE TABLE和DROP TABLE语句，不过由于数据库的原因，有些数据库有可能不支持此语句。本文以Access为例，因为ACCESS支持这两条语句，如果还是新手还看不懂那也没关系，以为有机会再研究好了:)。由于不清楚数据库定义了那些关键字，所以在创建表和字段时，都用[]把表名和字段名括起来，即使表名或字段名和数据库的关键字冲突，也不会引起程序出错。不过运行本程序前，必须先在Access中创建一个数据库名称为attachment.mdb，可以不为其创建表，用此程序来创建。
install.asp的源码：
<%
\'此文件在执行后最好删除，因为如果不注意再次执行的话，将会使数据库的所有数据丢失，切记！
Dim SYS_strTableName,SYS_strSQL,SYS_objRS
\'需要创建的表的名字
SYS_strTableName = "attachment"
Set objConn = Server.CreateObject("ADODB.Connection")
\'OLEDB方式打开数据库的Connection对象连接字符串
strcon="provider=microsoft.jet.oledb.4.0;data source=" & Server.mappath("attachment.mdb")
objConn.open strcon\'和数据库已经建立连接可对其操作了.
\'DROP TABLE是一条从数据库中删除表的SQL语句。有些数据库有可能不支持。
SYS_strSQL = "DROP TABLE [" & SYS_strTableName & "]"
\'删除表时，如果有错误出现则跳转执行下语句
\'因为如果DROP TABLE一个数据库中并不存在的表时，就会导致程序出错，
\'所以加了这个语句On Error Resume Next
On Error Resume Next
objConn.Execute (SYS_strSQL)
\'因为On Error Resume Next比较耗资源，执行这条语句后，下面再出现错误将不会被跳转了也就是On Error Resume Next将不对此后的语句产生作用了，如果不加这句话，就对此后的都起屏蔽错误的作用。
On Error Goto 0
\'创建表格的主要是用CREATE TABLE语句
\'CREATE TABLE tablename (fieldname1 fieldytype1,fieldname2 fieldtype2......)
SYS_strSQL = "CREATE TABLE [" & SYS_strTableName & "] ("
\'此为创建自动编号类型的字段id
SYS_strSQL = SYS_strSQL & "[id] integer IDENTITY (1, 1) PRIMARY KEY NOT NULL ,"
\'创建文本类型的字段smtpcheck，字段类型为是/否类型。
SYS_strSQL = SYS_strSQL & "[smtpcheck] yesno,"
\'创建文本类型的字段homepage，并限定该字段的长度为50(char(50)实现该功能),允许为空(NULL)
SYS_strSQL = SYS_strSQL & "[from] char(50) NULL ,"
SYS_strSQL = SYS_strSQL & "[fromname] char(50) NULL,"
SYS_strSQL = SYS_strSQL & "[to] char(50) NULL ,"
SYS_strSQL = SYS_strSQL & "[bcc] char(50) NULL,"
SYS_strSQL = SYS_strSQL & "[cc] char(50) NULL ,"
SYS_strSQL = SYS_strSQL & "[server] char(50) NULL,"
SYS_strSQL = SYS_strSQL & "[subject] char(50) NULL ,"
SYS_strSQL = SYS_strSQL & "[body] memo,"
SYS_strSQL = SYS_strSQL & "[username] char(50) NULL,"
SYS_strSQL = SYS_strSQL & "[password] char(50) NULL ,"
SYS_strSQL = SYS_strSQL & "[filenames] char(50) NULL)"
Set SYS_objRS = objConn.Execute(SYS_strSQL)
\'显示创建成功信息。
Response.Write ("<br><font color=""#ff0000"">" & SYS_strTableName & "</font> 表创建成功！<br>")
%>
mail.asp的源码：
<!--#include file="inc_clsEmail.asp"-->
<%
Dim sAction,objMail,strID,strConn,strSQL,objConn,objRS
Dim sServer,bSMTPCheck,sSubject,sBody,sFrom,sFromName,sTo,sBCC,sCC,sSMTPCheck,sAddFile,sUsername,sPassword
sAction = Trim(Request.Form("action"))
If sAction = "发送" Then
Sub DelFiles(filename)
Dim objFSO
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.DeleteFile filename
If Err.Number <> 0 Then On Error Goto 0
End Sub
Dim MyMail,sReturn,aryTemp,i,sAttachmentPath
Dim sFileName,sFilePath,intID
intID = Trim(Session("Attachment_ID"))
If intID = "" THen
\'去除附件表中的相应附件记录
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")
strSQL = "DELETE FROM [attachment]"
Set objConn = CreateObject("Adodb.Connection")
On Error Resume Next
Set objRS = objConn.Execute(strSQL)
If err.Number <> 0 Then
On Error Goto 0
End If
Set objConn = Nothing
Session("Attachment_ID") = ""
Session.Abandon
sSubject = Trim(Request.Form("subject"))
sUsername = Trim(Request.Form("username"))
sPassword = TriM(Request.Form("password"))
sBody = Trim(Request.Form("body"))
sFrom = Trim(Request.Form("from"))
sFromName = Trim(Request.Form("fromname"))
sTo = Trim(Request.Form("to"))
sBCC = Trim(Request.Form("BCC"))
sCC = Trim(Request.Form("CC"))
\'创建邮件Class
Set MyMail = New SWEmail
\'自已设定邮件组件创建字符串
\'MyMail.SetObject("CDONTS.NewMail")
\'MyMail.SetObject("JMail.Message")
\'MyMail.SetObject("JMail.SmtpMail")
If sBCC <> "" Then MyMail.BCC(sBCC) \'密送
If sCC <> "" Then MyMail.CC(sCC) \'抄送
If sServer <> "" Then MyMail.Server(sServer)
\'发送的是纯文本邮件，默认为HTML邮件
MyMail.IsHTML(False)
\'组件测试
MyMail.Check sFrom,sFromName,sTo,sSubject,sBody
\'发送邮件
\'sReturn = MyMail.Send(sFrom,sFromname,sTo,sSubject,sBody)
\'释放class占用的资源
MyMail.Close
\'If sReutrn = True Then
\' Response.Write("<br>呵呵，邮件发送成功啦！<br>")
\'Else
\' Response.Write(sReturn)
\'End If
Response.End
Else
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")
strSQL = "SELECT * FROM [attachment] WHERE id=" & intID
Set objConn = CreateObject("Adodb.Connection")
objConn.Open strConn
Set objRS = objConn.Execute(strSQL)
sFrom = objRS("From")
sFromname = objRS("Fromname")
sSubject = objRS("subject")
sBody = objRS("body")
sTo = objRS("to")
sAddFile = objRS("filenames")
sBCC = objRS("bcc")
sCC = objRS("cc")
sServer = objRS("server")
sUsername = objRS("username")
sPassword = objRS("password")
bSMTPCheck = objRS("smtpcheck")
\'去除附件表中的相应附件记录
strSQL = "DELETE FROM [attachment] WHERE id=" & intID
On Error Resume Next
Set objRS = objConn.Execute(strSQL)
If err.Number <> 0 Then
On Error Goto 0
End If
Session("Attachment_ID") = ""
Session.Abandon
objConn.Close
Set objConn = Nothing
\'创建邮件Class
Set MyMail = New SWEmail
\'自已设定邮件组件创建字符串
\'MyMail.SetObject("CDONTS.NewMail")
\'MyMail.SetObject("JMail.Message")
\'MyMail.SetObject("JMail.SmtpMail")
If sBCC <> "" Then MyMail.BCC(sBCC) \'密送
If sCC <> "" Then MyMail.CC(sCC) \'抄送
MyMail.AddFile(Replace(sAddFile,",","$")) \'添加附件
If sServer <> "" Then MyMail.Server(sServer)
\'发送的是纯文本邮件，默认为HTML邮件
MyMail.IsHTML(False)
\'组件测试
MyMail.Check sFrom,sFromName,sTo,sSubject,sBody
\'发送邮件
\'sReturn = MyMail.Send(sFrom,sFromname,sTo,sSubject,sBody)
\'释放class占用的资源
MyMail.Close
\'If sReutrn = True Then
\' Response.Write("<br>呵呵，邮件发送成功啦！<br>")
\'Else
\' Response.Write(sReturn)
\'End If
\'删除服务器上的附件
sAttachmentPath = Server.Mappath("AttachmentFiles")
If Instr(sAddFile,",") <> 0 Then
aryTemp = Split(sAddFile,",")
For i = LBound(aryTemp) To UBound(aryTemp)
Call DelFiles(sAttachmentPath & "" & aryTemp(i))
Next
Else
If Trim(sAddFile) <> "" Then
Call DelFiles(sAttachmentPath & "" & sAddFile)
End If
End If
Response.End
End If
ElseIf sAction = "附件" Then
sServer = Trim(Request.Form("smtpserver"))
bSMTPCheck= Trim(Request.Form("smtpcheck"))
If (bSMTPCheck = "True") or (bSMTPCheck=True) Then
bSMTPCheck = True
Else
bSMTPCheck = False
End If
sSubject = Trim(Request.Form("subject"))
sUsername = Trim(Request.Form("username"))
sPassword = TriM(Request.Form("password"))
sBody = Trim(Request.Form("body"))
sFrom = Trim(Request.Form("from"))
sFromName = Trim(Request.Form("fromname"))
sTo = Trim(Request.Form("to"))
sBCC = Trim(Request.Form("BCC"))
sCC = Trim(Request.Form("CC"))
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")
Set objConn = CreateObject("Adodb.Connection")
objConn.Open strConn
Set objRS = CreateObject("Adodb.RecordSet")
If Session("Attachment_ID") <> "" Then
strSQL = "SELECT * FROM [attachment] WHERE id=" & Session("Attachment_ID")
objRS.Open strSQL,objConn,1,2
Else
strSQL = "SELECT * FROM [attachment]"
objRS.Open strSQL,objConn,1,2
objRS.Addnew
End If
objRS("SmtpCheck") = bSMTPCheck
objRS("username") = sUsername
objRS("password") = sPassword
objRS("Server") = sServer
objRS("Subject") = sSubject
objRS("body") = sBody
objRS("from") = sFrom
objRS("fromname") = sFromname
objRS("bcc") = sBCC
objRS("cc") = sCC
objRS("to") = sTo
objRS.Update
Session("Attachment_ID") = objRS("id")
objRS.Close
Set objRS = Nothing
objConn.Close
Set objConn = Nothing
Response.Redirect "upload.asp"
Else
strID = Trim(Session("Attachment_ID"))
If strID <> "" Then
\' strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")
strConn = "Driver={Microsoft Access Driver (*.mdb)};DBQ=" & Server.Mappath("attachment.mdb")
strSQL = "SELECT * FROM [attachment] WHERE id=" & strID
Set objConn = Server.CreateObject("Adodb.Connection")
objConn.Open strConn
On Error Resume Next
Set objRS = objConn.Execute(strSQL)
If err.Number <> 0 Then
On Error Goto 0
Response.Write("找不到相应的附件，程序将终止运行！")
Response.End
Else
sServer = objRS("server")
bSMTPCheck = objRS("SMTPCheck")
sSubject = objRS("Subject")
sBody = objRS("body")
sFrom = objRS("from")
sFromname = objRS("fromname")
sTo = objRS("to")
sBCC = objRS("bcc")
sCC = objRS("cc")
sUsername = objRS("username")
sPassword = objRS("password")
sAddFile = objRS("filenames")
End If
objConn.Close
Set objConn = Nothing
End If
%>
<html>
<head>
<title>发送</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<script>
function scheck() {
if (form1.smtpcheck.checked)
form1.smtpcheck.value=true
else
form1.smtpcheck.value=false;
}
</script>
</head>
<body bgcolor="#FFFFFF" text="#000000">
<form name="form1" method="post" action="mail.asp">
<p>邮件服务器
<input type="text" name="smtpserver" value="<%=sServer%>">
</p>
<p>组件
<input type="text" name="mailobject">
</p>
<p>ＳＭＴＰ验证：
<%If bSMTPCheck Then%>
<input type="checkbox" name="smtpcheck" value="true" onclick="scheck();" checked>
<%Else%>
<input type="checkbox" name="smtpcheck" value="false" onclick="scheck();">
<%End If%>
</p>
<p>用户名：
<input type="text" name="username" value="<%=sUsername%>">
</p>
<p>密 码：
<input type="text" name="password" value="<%=sPassword%>">
</p>
<p>收信人地址
<input type="text" name="to" value="<%=sTo%>">
</p>
<p>发信人地址
<input type="text" name="from" value="<%=sFrom%>">
</p>
<p>发信人姓名
<input type="text" name="fromname" value="<%=sFromName%>">
</p>
<p>抄 送
<input type="text" name="cc" value="<%=sCC%>">
</p>
<p>密 送
<input type="text" name="bcc" value="<%=sBCC%>">
</p>
<p>主 题
<input type="text" name="subject" value="<%=sSubject%>">
</p>
<p>附 件：
<input type="text" name="addfile" value="<%=sAddFile%>">
</p>
<p>内 容
<textarea name="body" rows="20" cols="100"><%=sBody%>
</textarea>
</p>
<p>
<input type="submit" name="action" value="发送">
<input type="submit" name="action" value="附件">
</p>
</form>
</body>
</html>
<%End If%>
inc_clsEmail.asp文件，主要实现了邮件发送的全过程。此类有如下几种方法：a)check,主要是检测服务器支持哪些发信组件，并且发送一封邮件，看看能否成功发送；b)mailerr,主要是返回发送邮件过程中的错误信息；c)server,设置ＳＭＴＰ服务器的地址；d) send,发送邮件；e)BCC,密送邮件；f)CC,抄送邮件;g)addfile,添加附件，可添加多个附件；h)close,释放数据。
inc_clsEmail.asp的代码：
<%Option Explicit
\'#########声明变量########
\'以下定义邮件组件类型常量
Private Const SWEmail_JMail43 = 0
Private Const SWEmail_JMail = 1
Private Const SWEmail_ASPEMail = 2
Private Const SWEmail_ASPMail = 3
Private Const SWEmail_EasyWebmail = 4
Private Const SWEmail_CMailServer = 5
Private Const SWEmail_CDO = 6
\'本类支持的组件数,由于数组的下标是从0开始的，所以实际是支持7个组件
Private Const SWEmail_intMailobjects = 6
\'邮件组件数组
ReDim SWEmail_aryMailObject(SWEmail_intMailobjects,2)
\'JMail 4.3
SWEmail_aryMailObject(0,0) = "JMail.Message" \'创建组件的字符串，此字符串固定
SWEmail_aryMailObject(0,1) = SWEmail_JMail43 \'组件的类型，自定义
\'JMail 早期版本
SWEmail_aryMailObject(1,0) = "JMail.SmtpMail"
SWEmail_aryMailObject(1,1) = SWEmail_JMail
\'ASP EMail
SWEmail_aryMailObject(2,0) = "Persits.MailSender"
SWEmail_aryMailObject(2,1) = SWEmail_ASPEMail
\'ASP Mail
SWEmail_aryMailObject(3,0) = "smtpsvg.mailer"
SWEmail_aryMailObject(3,1) = SWEmail_ASPMail
\'Easy Web Mail
SWEmail_aryMailObject(4,0) = "easymail.MailSEnd"
SWEmail_aryMailObject(4,1) = SWEmail_EasyWebmail
\'CMail Server
SWEmail_aryMailObject(5,0) = "CMailCOM.SMTP.1"
SWEmail_aryMailObject(5,1) = SWEmail_CMailServer
\'微软自带的组件
SWEmail_aryMailObject(6,0) = "CDONTS.NewMail"
SWEmail_aryMailObject(6,1) = SWEmail_CDO
\'记录邮件组件创建字符串
Private SWEmail_strMailObject
\'邮件组件的类型
Private SWEmail_intMailType
\'邮件组件的名称（描述）
Private strMailName
\'邮件附件信息
Private SWEmail_strFiles
Private SWEmail_strFrom \'发件人Email地址
Private SWEmail_strFromName \'发件人姓名
Private SWEmail_strTo \'收件人Email地址
Private SWEmail_strSubject \'邮件主题
Private SWEmail_strBody \'邮件内容
Private SWEmail_strBCC \'密送人Email地址
Private SWEmail_strCC \'抄送人Email地址
Private SWEmail_strSMTPServer \'邮件服务器地址
Private SWEmail_intSpeed \'邮件等级
Private SWEmail_blnIsHTML \'是否HTML邮件，True为HTML邮件，FASLE为纯文本邮件
Private SWEmail_strUserName \'身份验证时输入的用户名
Private SWEmail_strPassword \'身份验证时输入的密码
Private SWEmail_strAttachmentPath \'附件路径
Private SWEmail_strError \'错误信息
\'#########声明结束########
\'#########数据初始化########
\'默认为普通
SWEmail_intSpeed = 1
\'默认为HTML邮件
SWEmail_blnIsHTML = True
\'设置默认发件服务器地址
\'SWEmail_strSMTPServr = "SMTP.163.com"
\'设置默认组件字符串
\'SWEmail_strMailObject = "JMail.Message"
\'设置附件文件的路径
SWEmail_strAttachmentPath = Server.Mappath("attachmentfiles")
\'#########初始化结束########
Class SWEmail
\'检测服务支持的邮件组件
Sub Check(sFrom,sFromName,sTo,sSubject,sBody)
Dim i,objTest,sReturn
Response.Write("<table border=""0"" cellspacing=""1"" cellpadding=""0"" bgcolor=""#000000"" align=""center"" width=""85%"">" & vbcrlf)
Response.Write(" <tr align=""center"" height=""30"" bgcolor=""#FFFFFF"">" & vbcrlf)
Response.Write(" <td width=""33%"">Name</td>" & vbcrlf & " <td>Enable</td>" & vbcrlf & " <td>IsSent</td>" & vbcrlf)
Response.Write(" </tr>" & vbcrlf)
For i = 0 To SWEmail_intMailobjects
On Error Resume Next
Set objTest = CreateObject(CStr(SWEmail_aryMailObject(i,0)))
Response.Write(" <tr align=""center"" height=""25"" bgcolor=""#FFFFFF"">" & vbcrlf)
Response.Write(" <td>" & SWEmail_aryMailObject(i,0) & "</td>" & vbcrlf)
If err.Number <> 0 Then \'查看错误原因
On Error Goto 0
Response.Write( " <td>No</td>" & vbcrlf)
Response.Write( " <td>No</td>" & vbcrlf)
Else
SWEmail_strMailObject = SWEmail_aryMailObject(i,0)
SWEmail_intMailType = SWEmail_aryMailObject(i,1)
Response.Write( " <td>Yes</td>" & vbcrlf)
sReturn = Send(sFrom,sFromName,sTo,sSubject,sBody)
If (sReturn = True) Then
Response.Write(" <td>Success</td>" & vbcrlf)
Else
If sReturn = False Then
Response.Write(" <td>Failed</td>" & vbcrlf)
Else
Response.Write(" <td>" & sReturn & "</td>" & vbcrlf)
End If
End If
End If
Response.Write(" </tr>" & vbcrlf)
Next
Response.Write("</table>" & vbcrlf)
End Sub
\'自动检测服务器支持的组件并设置，如果成功返回True，否则返回False
Function AutoSet()
Dim i,objTest
\'没检测到发送邮件的组件
AutoSet = False
SWEmail_strMailObject = ""
SWEmail_intMailType = ""
For i = 0 To SWEmail_intMailobjects
On Error Resume Next
Set objTest = CreateObject(SWEmail_aryMailObject(i,0))
If err.Number = 0 Then
\'只要检测到就退出，不继续检测！
AutoSet = True
SWEmail_strMailObject = SWEmail_aryMailObject(i,0)
SWEmail_intMailType = SWEmail_aryMailObject(i,1)
Exit Function
End If
Next
Set objTest = Nothing
End Function
Function MailErr()
MailErr = SWEmail_strError
End Function
\'邮件等级设置
Sub Speed(str)
\'0:最慢,1:默认,2,最快
If Trim(str) = "" Then
str = 1
Else
str = CInt(str)
End If
Select Case SWEmail_intMailType
Case SWEmail_JMail43
If str = 0 Then
SWEmail_intSpeed = 5
ElseIf str = 1 Then
SWEmail_intSpeed = 3
ElseIf str = 2 Then
SWEmail_intSpeed = 1
Else
SWEmail_intSpeed = 3
End If
Case SWEmail_JMail
If str = 0 Then
SWEmail_intSpeed = 5
ElseIf str = 1 Then
SWEmail_intSpeed = 3
ElseIf str = 2 Then
SWEmail_intSpeed = 1
Else
SWEmail_intSpeed = 3
End If
Case SWEmail_CDO
SWEmail_intSpeed = str
End Select
End Sub
\'是否发送HTML邮件
Sub IsHTML(bln)
SWEmail_blnIsHTML = bln
End Sub
\'SMTP服务器地址
Sub Server(str)
SWEmail_strSMTPServer = str
End Sub
\'发信
Function Send(from,fromname,go,subject,body)
Dim sReturn
\'发信人的Email地址
SWEmail_strFrom = from
\'发信人的名字
SWEmail_strFromName = fromname
\'收信人Email地址
SWEmail_strTo = go
\'邮件主题
SWEmail_strSubject = subject
\'邮件内容
SWEmail_strBody = body
sReturn = Execute()
If sReturn = True Then
Send = True
Else
Send = sReturn
End If
End Function
\'密送
Sub BCC(str)
SWEmail_strBCC = str
End Sub
\'抄送
Sub CC(str)
SWEmail_strCC = str
End Sub
\'添加附件
Sub AddFile(str)
SWEmail_strFiles = str
End Sub
\'SMTP验证,只有JMail组件可用
Sub SMTPCheck(username,password)
SWEmail_strUsername = username
SWEmail_strPassword = password
End Sub
\'设置邮件组件对象
Sub SetObject(str)
Dim i
For i = 0 To SWEmail_intMailObjects
If SWEmail_aryMailObject(i,0) = str Then
SWEmail_strMailObject = str
SWEmail_intMailType = SWEmail_aryMailObject(i,1)
Exit For
End If
Next
End Sub
\'发送邮件主体
Function Execute()
Dim i,sFilePath,strFileName,strTemp,aryTemp,intUpLimit
Dim objMail
If Trim(SWEmail_strMailObject) = "" Then
Execute = "It can\'t create a null string object."
Exit Function
End If
\'On Error Resume Next
Set objMail = CreateObject(SWEmail_strMailObject)
If Err.Number <> 0 Then
Execute = "Can\'t create object <font color=""#ff0000"">" & SWEmail_strMailObject & "</font>."
Exit Function
End If
Select Case SWEmail_intMailType
Case SWEmail_JMail43 \'Jmail4.3 发信主体
\'屏蔽例外错误
objMail.Silent = True
\'启用邮件日志
\'objMail.logging = True
objMail.Charset = "GB2312"
objMail.AddRecipient SWEmail_strTo
objMail.AddRecipientBCC SWEmail_strBCC
objMail.AddRecipientCC SWEmail_strCC
objMail.From = SWEmail_strFrom
objMail.MailServerUserName = SWEmail_strUserName
objMail.MailServerPassword = SWEmail_strPassword
objMail.Subject = SWEmail_strSubject
If SWEmail_blnIsHTML = True Then
objMail.ContentType = "text/html"
objMail.HtmlBody = SWEmail_strBody
Else
objMail.Body = SWEmail_strBody
End If
objMail.Priority = SWEmail_intSpeed
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & strFileName)
End If
Next
Else
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & SWEmail_strFiles)
End If
End If
objMail.Send(SWEmail_strSMTPServer)
objMail.Close()
Case SWEmail_JMail
\'Jmail早期版本发信主体
objMail.Silent = True
objMail.logging = True
objMail.Charset = "GB2312"
objMail.ContentType = "text/html"
objMail.ServerAddress = SWEmail_strSMTPServer
objMail.AddRecipient SWEmail_strTo
objMail.AddRecipientBCC SWEmail_strBCC
objMail.AddRecipientCC SWEmail_strCC
objMail.SenderName = SWEmail_strFromName
objMail.Sender = SWEmail_strFrom
objMail.Priority = SWEmail_intSpeed
objMail.Subject = SWEmail_strSubject
objMail.Body = SWEmail_strBody
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & strFileName)
End If
Next
Else
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & SWEmail_strFiles)
End If
End If
objMail.Execute()
objMail.Close
Case SWEmail_ASPEMail
\'ASPMail组件
If Trim(SWEmail_strServer) <> "" Then objMail.Host = SWEmail_strServer
If Trim(SWEmail_strBCC) <> "" Then objMail.AddBcc SWEmail_strBCC
If Trim(SWEmail_strUsername) <>"" Then objMail.Username = SWEmail_strUsername
If Trim(SWEmail_strPassword) <>"" Then objMail.Password = SWEmail_strPassword
objMail.Subject = SWEmail_strSubject
objMail.From = SWEmail_strFrom
objMail.Body = SWEmail_strBody
objMail.AddAddress SWEmail_strTo
objMail.IsHTML = SWEmail_blnIsHTML
objMail.CharSet = "gb2312"
objMail.Priority = SWEmain_intSpeed
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & strFileName)
End If
Next
Else
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & SWEmail_strFiles)
End If
End If
Case SWEmail_ASPMail
objMail.CusTomCharSet = "gb2312"
objMail.FromAddress = FromMail
objMail.FromName = FromName
objMail.AddRecipient ToMail, ToMail
If ToMailbcc <> "" Then objMail.AddBCC ToMailbcc, ToMailbcc
objMail.Subject = MailSubject
If MailFormat = "html" Then
objMail.ContentType = "text/html"
objMail.BodyText = MailBody
Else
objMail.BodyText = MailBody
End If
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
objMail.ClearAttachments
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & strFileName)
End If
Next
Else
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & SWEmail_strFiles)
End If
End If
objMail.Priority = SWEmail_intSpeed
objMail.RemoteHost = SWEmail_strServer
objMail.Timeout = 9999
objMail.SendMail
SWEmail_strError = objMail.Response
Case SWEmail_EasyWebmail
objMail.CreateNew SWEmail_strFrom, "temp"
objMail.MailName = SWEmail_strFromName
objMail.EM_To = SWEmail_strTo
If Trim(SWEmail_strBCC) <> "" Then objMail.EM_BCC SWEmail_strBCC
objMail.EM_Subject = SWEmail_strSubject
If SWEmail_IsHTML = true Then
objMail.EM_HTML_Text = SWEmail_strBody
objMail.useRichEditer = true
Else
objMail.EM_Text = SWEmail_strBody
End If
objMail.EM_Priority = SWEmail_intSpeed
\'If TimeMail Then objMail.EM_TimerSEnd = webmailtime
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AddFromAttFileString = SWEmail_strAttachmentPath & "" & strFileName
End If
Next
Else
objMail.AddAttFileString = SWEmail_strAttachmentPath & "" & SWEmail_strFiles
End If
End If
If objMail.Send() = FALSE Then
SWEmail_strError= "有错误发生"
End If
Case SWEmail_CMailServer
objMail.CreateUserPath("ASPMail")
objMail.Subject = SWEmail_strSubject
objMail.Body = SWEmail_strBody
objMail.To = SWEmail_strTo
objMail.From = SWEmail_strFrom
objMail.SendMail
If Left(objMail.LastResponse, 3) <> "+OK" Then
SWEmail_strError = "错误原因：" & objMail.LastResponse
End If
Case SWEmail_CDO
\'微软自带发信主体
objMail.Subject = SWEmail_strSubject
objMail.From = SWEmail_strFrom
objMail.To = SWEmail_strTo
If SWEmail_blnIsHTML Then
objMail.BodyFormat = 0 \'支持HTML
Else
objMail.BodyFormat = 1 \'支持纯文本
End If
\'0 表示将采用 MIME 格式
\'1 表示将采用连续的纯文本（默认值）
\'objMail.MailFormat = 0
objMail.Body = SWEmail_strBody
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AttachFile (SWEmail_strAttachmentPath & "" & strFileName)
End If
Next
Else
objMail.AttachFile (SWEmail_strAttachmentPath & "" & SWEmail_strFiles)
End If
End If
objMail.Send
End Select
If Err.Number <> 0 Then
If Trim(err.Description) <> "" Then Execute = Err.Description & "<br>"
Else
Execute = True
End If
Set objMail = Nothing
End Function
\'清空内容
Sub Close()
SWEmail_strMailObject = ""
SWEmail_intMailType = ""
strMailName = ""
SWEmail_strFiles = ""
SWEmail_intSpeed = ""
\'释放数组
Erase SWEmail_aryMailObject
End Sub
End Class
%>
upload.asp的源码：
<%
If Trim(Request.ServerVariables("HTTP_REFERER"))="" Then
\'Response.Write(Request.ServerVariables("HTTP_REFERER"))
\'Response.End
Response.Redirect "mail.asp"
Response.End
End If
%>
<!--#include file="inc_set.asp"-->
<html>
<head>
<title>文件上传</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<style type="text/css">
<!--
.tx { height: 16px; width: 30px; border-color: black black #000000; border-top-width: 0px; border-right-width: 0px; border-bottom-width: 1px; border-left-width: 0px; font-size: 9pt; background-color: <%=clrGeneralTR%>; color: #0000FF}
.tx1 { height: 20px; width: 30px; font-size: 9pt; border: 1px solid; border-color: black black #000000; color: #0000FF}
-->
</style>
</head>
<body topmargin="0">
<table border="1">
<tr>
<td>
<br><form name="form1" method="post" action="uploadok.asp" enctype="multipart/form-data">
<table width="88%" border="0" cellspacing="1" cellpadding="0" align="center">
<tr bgcolor="<%=clrTitleTR%>">
<td height="28" align="center" valign="middle" bgcolor="<%=clrTitleTR%>"><b>文件上传</b></td>
</tr>
<tr align="left" valign="middle" bgcolor="<%=clrGeneralTR%>">
<td height="92">
<script language="javascript">
<!--
function setid()
{
str=\'<br>\';
if(!window.form1.upcount.value)
window.form1.upcount.value=1;
for(i=1;i<=window.form1.upcount.value;i++)
str+=\'文件\'+i+\':<input type="file" name="file\'+i+\'" style="width:350" class="tx1"> 文件重命名：<input type="text" name="filename\'+i+\'" style="width:100" class="tx"><br><br>\';
window.upid.innerHTML=str+\'<br>\';
}
file://-->
</script>
<li> 需要上传的个数
<input type="text" name="upcount" class="tx" value="2">
<input type="button" name="Button" class="button" onclick="setid();" value="设置">
</li>
</td>
</tr>
<tr align="center" valign="middle" bgcolor="<%=clrGeneralTR%>">
<td align="left" id="upid" height="122"> 文件1:
<input type="file" name="file1" style="width:200" class="tx1" value="">
<input type="text" name="filename1" style="width:30" class="tx">
</td>
</tr>
<tr align="center" valign="middle" bgcolor="<%=clrTitleTR%>">
<td height="28" bgcolor="<%=clrTitleTR%>"></td>
</tr>
<tr>
<td>
<input type="submit" name="action" value="上传" class="button">
</td>
</tr>
</table>
</form>
</td>
</tr>
</table>
</body>
</html>
<script language="javascript">
<!--
setid();
file://-->
</script>
uploadok.asp的源码：
<%Option Explicit
Response.Expires = 0
%>
<!--#include file="inc_clsUpload.asp"-->
<%
Private Function FormatStr(str)
str = Trim(BinToStr(str))
str = Replace(str,"\'","\'\'")
str = Replace(str,vbcrlf,"")
FormatStr = str
End Function
\'设置文件上传路径，此目录必须存在，否则会出错
Private Const svrUploadFilePath = "attachmentfiles"
Dim strNewName,sNewname,strSQL,strNoPic,strInfo,strFileName,strFilePath
Dim intFormSize,intFileCount,I
Dim binFormData,binTextData,binFileData
Dim aryFileName
Dim objUpload
\'获取表单数据的大小
intFormSize = Request.TotalBytes
\'获取所有的表单数据
binFormData = Request.BinaryRead(intFormSize)
\'创建上传类
Set objUpload = New Upload
\'初始化表单提交的数据中
objUpload.Init(binFormData)
\'清空数据
binFormData = ""
strInfo = ""
intFileCount = objUpload.FileCount
\'设置上传文件存放的路径
objUpload.SetPath(svrUploadFilePath)
\'获取上传文件的存放路径
\'strFilePath = objUpload.GetPath
\'设置允许上传的文件格式,多种格式以|分隔
objUpload.AllowFiles ("zip|rar|jpg|png|bmp|txt|htm|html")
\'获取默认文件名列表
strFileName = objUpload.FileName
aryFileName = Split(strFileName,",")
If intFileCount > 1 Then
For i = 1 To intFileCount
sNewname = objUpload.FormName("filename" & i)
If sNewname = "" Then sNewname = aryFileName(i-1)
If strNewname = "" Then
strNewname = strNewname & sNewname
Else
strNewname = strNewname & "," & sNewname
End If
Next
Else
strNewname = objUpload.FormName("filename1")
End If
\'清空文本内容
binTextData = ""
Dim strAttachmentFiles
If strInfo = "" Then
If strNewName = "" Then strNewName = strFileName
If objUpload.FileExist(strNewName) Then\'如果文件不存在，则保存文件
If objUpload.SaveFile(strNewName) Then
strAttachmentFiles = strAttachmentFiles & strNewName & ","
\' strInfo = strInfo & objUpload.ErrorInfo
\' Else
\' strInfo = strInfo & objUpload.ErrorInfo
End If
\' Else
\' strInfo = strInfo & objUpload.ErrorInfo
End If
End If
Dim oConn,oRS,sConn
strSQL = "UPDATE [attachment] SET filenames=\'" & Left(strAttachmentFiles,Len(strAttachmentFiles)-1) & "\' WHERE id=" & Session("Attachment_ID")
sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")
\' sConn = "Driver={Microsoft Access Driver (*.mdb)};DBQ=" & Server.Mappath("attachment.mdb")
Set oConn = CreateObject("Adodb.Connection")
oConn.Open sConn
Set oRS = oConn.Execute(strSQL)
Set oConn = Nothing
Response.Redirect "mail.asp"
Response.End
%>
inc_clsUpload.asp的源码：
<%
\'*****************************************
\' 目的： 将Binary字符转成String。
\' 输入： str: 需要转换Binary。
\' 返回： 转换后的String,并把string中的\'替换成\'\',换行符去掉。
\'*****************************************
Private Function BinToStr(str)
Dim i,strTemp
strTemp = ""
For i=1 To LenB(str)
If AscB(MidB(str, i, 1)) > 127 Then
strTemp = strTemp & Chr(Ascb(MidB(str, i, 1))*256+Ascb(MidB(str, i+1, 1)))
i = i + 1
Else
strTemp = strTemp & Chr(AscB(MidB(str, i, 1)))
End If
Next
strTemp = Replace(Replace(Trim(strTemp),"\'","\'\'"),VBCRLF,"")
BinToStr=strTemp
End Function
\'*****************************************
\' 目的： 将String转成Binary。
\' 输入： str: 需要转换的String。
\' 返回： 转换后的二进制字符串。
\'*****************************************
Private Function StrToBin(str)
Dim i, binTemp
For i = 1 To Len(str)
binTemp = binTemp & ChrB(Asc(Mid(str,I,1)))
Next
StrToBin = binTemp
End Function
Class Upload
\'文件名、文件路径、错误信息、文件信息、允许上传的文件后缀名
Dim strFileName,strFilePath,strErrorInfo,strFileInfo,strAllowed
\'文件开始位置、文件大小、文件个数
Dim intFileStart,intFileSize,intFileCount
\'AdoStream对象objData和Dictionary对象objFiles
Dim objData,objFiles
\'二进制数据
Dim binTxtData
\'以上变量均为Class级变量，可在此Class的所有过程函数中使用
\'*****************************************
\' 目的： 将文件与文本数据分离,保存文件到Dictionary对象
\' 输入： formdata： 为表单提交的所有数据
\' 返回： 无
\'*****************************************
Sub Init(formdata)
Dim BnCrlf,binName,binFileName,binQuotation,binSpace,binFileContent
Dim sStart,sInfo,sFileName,sFormName,sFormValue
Dim iStart,iFormStart,iFormEnd,iInfoStart,iInfoEnd,iFindStart,iFindEnd,iValStart,iValEnd,iFileName
Set objFiles = Server.CreateObject("Scripting.Dictionary")
Set objData = Server.CreateObject("Adodb.Stream")
objData.Type = 1
objData.Mode = 3
objData.Open
objData.Write formdata
BnCrlf = ChrB(13) & ChrB(10)
binName = StrToBin("name=""")
binFileName = StrToBin("filename=""")
binQuotation = StrToBin("""")
binSpace = StrToBin(" ")
intFileCount = 0 \'文件个数清零
iFormEnd = LenB(formdata)
iFormStart = 1
\'-----------------------------7d320717017a
sStart = MidB(formdata,1,InStrB(1,formdata,bnCrlf)-1)
iStart = LenB(sStart)
iFormStart = iFormStart+iStart+1
While iFormStart + 10 < iFormEnd
iInfoEnd = InStrB(iFormStart,formdata,BnCrlf&BnCrlf)+1
sInfo = MidB(formdata,iFormStart,iInfoEnd-iFormStart)
\'Find form name
iFormStart = InStrB(iInfoEnd,formdata,sStart)
iFindStart = InStrB(11,sInfo,binName,1)
iFindEnd = InStrB(iFindStart+6,sInfo,binQuotation,1)
sFormName = MidB(sInfo,iFindStart,iFindEnd-iFindStart)
\'取得表单值起始位置
iValStart = iInfoEnd + 1
\'如果是文件
If InStrB (22,sInfo,binFileName,0) > 0 Then
\'取得文件名
iFindStart = InStrB(iFindEnd,sInfo,binFileName,0) + 10
iFindEnd = InStrB(iFindStart,sInfo,binQuotation,1)
sFileName = MidB(sInfo,iFindStart,iFindEnd-iFindStart)
sFileName = BinToStr(sFileName)
iFileName = InstrRev(sFileName,"",-1) + 1
sFileName = Mid(sFileName,iFileName,Len(sFileName)-iFileName + 1)
If Trim(strFileName) <> "" Then
strFileName = strFileName & "," & sFileName
Else
strFileName = sFileName
End If
\'文件开始位置
intFileStart = iInfoEnd
\'文件大小
intFileSize = iFormStart -iInfoEnd
\'文件内容
\'binFileContent = MidB(formdata,intFileStart,intFileSize)
\'添加文件,以文件名为关键字
If Not objFiles.Exists(sFileName) Then
objFiles.Add sFileName,intFileStart & "," & intFileSize
Else
strErrorInfo = strErrorInfo & "<br>文件 <b>" & sFileName & "</b> 已经存在！"
Exit Sub
End If
\'统计文件个数
intFileCount = intFileCount + 1
Else \'如果是表单项目
iValEnd = iFormStart-iInfoEnd-3
If iValEnd> 0 Then
sFormValue = MidB(formdata,iValStart,iValEnd)
Else
sFormValue = ""
End If
binTxtData = binTxtData & sFormname & StrToBin(":") & sFormValue & StrToBin("""")
End If
iFormStart=iFormStart + iStart + 1
Wend
formdata=""
End Sub
\'*****************************************
\' 目的： 限制文件上传的类型,只能许sAllow格式的文件
\' 输入： strLimit，允许上传的文件格式，多种格式用|分开
\'
\' 返回： 允许上传的文件格式（多种格式用|分开）
\'*****************************************
Sub AllowFiles(sAllow)
strAllowed = sAllow
End Sub
\'*****************************************
\' 目的： 检查文件后缀是否为被允许的文件格式
\' 输入： filename
\'
\' 返回： 如果是允许的文件格式返回True,否则返回False
\'*****************************************
Function IsAllowed(filename)
Dim intStart
IsAllowed = False
If strAllowed = "" Then
IsAllowed = True
Else
filename=Trim(filename)
If Trim(filename) <> "" Then
intStart = InstrRev(filename,".")
If intStart > 0 Then
If Instr(strAllowed,Mid(filename,intStart+1,Len(filename)-intStart))>0 Then
IsAllowed = True
End If
End IF
End If
End If
End Function
\'*****************************************
\' 目的： 统计文件个数
\' 输入： 无
\' 返回： 返回上传的文件个数
\' 说明： intFileCount是一个Class级变量，在本Class内有效
\' 在函数PickData过程中，统计文件个数
\'*****************************************
Function FileCount()
FileCount = intFileCount
End Function
\'*****************************************
\' 目的： 将二进制数据写入文件
\' 输入： FileName： 文件名
\' 返回： 保存成功返回TRUE，失败则返回错误信息
\'*****************************************
Function SaveFile(filename)
Dim i,iFileCount
Dim objSaveFile
Dim sFileName,sNewpath,binFileCount
Dim aryFileName,aryNewName,aryFileInfo
SaveFile = True
Set objSaveFile = Server.CreateObject("Adodb.Stream")
objSaveFile.Mode=3 \'3表示adModeReadWrite
objSaveFile.Type=1 \'1表示adTypeBinary
objSaveFile.Open()
\'On Error Resume Next
If Trim(filename) = "" Then filename = strFileName
If Instr(filename,",")>0 Then
\'多文件
aryFileName = Split(strFileName,",")
aryNewname = Split(filename,",")
For i =LBound(aryNewName) To UBound(aryNewName)
sFileName = aryFileName(i)
If IsAllowed(sFileName) Then \'是否为允许的文件格式
objSaveFile.Position = 0
aryFileInfo = Split(objFiles.Item(sFileName),",")
\'objSaveFile.Write objFiles.Item(sFileName)
objData.Position = aryFileInfo(0) + 2
objData.CopyTo objSaveFile,aryFileInfo(1)
sNewPath = Server.Mappath(strfilepath&sFileName)
\' strFileInfo = strFileInfo & FileName & "<Br>"
strErrorInfo = strErrorInfo & "<br>文件 <Font Color=""#FF0000"">" & sFileName & "</Font>上传成功"
\'存成文件，2表示adSaveCreateOverWrite
objSaveFile.SaveToFile sNewPath,2
Else
strErrorInfo = strErrorInfo & "<br>文件 <font color=""#ff00000"">" & sFileName & "</font> 为不被允许上传的文件，请检查文件后缀<br>"
SaveFile = False
\'Exit Function
End If
Next
Else
\'单文件
If IsAllowed(strFileName) Then \'是否为允许的文件格式
aryFileInfo = Split(objFiles.Item(strFileName),",")
objData.Position = aryFileInfo(0) + 2
objData.CopyTo objSaveFile,aryFileInfo(1)
sNewPath = Server.Mappath(strFilePath&FileName)
\' strFileInfo = strFileInfo & FileName & "<Br>"
strErrorInfo = strErrorInfo & "<br>文件 <Font Color=""#FF0000"">" & FileName & "</Font>"
objSaveFile.SaveToFile sNewPath,2
Else
strErrorInfo = strErrorInfo & "<br>文件 <Font Color=""#FF0000"">" & sFileName & "</font> 为不被允许上传的文件，请检查文件后缀！"
SaveFile = False
\'Exit Function
End If
End If
objSaveFile.Close
Set objSaveFile = Nothing
objData.Close
Set objData = Nothing
Set objFiles = Nothing
\'If err.Number <> 0 Then SaveFile = False
End Function
\'*****************************************
\' 目的： 获取表单项的值
\' 输入： name： 为要寻找的字段变量
\' txtdata： 为已从图象中分离出来的的所有文本
\' 返回： 表单项的值
\'*****************************************
Function FindInput(fName,txtdata)
Dim intStartPos,intEndPos,intNameLen,intValEnd,i,bReturn
所有的程序，主要实现两个功能，一、发送邮件；二、上传附件。使用无组件上传程序来上传附件到服务器，在发送完后，将删除服务器上的邮件。实现这两个功能，需要一个数据库来存放邮件内容及附件信息（文件名）。邮件的发送有两种情况：一是，无附件的邮件；二是，有附件的邮件。
１.发送无附件的邮件。用户根据实际情况来填写收信人、发信人、抄送、密送、SMTP服务器地址、邮件主题、邮件内容等信息，这些信息中，收信人、发信人、邮件主题、邮件内容是必须填写的，否则将收不到邮件。如果ＳＭＴＰ服务器支持ＳＭＴＰ验证，那么你就把你在该邮局的用户名和密码填上。如，你填的发信人地址是xxxx@163.com，因为１６３的ＳＭＴＰ服务，支持ＳＭＴＰ验证，所以你就要需要你在１６３的用户名xxxx，密码****，这样才能顺利发送邮件；如，你发信人地址是xxxx@hotmail.com，因为hotmail是不需要ＳＭＴＰ验证的，所以你不用填写用户名和密码。只要记住一点，你的发信的ＳＭＴＰ服务器支持ＳＭＴＰ验证的话，你就要填写相应的用户名和密码。你在填写完表单后，点“发送”按钮就直接发送邮件了。这个过程是在mail.asp和inc_clsEmail.asp完成的。
２.发送带附件的邮件。这个过程，主要分三步，一、填写表单信息（同上），不过在点“发送”按钮前，需要转到第二步，发送附件。二、此步聚主要是上传附件到服务器。需要服务器支持FSO、Dictionary、Stream等组件。在进入上传附件界面前，先在数据库中创建一条记录，把刚成填的表单信息存在表里，然后选择本地需要本地的rar或zip文件，选好后点“上传”按钮就行了，传完后程序将更新数据库中存入附件文件名和字段的内容并自动跳转到发信页面，发信页面从数据库中读取邮件信息并显示出来，此时点“发送”，就将发送附件了。本过程主要由 mail.asp、inc_clsEmail.asp、inc_clsUpload.asp、Upload.asp和Uploadok.asp来完成。
在这个发信程序中用到的文件清单:
attachment.mdb \'邮件信息临时存放库
install.asp \'在数据库中创建邮件信息临时表
Mail.asp \'发送邮件
Upload.asp \'文件上传
Uploadok.asp \'文件上传成功
inc_clsEmail.asp \'邮件发送类
inc_clsUpload.asp \'无组件上传类
inc_set.asp \'一些表格颜色的设置
二.建立数据库
1.打开你的Access建立一个文件名为:attachment.mdb.添加以下字段:
(1). ID 类型为自动编号(存放邮件信息的ID编号)
(2). smtpcheck 类型为是／否字段(存放是否需要ＳＭＴＰ验证)
(3). from 类型为文本字段(存放发信人的Email地址)
(4). fromname 类型为文本字段(存放发信人的名字)
(5). to 类型为文本字段(存放收信人的Email地址)
(6). bcc 类型为文本字段(存放密送人的Email地址)
(7). cc 类型为文本字段(存放抄送人的Email地址)
(8). server 类型为文本字段(存放SMTP服务器地址)
(9). subject 类型为文本字段(存放邮件主题)
(10). body 类型为备注字段(存放邮件的内容)
(11). username 类型为文本字段(存放邮箱登录用户名)
(12). password 类型为文本字段(存放邮箱登录的密码)
(13). filenames 类型为文本字段(存放附件的文件名)
注意：可以把字段设置为允许为空。
当然你可以自己添加你认为需要的字段，如果你把字段名或表名换成其它名称，则对程序也要作出相应的更改，不然会出错。如果你不想手工建表及添加字段，那你可以在浏览器中运行Install.asp文件，它可以自动建表，你就可以偷懒了:)
2. 在开始编写之前你可以罗列一下要用到的SQL语句.
\'搜索出数据库中ID号为1的邮件信息
SQL = "SELECT * FROM attachment ORDER BY WHERE id=1"
\'这个语句是添加新的临时邮件信息时用到的.
SQL="INSERT INTO attachment(smtpcheck,from,fromname,to,bcc,cc,server,subject,body,username,
password,filenames) VALUES(true,\'cjj8110@hotmail.com\',cjj\',\'cjj8110@hotmail.com\',\'\',\'\',\'\',\'测试\',\'测试邮件件发送程序\',\'cjj8110\',\'********\',\'1,zip,1.rar\')"
\'删除表中全部数据。
SQL = "DELETE FROM attachment"
\'删除表中指定ＩＤ的记录
SQL = "DELETE FROM attachment WHERE id =" & id
\'更新表中，指定ＩＤ的filenames字段的内容
SQL = "UPDATE attachemnt SET filenames=\'" & filenames & "\' WHERE ID=" & id
三.编写代码
Install.asp：考虑到手工建表有点麻烦，所以写了这个文件。文件主要用到CREATE TABLE和DROP TABLE语句，不过由于数据库的原因，有些数据库有可能不支持此语句。本文以Access为例，因为ACCESS支持这两条语句，如果还是新手还看不懂那也没关系，以为有机会再研究好了:)。由于不清楚数据库定义了那些关键字，所以在创建表和字段时，都用[]把表名和字段名括起来，即使表名或字段名和数据库的关键字冲突，也不会引起程序出错。不过运行本程序前，必须先在Access中创建一个数据库名称为attachment.mdb，可以不为其创建表，用此程序来创建。
install.asp的源码：
<%
\'此文件在执行后最好删除，因为如果不注意再次执行的话，将会使数据库的所有数据丢失，切记！
Dim SYS_strTableName,SYS_strSQL,SYS_objRS
\'需要创建的表的名字
SYS_strTableName = "attachment"
Set objConn = Server.CreateObject("ADODB.Connection")
\'OLEDB方式打开数据库的Connection对象连接字符串
strcon="provider=microsoft.jet.oledb.4.0;data source=" & Server.mappath("attachment.mdb")
objConn.open strcon\'和数据库已经建立连接可对其操作了.
\'DROP TABLE是一条从数据库中删除表的SQL语句。有些数据库有可能不支持。
SYS_strSQL = "DROP TABLE [" & SYS_strTableName & "]"
\'删除表时，如果有错误出现则跳转执行下语句
\'因为如果DROP TABLE一个数据库中并不存在的表时，就会导致程序出错，
\'所以加了这个语句On Error Resume Next
On Error Resume Next
objConn.Execute (SYS_strSQL)
\'因为On Error Resume Next比较耗资源，执行这条语句后，下面再出现错误将不会被跳转了也就是On Error Resume Next将不对此后的语句产生作用了，如果不加这句话，就对此后的都起屏蔽错误的作用。
On Error Goto 0
\'创建表格的主要是用CREATE TABLE语句
\'CREATE TABLE tablename (fieldname1 fieldytype1,fieldname2 fieldtype2......)
SYS_strSQL = "CREATE TABLE [" & SYS_strTableName & "] ("
\'此为创建自动编号类型的字段id
SYS_strSQL = SYS_strSQL & "[id] integer IDENTITY (1, 1) PRIMARY KEY NOT NULL ,"
\'创建文本类型的字段smtpcheck，字段类型为是/否类型。
SYS_strSQL = SYS_strSQL & "[smtpcheck] yesno,"
\'创建文本类型的字段homepage，并限定该字段的长度为50(char(50)实现该功能),允许为空(NULL)
SYS_strSQL = SYS_strSQL & "[from] char(50) NULL ,"
SYS_strSQL = SYS_strSQL & "[fromname] char(50) NULL,"
SYS_strSQL = SYS_strSQL & "[to] char(50) NULL ,"
SYS_strSQL = SYS_strSQL & "[bcc] char(50) NULL,"
SYS_strSQL = SYS_strSQL & "[cc] char(50) NULL ,"
SYS_strSQL = SYS_strSQL & "[server] char(50) NULL,"
SYS_strSQL = SYS_strSQL & "[subject] char(50) NULL ,"
SYS_strSQL = SYS_strSQL & "[body] memo,"
SYS_strSQL = SYS_strSQL & "[username] char(50) NULL,"
SYS_strSQL = SYS_strSQL & "[password] char(50) NULL ,"
SYS_strSQL = SYS_strSQL & "[filenames] char(50) NULL)"
Set SYS_objRS = objConn.Execute(SYS_strSQL)
\'显示创建成功信息。
Response.Write ("<br><font color=""#ff0000"">" & SYS_strTableName & "</font> 表创建成功！<br>")
%>
mail.asp的源码：
<!--#include file="inc_clsEmail.asp"-->
<%
Dim sAction,objMail,strID,strConn,strSQL,objConn,objRS
Dim sServer,bSMTPCheck,sSubject,sBody,sFrom,sFromName,sTo,sBCC,sCC,sSMTPCheck,sAddFile,sUsername,sPassword
sAction = Trim(Request.Form("action"))
If sAction = "发送" Then
Sub DelFiles(filename)
Dim objFSO
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.DeleteFile filename
If Err.Number <> 0 Then On Error Goto 0
End Sub
Dim MyMail,sReturn,aryTemp,i,sAttachmentPath
Dim sFileName,sFilePath,intID
intID = Trim(Session("Attachment_ID"))
If intID = "" THen
\'去除附件表中的相应附件记录
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")
strSQL = "DELETE FROM [attachment]"
Set objConn = CreateObject("Adodb.Connection")
On Error Resume Next
Set objRS = objConn.Execute(strSQL)
If err.Number <> 0 Then
On Error Goto 0
End If
Set objConn = Nothing
Session("Attachment_ID") = ""
Session.Abandon
sSubject = Trim(Request.Form("subject"))
sUsername = Trim(Request.Form("username"))
sPassword = TriM(Request.Form("password"))
sBody = Trim(Request.Form("body"))
sFrom = Trim(Request.Form("from"))
sFromName = Trim(Request.Form("fromname"))
sTo = Trim(Request.Form("to"))
sBCC = Trim(Request.Form("BCC"))
sCC = Trim(Request.Form("CC"))
\'创建邮件Class
Set MyMail = New SWEmail
\'自已设定邮件组件创建字符串
\'MyMail.SetObject("CDONTS.NewMail")
\'MyMail.SetObject("JMail.Message")
\'MyMail.SetObject("JMail.SmtpMail")
If sBCC <> "" Then MyMail.BCC(sBCC) \'密送
If sCC <> "" Then MyMail.CC(sCC) \'抄送
If sServer <> "" Then MyMail.Server(sServer)
\'发送的是纯文本邮件，默认为HTML邮件
MyMail.IsHTML(False)
\'组件测试
MyMail.Check sFrom,sFromName,sTo,sSubject,sBody
\'发送邮件
\'sReturn = MyMail.Send(sFrom,sFromname,sTo,sSubject,sBody)
\'释放class占用的资源
MyMail.Close
\'If sReutrn = True Then
\' Response.Write("<br>呵呵，邮件发送成功啦！<br>")
\'Else
\' Response.Write(sReturn)
\'End If
Response.End
Else
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")
strSQL = "SELECT * FROM [attachment] WHERE id=" & intID
Set objConn = CreateObject("Adodb.Connection")
objConn.Open strConn
Set objRS = objConn.Execute(strSQL)
sFrom = objRS("From")
sFromname = objRS("Fromname")
sSubject = objRS("subject")
sBody = objRS("body")
sTo = objRS("to")
sAddFile = objRS("filenames")
sBCC = objRS("bcc")
sCC = objRS("cc")
sServer = objRS("server")
sUsername = objRS("username")
sPassword = objRS("password")
bSMTPCheck = objRS("smtpcheck")
\'去除附件表中的相应附件记录
strSQL = "DELETE FROM [attachment] WHERE id=" & intID
On Error Resume Next
Set objRS = objConn.Execute(strSQL)
If err.Number <> 0 Then
On Error Goto 0
End If
Session("Attachment_ID") = ""
Session.Abandon
objConn.Close
Set objConn = Nothing
\'创建邮件Class
Set MyMail = New SWEmail
\'自已设定邮件组件创建字符串
\'MyMail.SetObject("CDONTS.NewMail")
\'MyMail.SetObject("JMail.Message")
\'MyMail.SetObject("JMail.SmtpMail")
If sBCC <> "" Then MyMail.BCC(sBCC) \'密送
If sCC <> "" Then MyMail.CC(sCC) \'抄送
MyMail.AddFile(Replace(sAddFile,",","$")) \'添加附件
If sServer <> "" Then MyMail.Server(sServer)
\'发送的是纯文本邮件，默认为HTML邮件
MyMail.IsHTML(False)
\'组件测试
MyMail.Check sFrom,sFromName,sTo,sSubject,sBody
\'发送邮件
\'sReturn = MyMail.Send(sFrom,sFromname,sTo,sSubject,sBody)
\'释放class占用的资源
MyMail.Close
\'If sReutrn = True Then
\' Response.Write("<br>呵呵，邮件发送成功啦！<br>")
\'Else
\' Response.Write(sReturn)
\'End If
\'删除服务器上的附件
sAttachmentPath = Server.Mappath("AttachmentFiles")
If Instr(sAddFile,",") <> 0 Then
aryTemp = Split(sAddFile,",")
For i = LBound(aryTemp) To UBound(aryTemp)
Call DelFiles(sAttachmentPath & "" & aryTemp(i))
Next
Else
If Trim(sAddFile) <> "" Then
Call DelFiles(sAttachmentPath & "" & sAddFile)
End If
End If
Response.End
End If
ElseIf sAction = "附件" Then
sServer = Trim(Request.Form("smtpserver"))
bSMTPCheck= Trim(Request.Form("smtpcheck"))
If (bSMTPCheck = "True") or (bSMTPCheck=True) Then
bSMTPCheck = True
Else
bSMTPCheck = False
End If
sSubject = Trim(Request.Form("subject"))
sUsername = Trim(Request.Form("username"))
sPassword = TriM(Request.Form("password"))
sBody = Trim(Request.Form("body"))
sFrom = Trim(Request.Form("from"))
sFromName = Trim(Request.Form("fromname"))
sTo = Trim(Request.Form("to"))
sBCC = Trim(Request.Form("BCC"))
sCC = Trim(Request.Form("CC"))
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")
Set objConn = CreateObject("Adodb.Connection")
objConn.Open strConn
Set objRS = CreateObject("Adodb.RecordSet")
If Session("Attachment_ID") <> "" Then
strSQL = "SELECT * FROM [attachment] WHERE id=" & Session("Attachment_ID")
objRS.Open strSQL,objConn,1,2
Else
strSQL = "SELECT * FROM [attachment]"
objRS.Open strSQL,objConn,1,2
objRS.Addnew
End If
objRS("SmtpCheck") = bSMTPCheck
objRS("username") = sUsername
objRS("password") = sPassword
objRS("Server") = sServer
objRS("Subject") = sSubject
objRS("body") = sBody
objRS("from") = sFrom
objRS("fromname") = sFromname
objRS("bcc") = sBCC
objRS("cc") = sCC
objRS("to") = sTo
objRS.Update
Session("Attachment_ID") = objRS("id")
objRS.Close
Set objRS = Nothing
objConn.Close
Set objConn = Nothing
Response.Redirect "upload.asp"
Else
strID = Trim(Session("Attachment_ID"))
If strID <> "" Then
\' strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")
strConn = "Driver={Microsoft Access Driver (*.mdb)};DBQ=" & Server.Mappath("attachment.mdb")
strSQL = "SELECT * FROM [attachment] WHERE id=" & strID
Set objConn = Server.CreateObject("Adodb.Connection")
objConn.Open strConn
On Error Resume Next
Set objRS = objConn.Execute(strSQL)
If err.Number <> 0 Then
On Error Goto 0
Response.Write("找不到相应的附件，程序将终止运行！")
Response.End
Else
sServer = objRS("server")
bSMTPCheck = objRS("SMTPCheck")
sSubject = objRS("Subject")
sBody = objRS("body")
sFrom = objRS("from")
sFromname = objRS("fromname")
sTo = objRS("to")
sBCC = objRS("bcc")
sCC = objRS("cc")
sUsername = objRS("username")
sPassword = objRS("password")
sAddFile = objRS("filenames")
End If
objConn.Close
Set objConn = Nothing
End If
%>
<html>
<head>
<title>发送</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<script>
function scheck() {
if (form1.smtpcheck.checked)
form1.smtpcheck.value=true
else
form1.smtpcheck.value=false;
}
</script>
</head>
<body bgcolor="#FFFFFF" text="#000000">
<form name="form1" method="post" action="mail.asp">
<p>邮件服务器
<input type="text" name="smtpserver" value="<%=sServer%>">
</p>
<p>组件
<input type="text" name="mailobject">
</p>
<p>ＳＭＴＰ验证：
<%If bSMTPCheck Then%>
<input type="checkbox" name="smtpcheck" value="true" onclick="scheck();" checked>
<%Else%>
<input type="checkbox" name="smtpcheck" value="false" onclick="scheck();">
<%End If%>
</p>
<p>用户名：
<input type="text" name="username" value="<%=sUsername%>">
</p>
<p>密 码：
<input type="text" name="password" value="<%=sPassword%>">
</p>
<p>收信人地址
<input type="text" name="to" value="<%=sTo%>">
</p>
<p>发信人地址
<input type="text" name="from" value="<%=sFrom%>">
</p>
<p>发信人姓名
<input type="text" name="fromname" value="<%=sFromName%>">
</p>
<p>抄 送
<input type="text" name="cc" value="<%=sCC%>">
</p>
<p>密 送
<input type="text" name="bcc" value="<%=sBCC%>">
</p>
<p>主 题
<input type="text" name="subject" value="<%=sSubject%>">
</p>
<p>附 件：
<input type="text" name="addfile" value="<%=sAddFile%>">
</p>
<p>内 容
<textarea name="body" rows="20" cols="100"><%=sBody%>
</textarea>
</p>
<p>
<input type="submit" name="action" value="发送">
<input type="submit" name="action" value="附件">
</p>
</form>
</body>
</html>
<%End If%>
inc_clsEmail.asp文件，主要实现了邮件发送的全过程。此类有如下几种方法：a)check,主要是检测服务器支持哪些发信组件，并且发送一封邮件，看看能否成功发送；b)mailerr,主要是返回发送邮件过程中的错误信息；c)server,设置ＳＭＴＰ服务器的地址；d) send,发送邮件；e)BCC,密送邮件；f)CC,抄送邮件;g)addfile,添加附件，可添加多个附件；h)close,释放数据。
inc_clsEmail.asp的代码：
<%Option Explicit
\'#########声明变量########
\'以下定义邮件组件类型常量
Private Const SWEmail_JMail43 = 0
Private Const SWEmail_JMail = 1
Private Const SWEmail_ASPEMail = 2
Private Const SWEmail_ASPMail = 3
Private Const SWEmail_EasyWebmail = 4
Private Const SWEmail_CMailServer = 5
Private Const SWEmail_CDO = 6
\'本类支持的组件数,由于数组的下标是从0开始的，所以实际是支持7个组件
Private Const SWEmail_intMailobjects = 6
\'邮件组件数组
ReDim SWEmail_aryMailObject(SWEmail_intMailobjects,2)
\'JMail 4.3
SWEmail_aryMailObject(0,0) = "JMail.Message" \'创建组件的字符串，此字符串固定
SWEmail_aryMailObject(0,1) = SWEmail_JMail43 \'组件的类型，自定义
\'JMail 早期版本
SWEmail_aryMailObject(1,0) = "JMail.SmtpMail"
SWEmail_aryMailObject(1,1) = SWEmail_JMail
\'ASP EMail
SWEmail_aryMailObject(2,0) = "Persits.MailSender"
SWEmail_aryMailObject(2,1) = SWEmail_ASPEMail
\'ASP Mail
SWEmail_aryMailObject(3,0) = "smtpsvg.mailer"
SWEmail_aryMailObject(3,1) = SWEmail_ASPMail
\'Easy Web Mail
SWEmail_aryMailObject(4,0) = "easymail.MailSEnd"
SWEmail_aryMailObject(4,1) = SWEmail_EasyWebmail
\'CMail Server
SWEmail_aryMailObject(5,0) = "CMailCOM.SMTP.1"
SWEmail_aryMailObject(5,1) = SWEmail_CMailServer
\'微软自带的组件
SWEmail_aryMailObject(6,0) = "CDONTS.NewMail"
SWEmail_aryMailObject(6,1) = SWEmail_CDO
\'记录邮件组件创建字符串
Private SWEmail_strMailObject
\'邮件组件的类型
Private SWEmail_intMailType
\'邮件组件的名称（描述）
Private strMailName
\'邮件附件信息
Private SWEmail_strFiles
Private SWEmail_strFrom \'发件人Email地址
Private SWEmail_strFromName \'发件人姓名
Private SWEmail_strTo \'收件人Email地址
Private SWEmail_strSubject \'邮件主题
Private SWEmail_strBody \'邮件内容
Private SWEmail_strBCC \'密送人Email地址
Private SWEmail_strCC \'抄送人Email地址
Private SWEmail_strSMTPServer \'邮件服务器地址
Private SWEmail_intSpeed \'邮件等级
Private SWEmail_blnIsHTML \'是否HTML邮件，True为HTML邮件，FASLE为纯文本邮件
Private SWEmail_strUserName \'身份验证时输入的用户名
Private SWEmail_strPassword \'身份验证时输入的密码
Private SWEmail_strAttachmentPath \'附件路径
Private SWEmail_strError \'错误信息
\'#########声明结束########
\'#########数据初始化########
\'默认为普通
SWEmail_intSpeed = 1
\'默认为HTML邮件
SWEmail_blnIsHTML = True
\'设置默认发件服务器地址
\'SWEmail_strSMTPServr = "SMTP.163.com"
\'设置默认组件字符串
\'SWEmail_strMailObject = "JMail.Message"
\'设置附件文件的路径
SWEmail_strAttachmentPath = Server.Mappath("attachmentfiles")
\'#########初始化结束########
Class SWEmail
\'检测服务支持的邮件组件
Sub Check(sFrom,sFromName,sTo,sSubject,sBody)
Dim i,objTest,sReturn
Response.Write("<table border=""0"" cellspacing=""1"" cellpadding=""0"" bgcolor=""#000000"" align=""center"" width=""85%"">" & vbcrlf)
Response.Write(" <tr align=""center"" height=""30"" bgcolor=""#FFFFFF"">" & vbcrlf)
Response.Write(" <td width=""33%"">Name</td>" & vbcrlf & " <td>Enable</td>" & vbcrlf & " <td>IsSent</td>" & vbcrlf)
Response.Write(" </tr>" & vbcrlf)
For i = 0 To SWEmail_intMailobjects
On Error Resume Next
Set objTest = CreateObject(CStr(SWEmail_aryMailObject(i,0)))
Response.Write(" <tr align=""center"" height=""25"" bgcolor=""#FFFFFF"">" & vbcrlf)
Response.Write(" <td>" & SWEmail_aryMailObject(i,0) & "</td>" & vbcrlf)
If err.Number <> 0 Then \'查看错误原因
On Error Goto 0
Response.Write( " <td>No</td>" & vbcrlf)
Response.Write( " <td>No</td>" & vbcrlf)
Else
SWEmail_strMailObject = SWEmail_aryMailObject(i,0)
SWEmail_intMailType = SWEmail_aryMailObject(i,1)
Response.Write( " <td>Yes</td>" & vbcrlf)
sReturn = Send(sFrom,sFromName,sTo,sSubject,sBody)
If (sReturn = True) Then
Response.Write(" <td>Success</td>" & vbcrlf)
Else
If sReturn = False Then
Response.Write(" <td>Failed</td>" & vbcrlf)
Else
Response.Write(" <td>" & sReturn & "</td>" & vbcrlf)
End If
End If
End If
Response.Write(" </tr>" & vbcrlf)
Next
Response.Write("</table>" & vbcrlf)
End Sub
\'自动检测服务器支持的组件并设置，如果成功返回True，否则返回False
Function AutoSet()
Dim i,objTest
\'没检测到发送邮件的组件
AutoSet = False
SWEmail_strMailObject = ""
SWEmail_intMailType = ""
For i = 0 To SWEmail_intMailobjects
On Error Resume Next
Set objTest = CreateObject(SWEmail_aryMailObject(i,0))
If err.Number = 0 Then
\'只要检测到就退出，不继续检测！
AutoSet = True
SWEmail_strMailObject = SWEmail_aryMailObject(i,0)
SWEmail_intMailType = SWEmail_aryMailObject(i,1)
Exit Function
End If
Next
Set objTest = Nothing
End Function
Function MailErr()
MailErr = SWEmail_strError
End Function
\'邮件等级设置
Sub Speed(str)
\'0:最慢,1:默认,2,最快
If Trim(str) = "" Then
str = 1
Else
str = CInt(str)
End If
Select Case SWEmail_intMailType
Case SWEmail_JMail43
If str = 0 Then
SWEmail_intSpeed = 5
ElseIf str = 1 Then
SWEmail_intSpeed = 3
ElseIf str = 2 Then
SWEmail_intSpeed = 1
Else
SWEmail_intSpeed = 3
End If
Case SWEmail_JMail
If str = 0 Then
SWEmail_intSpeed = 5
ElseIf str = 1 Then
SWEmail_intSpeed = 3
ElseIf str = 2 Then
SWEmail_intSpeed = 1
Else
SWEmail_intSpeed = 3
End If
Case SWEmail_CDO
SWEmail_intSpeed = str
End Select
End Sub
\'是否发送HTML邮件
Sub IsHTML(bln)
SWEmail_blnIsHTML = bln
End Sub
\'SMTP服务器地址
Sub Server(str)
SWEmail_strSMTPServer = str
End Sub
\'发信
Function Send(from,fromname,go,subject,body)
Dim sReturn
\'发信人的Email地址
SWEmail_strFrom = from
\'发信人的名字
SWEmail_strFromName = fromname
\'收信人Email地址
SWEmail_strTo = go
\'邮件主题
SWEmail_strSubject = subject
\'邮件内容
SWEmail_strBody = body
sReturn = Execute()
If sReturn = True Then
Send = True
Else
Send = sReturn
End If
End Function
\'密送
Sub BCC(str)
SWEmail_strBCC = str
End Sub
\'抄送
Sub CC(str)
SWEmail_strCC = str
End Sub
\'添加附件
Sub AddFile(str)
SWEmail_strFiles = str
End Sub
\'SMTP验证,只有JMail组件可用
Sub SMTPCheck(username,password)
SWEmail_strUsername = username
SWEmail_strPassword = password
End Sub
\'设置邮件组件对象
Sub SetObject(str)
Dim i
For i = 0 To SWEmail_intMailObjects
If SWEmail_aryMailObject(i,0) = str Then
SWEmail_strMailObject = str
SWEmail_intMailType = SWEmail_aryMailObject(i,1)
Exit For
End If
Next
End Sub
\'发送邮件主体
Function Execute()
Dim i,sFilePath,strFileName,strTemp,aryTemp,intUpLimit
Dim objMail
If Trim(SWEmail_strMailObject) = "" Then
Execute = "It can\'t create a null string object."
Exit Function
End If
\'On Error Resume Next
Set objMail = CreateObject(SWEmail_strMailObject)
If Err.Number <> 0 Then
Execute = "Can\'t create object <font color=""#ff0000"">" & SWEmail_strMailObject & "</font>."
Exit Function
End If
Select Case SWEmail_intMailType
Case SWEmail_JMail43 \'Jmail4.3 发信主体
\'屏蔽例外错误
objMail.Silent = True
\'启用邮件日志
\'objMail.logging = True
objMail.Charset = "GB2312"
objMail.AddRecipient SWEmail_strTo
objMail.AddRecipientBCC SWEmail_strBCC
objMail.AddRecipientCC SWEmail_strCC
objMail.From = SWEmail_strFrom
objMail.MailServerUserName = SWEmail_strUserName
objMail.MailServerPassword = SWEmail_strPassword
objMail.Subject = SWEmail_strSubject
If SWEmail_blnIsHTML = True Then
objMail.ContentType = "text/html"
objMail.HtmlBody = SWEmail_strBody
Else
objMail.Body = SWEmail_strBody
End If
objMail.Priority = SWEmail_intSpeed
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & strFileName)
End If
Next
Else
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & SWEmail_strFiles)
End If
End If
objMail.Send(SWEmail_strSMTPServer)
objMail.Close()
Case SWEmail_JMail
\'Jmail早期版本发信主体
objMail.Silent = True
objMail.logging = True
objMail.Charset = "GB2312"
objMail.ContentType = "text/html"
objMail.ServerAddress = SWEmail_strSMTPServer
objMail.AddRecipient SWEmail_strTo
objMail.AddRecipientBCC SWEmail_strBCC
objMail.AddRecipientCC SWEmail_strCC
objMail.SenderName = SWEmail_strFromName
objMail.Sender = SWEmail_strFrom
objMail.Priority = SWEmail_intSpeed
objMail.Subject = SWEmail_strSubject
objMail.Body = SWEmail_strBody
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & strFileName)
End If
Next
Else
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & SWEmail_strFiles)
End If
End If
objMail.Execute()
objMail.Close
Case SWEmail_ASPEMail
\'ASPMail组件
If Trim(SWEmail_strServer) <> "" Then objMail.Host = SWEmail_strServer
If Trim(SWEmail_strBCC) <> "" Then objMail.AddBcc SWEmail_strBCC
If Trim(SWEmail_strUsername) <>"" Then objMail.Username = SWEmail_strUsername
If Trim(SWEmail_strPassword) <>"" Then objMail.Password = SWEmail_strPassword
objMail.Subject = SWEmail_strSubject
objMail.From = SWEmail_strFrom
objMail.Body = SWEmail_strBody
objMail.AddAddress SWEmail_strTo
objMail.IsHTML = SWEmail_blnIsHTML
objMail.CharSet = "gb2312"
objMail.Priority = SWEmain_intSpeed
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & strFileName)
End If
Next
Else
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & SWEmail_strFiles)
End If
End If
Case SWEmail_ASPMail
objMail.CusTomCharSet = "gb2312"
objMail.FromAddress = FromMail
objMail.FromName = FromName
objMail.AddRecipient ToMail, ToMail
If ToMailbcc <> "" Then objMail.AddBCC ToMailbcc, ToMailbcc
objMail.Subject = MailSubject
If MailFormat = "html" Then
objMail.ContentType = "text/html"
objMail.BodyText = MailBody
Else
objMail.BodyText = MailBody
End If
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
objMail.ClearAttachments
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & strFileName)
End If
Next
Else
objMail.AddAttachment (SWEmail_strAttachmentPath & "" & SWEmail_strFiles)
End If
End If
objMail.Priority = SWEmail_intSpeed
objMail.RemoteHost = SWEmail_strServer
objMail.Timeout = 9999
objMail.SendMail
SWEmail_strError = objMail.Response
Case SWEmail_EasyWebmail
objMail.CreateNew SWEmail_strFrom, "temp"
objMail.MailName = SWEmail_strFromName
objMail.EM_To = SWEmail_strTo
If Trim(SWEmail_strBCC) <> "" Then objMail.EM_BCC SWEmail_strBCC
objMail.EM_Subject = SWEmail_strSubject
If SWEmail_IsHTML = true Then
objMail.EM_HTML_Text = SWEmail_strBody
objMail.useRichEditer = true
Else
objMail.EM_Text = SWEmail_strBody
End If
objMail.EM_Priority = SWEmail_intSpeed
\'If TimeMail Then objMail.EM_TimerSEnd = webmailtime
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AddFromAttFileString = SWEmail_strAttachmentPath & "" & strFileName
End If
Next
Else
objMail.AddAttFileString = SWEmail_strAttachmentPath & "" & SWEmail_strFiles
End If
End If
If objMail.Send() = FALSE Then
SWEmail_strError= "有错误发生"
End If
Case SWEmail_CMailServer
objMail.CreateUserPath("ASPMail")
objMail.Subject = SWEmail_strSubject
objMail.Body = SWEmail_strBody
objMail.To = SWEmail_strTo
objMail.From = SWEmail_strFrom
objMail.SendMail
If Left(objMail.LastResponse, 3) <> "+OK" Then
SWEmail_strError = "错误原因：" & objMail.LastResponse
End If
Case SWEmail_CDO
\'微软自带发信主体
objMail.Subject = SWEmail_strSubject
objMail.From = SWEmail_strFrom
objMail.To = SWEmail_strTo
If SWEmail_blnIsHTML Then
objMail.BodyFormat = 0 \'支持HTML
Else
objMail.BodyFormat = 1 \'支持纯文本
End If
\'0 表示将采用 MIME 格式
\'1 表示将采用连续的纯文本（默认值）
\'objMail.MailFormat = 0
objMail.Body = SWEmail_strBody
\'发送附件
If Trim(SWEmail_strFiles) <> "" Then
If Instr(SWEmail_strFiles,"$") <> 0 Then
aryTemp = Split(SWEmail_strFiles,"$")
intUpLimit = UBound(aryTemp)
For i = LBound(aryTemp) To intUpLimit
strFileName = Trim(aryTemp(i))
If strFileName <> "" Then
objMail.AttachFile (SWEmail_strAttachmentPath & "" & strFileName)
End If
Next
Else
objMail.AttachFile (SWEmail_strAttachmentPath & "" & SWEmail_strFiles)
End If
End If
objMail.Send
End Select
If Err.Number <> 0 Then
If Trim(err.Description) <> "" Then Execute = Err.Description & "<br>"
Else
Execute = True
End If
Set objMail = Nothing
End Function
\'清空内容
Sub Close()
SWEmail_strMailObject = ""
SWEmail_intMailType = ""
strMailName = ""
SWEmail_strFiles = ""
SWEmail_intSpeed = ""
\'释放数组
Erase SWEmail_aryMailObject
End Sub
End Class
%>
upload.asp的源码：
<%
If Trim(Request.ServerVariables("HTTP_REFERER"))="" Then
\'Response.Write(Request.ServerVariables("HTTP_REFERER"))
\'Response.End
Response.Redirect "mail.asp"
Response.End
End If
%>
<!--#include file="inc_set.asp"-->
<html>
<head>
<title>文件上传</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<style type="text/css">
<!--
.tx { height: 16px; width: 30px; border-color: black black #000000; border-top-width: 0px; border-right-width: 0px; border-bottom-width: 1px; border-left-width: 0px; font-size: 9pt; background-color: <%=clrGeneralTR%>; color: #0000FF}
.tx1 { height: 20px; width: 30px; font-size: 9pt; border: 1px solid; border-color: black black #000000; color: #0000FF}
-->
</style>
</head>
<body topmargin="0">
<table border="1">
<tr>
<td>
<br><form name="form1" method="post" action="uploadok.asp" enctype="multipart/form-data">
<table width="88%" border="0" cellspacing="1" cellpadding="0" align="center">
<tr bgcolor="<%=clrTitleTR%>">
<td height="28" align="center" valign="middle" bgcolor="<%=clrTitleTR%>"><b>文件上传</b></td>
</tr>
<tr align="left" valign="middle" bgcolor="<%=clrGeneralTR%>">
<td height="92">
<script language="javascript">
<!--
function setid()
{
str=\'<br>\';
if(!window.form1.upcount.value)
window.form1.upcount.value=1;
for(i=1;i<=window.form1.upcount.value;i++)
str+=\'文件\'+i+\':<input type="file" name="file\'+i+\'" style="width:350" class="tx1"> 文件重命名：<input type="text" name="filename\'+i+\'" style="width:100" class="tx"><br><br>\';
window.upid.innerHTML=str+\'<br>\';
}
file://-->
</script>
<li> 需要上传的个数
<input type="text" name="upcount" class="tx" value="2">
<input type="button" name="Button" class="button" onclick="setid();" value="设置">
</li>
</td>
</tr>
<tr align="center" valign="middle" bgcolor="<%=clrGeneralTR%>">
<td align="left" id="upid" height="122"> 文件1:
<input type="file" name="file1" style="width:200" class="tx1" value="">
<input type="text" name="filename1" style="width:30" class="tx">
</td>
</tr>
<tr align="center" valign="middle" bgcolor="<%=clrTitleTR%>">
<td height="28" bgcolor="<%=clrTitleTR%>"></td>
</tr>
<tr>
<td>
<input type="submit" name="action" value="上传" class="button">
</td>
</tr>
</table>
</form>
</td>
</tr>
</table>
</body>
</html>
<script language="javascript">
<!--
setid();
file://-->
</script>
uploadok.asp的源码：
<%Option Explicit
Response.Expires = 0
%>
<!--#include file="inc_clsUpload.asp"-->
<%
Private Function FormatStr(str)
str = Trim(BinToStr(str))
str = Replace(str,"\'","\'\'")
str = Replace(str,vbcrlf,"")
FormatStr = str
End Function
\'设置文件上传路径，此目录必须存在，否则会出错
Private Const svrUploadFilePath = "attachmentfiles"
Dim strNewName,sNewname,strSQL,strNoPic,strInfo,strFileName,strFilePath
Dim intFormSize,intFileCount,I
Dim binFormData,binTextData,binFileData
Dim aryFileName
Dim objUpload
\'获取表单数据的大小
intFormSize = Request.TotalBytes
\'获取所有的表单数据
binFormData = Request.BinaryRead(intFormSize)
\'创建上传类
Set objUpload = New Upload
\'初始化表单提交的数据中
objUpload.Init(binFormData)
\'清空数据
binFormData = ""
strInfo = ""
intFileCount = objUpload.FileCount
\'设置上传文件存放的路径
objUpload.SetPath(svrUploadFilePath)
\'获取上传文件的存放路径
\'strFilePath = objUpload.GetPath
\'设置允许上传的文件格式,多种格式以|分隔
objUpload.AllowFiles ("zip|rar|jpg|png|bmp|txt|htm|html")
\'获取默认文件名列表
strFileName = objUpload.FileName
aryFileName = Split(strFileName,",")
If intFileCount > 1 Then
For i = 1 To intFileCount
sNewname = objUpload.FormName("filename" & i)
If sNewname = "" Then sNewname = aryFileName(i-1)
If strNewname = "" Then
strNewname = strNewname & sNewname
Else
strNewname = strNewname & "," & sNewname
End If
Next
Else
strNewname = objUpload.FormName("filename1")
End If
\'清空文本内容
binTextData = ""
Dim strAttachmentFiles
If strInfo = "" Then
If strNewName = "" Then strNewName = strFileName
If objUpload.FileExist(strNewName) Then\'如果文件不存在，则保存文件
If objUpload.SaveFile(strNewName) Then
strAttachmentFiles = strAttachmentFiles & strNewName & ","
\' strInfo = strInfo & objUpload.ErrorInfo
\' Else
\' strInfo = strInfo & objUpload.ErrorInfo
End If
\' Else
\' strInfo = strInfo & objUpload.ErrorInfo
End If
End If
Dim oConn,oRS,sConn
strSQL = "UPDATE [attachment] SET filenames=\'" & Left(strAttachmentFiles,Len(strAttachmentFiles)-1) & "\' WHERE id=" & Session("Attachment_ID")
sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.Mappath("attachment.mdb")
\' sConn = "Driver={Microsoft Access Driver (*.mdb)};DBQ=" & Server.Mappath("attachment.mdb")
Set oConn = CreateObject("Adodb.Connection")
oConn.Open sConn
Set oRS = oConn.Execute(strSQL)
Set oConn = Nothing
Response.Redirect "mail.asp"
Response.End
%>
inc_clsUpload.asp的源码：
<%
\'*****************************************
\' 目的： 将Binary字符转成String。
\' 输入： str: 需要转换Binary。
\' 返回： 转换后的String,并把string中的\'替换成\'\',换行符去掉。
\'*****************************************
Private Function BinToStr(str)
Dim i,strTemp
strTemp = ""
For i=1 To LenB(str)
If AscB(MidB(str, i, 1)) > 127 Then
strTemp = strTemp & Chr(Ascb(MidB(str, i, 1))*256+Ascb(MidB(str, i+1, 1)))
i = i + 1
Else
strTemp = strTemp & Chr(AscB(MidB(str, i, 1)))
End If
Next
strTemp = Replace(Replace(Trim(strTemp),"\'","\'\'"),VBCRLF,"")
BinToStr=strTemp
End Function
\'*****************************************
\' 目的： 将String转成Binary。
\' 输入： str: 需要转换的String。
\' 返回： 转换后的二进制字符串。
\'*****************************************
Private Function StrToBin(str)
Dim i, binTemp
For i = 1 To Len(str)
binTemp = binTemp & ChrB(Asc(Mid(str,I,1)))
Next
StrToBin = binTemp
End Function
Class Upload
\'文件名、文件路径、错误信息、文件信息、允许上传的文件后缀名
Dim strFileName,strFilePath,strErrorInfo,strFileInfo,strAllowed
\'文件开始位置、文件大小、文件个数
Dim intFileStart,intFileSize,intFileCount
\'AdoStream对象objData和Dictionary对象objFiles
Dim objData,objFiles
\'二进制数据
Dim binTxtData
\'以上变量均为Class级变量，可在此Class的所有过程函数中使用
\'*****************************************
\' 目的： 将文件与文本数据分离,保存文件到Dictionary对象
\' 输入： formdata： 为表单提交的所有数据
\' 返回： 无
\'*****************************************
Sub Init(formdata)
Dim BnCrlf,binName,binFileName,binQuotation,binSpace,binFileContent
Dim sStart,sInfo,sFileName,sFormName,sFormValue
Dim iStart,iFormStart,iFormEnd,iInfoStart,iInfoEnd,iFindStart,iFindEnd,iValStart,iValEnd,iFileName
Set objFiles = Server.CreateObject("Scripting.Dictionary")
Set objData = Server.CreateObject("Adodb.Stream")
objData.Type = 1
objData.Mode = 3
objData.Open
objData.Write formdata
BnCrlf = ChrB(13) & ChrB(10)
binName = StrToBin("name=""")
binFileName = StrToBin("filename=""")
binQuotation = StrToBin("""")
binSpace = StrToBin(" ")
intFileCount = 0 \'文件个数清零
iFormEnd = LenB(formdata)
iFormStart = 1
\'-----------------------------7d320717017a
sStart = MidB(formdata,1,InStrB(1,formdata,bnCrlf)-1)
iStart = LenB(sStart)
iFormStart = iFormStart+iStart+1
While iFormStart + 10 < iFormEnd
iInfoEnd = InStrB(iFormStart,formdata,BnCrlf&BnCrlf)+1
sInfo = MidB(formdata,iFormStart,iInfoEnd-iFormStart)
\'Find form name
iFormStart = InStrB(iInfoEnd,formdata,sStart)
iFindStart = InStrB(11,sInfo,binName,1)
iFindEnd = InStrB(iFindStart+6,sInfo,binQuotation,1)
sFormName = MidB(sInfo,iFindStart,iFindEnd-iFindStart)
\'取得表单值起始位置
iValStart = iInfoEnd + 1
\'如果是文件
If InStrB (22,sInfo,binFileName,0) > 0 Then
\'取得文件名
iFindStart = InStrB(iFindEnd,sInfo,binFileName,0) + 10
iFindEnd = InStrB(iFindStart,sInfo,binQuotation,1)
sFileName = MidB(sInfo,iFindStart,iFindEnd-iFindStart)
sFileName = BinToStr(sFileName)
iFileName = InstrRev(sFileName,"",-1) + 1
sFileName = Mid(sFileName,iFileName,Len(sFileName)-iFileName + 1)
If Trim(strFileName) <> "" Then
strFileName = strFileName & "," & sFileName
Else
strFileName = sFileName
End If
\'文件开始位置
intFileStart = iInfoEnd
\'文件大小
intFileSize = iFormStart -iInfoEnd
\'文件内容
\'binFileContent = MidB(formdata,intFileStart,intFileSize)
\'添加文件,以文件名为关键字
If Not objFiles.Exists(sFileName) Then
objFiles.Add sFileName,intFileStart & "," & intFileSize
Else
strErrorInfo = strErrorInfo & "<br>文件 <b>" & sFileName & "</b> 已经存在！"
Exit Sub
End If
\'统计文件个数
intFileCount = intFileCount + 1
Else \'如果是表单项目
iValEnd = iFormStart-iInfoEnd-3
If iValEnd> 0 Then
sFormValue = MidB(formdata,iValStart,iValEnd)
Else
sFormValue = ""
End If
binTxtData = binTxtData & sFormname & StrToBin(":") & sFormValue & StrToBin("""")
End If
iFormStart=iFormStart + iStart + 1
Wend
formdata=""
End Sub
\'*****************************************
\' 目的： 限制文件上传的类型,只能许sAllow格式的文件
\' 输入： strLimit，允许上传的文件格式，多种格式用|分开
\'
\' 返回： 允许上传的文件格式（多种格式用|分开）
\'*****************************************
Sub AllowFiles(sAllow)
strAllowed = sAllow
End Sub
\'*****************************************
\' 目的： 检查文件后缀是否为被允许的文件格式
\' 输入： filename
\'
\' 返回： 如果是允许的文件格式返回True,否则返回False
\'*****************************************
Function IsAllowed(filename)
Dim intStart
IsAllowed = False
If strAllowed = "" Then
IsAllowed = True
Else
filename=Trim(filename)
If Trim(filename) <> "" Then
intStart = InstrRev(filename,".")
If intStart > 0 Then
If Instr(strAllowed,Mid(filename,intStart+1,Len(filename)-intStart))>0 Then
IsAllowed = True
End If
End IF
End If
End If
End Function
\'*****************************************
\' 目的： 统计文件个数
\' 输入： 无
\' 返回： 返回上传的文件个数
\' 说明： intFileCount是一个Class级变量，在本Class内有效
\' 在函数PickData过程中，统计文件个数
\'*****************************************
Function FileCount()
FileCount = intFileCount
End Function
\'*****************************************
\' 目的： 将二进制数据写入文件
\' 输入： FileName： 文件名
\' 返回： 保存成功返回TRUE，失败则返回错误信息
\'*****************************************
Function SaveFile(filename)
Dim i,iFileCount
Dim objSaveFile
Dim sFileName,sNewpath,binFileCount
Dim aryFileName,aryNewName,aryFileInfo
SaveFile = True
Set objSaveFile = Server.CreateObject("Adodb.Stream")
objSaveFile.Mode=3 \'3表示adModeReadWrite
objSaveFile.Type=1 \'1表示adTypeBinary
objSaveFile.Open()
\'On Error Resume Next
If Trim(filename) = "" Then filename = strFileName
If Instr(filename,",")>0 Then
\'多文件
aryFileName = Split(strFileName,",")
aryNewname = Split(filename,",")
For i =LBound(aryNewName) To UBound(aryNewName)
sFileName = aryFileName(i)
If IsAllowed(sFileName) Then \'是否为允许的文件格式
objSaveFile.Position = 0
aryFileInfo = Split(objFiles.Item(sFileName),",")
\'objSaveFile.Write objFiles.Item(sFileName)
objData.Position = aryFileInfo(0) + 2
objData.CopyTo objSaveFile,aryFileInfo(1)
sNewPath = Server.Mappath(strfilepath&sFileName)
\' strFileInfo = strFileInfo & FileName & "<Br>"
strErrorInfo = strErrorInfo & "<br>文件 <Font Color=""#FF0000"">" & sFileName & "</Font>上传成功"
\'存成文件，2表示adSaveCreateOverWrite
objSaveFile.SaveToFile sNewPath,2
Else
strErrorInfo = strErrorInfo & "<br>文件 <font color=""#ff00000"">" & sFileName & "</font> 为不被允许上传的文件，请检查文件后缀<br>"
SaveFile = False
\'Exit Function
End If
Next
Else
\'单文件
If IsAllowed(strFileName) Then \'是否为允许的文件格式
aryFileInfo = Split(objFiles.Item(strFileName),",")
objData.Position = aryFileInfo(0) + 2
objData.CopyTo objSaveFile,aryFileInfo(1)
sNewPath = Server.Mappath(strFilePath&FileName)
\' strFileInfo = strFileInfo & FileName & "<Br>"
strErrorInfo = strErrorInfo & "<br>文件 <Font Color=""#FF0000"">" & FileName & "</Font>"
objSaveFile.SaveToFile sNewPath,2
Else
strErrorInfo = strErrorInfo & "<br>文件 <Font Color=""#FF0000"">" & sFileName & "</font> 为不被允许上传的文件，请检查文件后缀！"
SaveFile = False
\'Exit Function
End If
End If
objSaveFile.Close
Set objSaveFile = Nothing
objData.Close
Set objData = Nothing
Set objFiles = Nothing
\'If err.Number <> 0 Then SaveFile = False
End Function
\'*****************************************
\' 目的： 获取表单项的值
\' 输入： name： 为要寻找的字段变量
\' txtdata： 为已从图象中分离出来的的所有文本
\' 返回： 表单项的值
\'*****************************************
Function FindInput(fName,txtdata)
Dim intStartPos,intEndPos,intNameLen,intValEnd,i,bReturn
- 上一篇: ASP常见问题(新手)
- 下一篇: 用ASP实现ASP文件的运行
