DLL向主程序中一个自定义对象发送消息
[问题点数：120分，结帖人Jack_Yin]
DLL向主程序中一个自定义对象发送消息
[问题点数：120分，结帖人Jack_Yin]
不显示删除回复
显示所有回复
显示星级回复
显示得分回复
只显示楼主
本帖子已过去太久远了，不再提供回复功能。后使用快捷导航没有帐号？
只需一步，快速开始
查看: 21732|回复: 10
建议：编写asp各种功能函数库
UID19168在线时间 小时积分149帖子离线17009 天注册时间
初级会员, 积分 149, 距离下一级还需 51 积分
sp能完成很多的功能，但是每个例子都有它的独特性，要使用统一的方法很难，为了大家不重复的提问
每个功能，建议编写asp各种功能函数库，以便大家相互学习，统一编码，提到水平
编写函数的要求
1、函数名称
2、函数的简单介绍
3、函数的内容
4、函数的调用例子
函数名称：通用打开access数据库的函数
函数说明：通用打开asp数据库的函数
&%
function openAccessDB
AccessDb=access.mdb
& & & & Set conn = Server.CreateObject(&ADODB.Connection&)
& & & & connstr=&Provider=Microsoft.Jet.OLEDB.4.0;Data Source=& & Server.MapPath(AccessDB)
& & conn.Open connstr
End Function
%&
复制代码
函数名称：通用关闭access数据库的函数
函数说明：同上
function CloseAccessDB
& & & & Conn.close
& & & & Set conn = Nothing
End Function
复制代码
&%
openaccessDB
sql=&select * from art&
set rs=server.createobject(&adodb.recordset&)
rs.open sql,conn,1,1
.................
CloseAccessDB
%&
UID23092在线时间 小时积分21942帖子离线17009 天注册时间
下面的代码是一个购物车的类！
Class CartKit '开始类CartKit的定义
Sub CreateCart()
If IsArray(Session(&Cart&)) = False Then
Dim aryCart(19,2)
Session(&Cart&) = aryCart
Function CheckCart()
If IsArray(Session(&Cart&)) Then
CheckCart = True
CheckCart = False
End Function
Function CheckItem(ID)
Dim aryCart
If CheckCart = True Then
aryCart = Session(&Cart&)
For i = LBound(aryCart) To UBound(aryCart)
If aryCart(i,0) = ID Then
CheckItem = True
Exit Function
ElseIf aryCart(i,0) && ID Then
CheckItem = False
End Function
Function RemoveItem(ID)
dim i,intPos,aryRemoveCart
aryCartRemove = Session(&Cart&)
For i = LBound(aryCart) To UBound(aryCart)
If aryCart(i,0) = ID Then
intPos = i
For i = intPos To UBound(aryRemoveCart) - 1
If Not aryRemoveCart(i,0) = && Then
aryRemoveCart(i,0) = aryRemoveCart(i+1,0)
aryRemoveCart(i,1) = aryRemoveCart(i+1,1)
aryRemoveCart(i,2) = aryRemoveCart(i+2,2)
Session(&Cart&) = aryRemoveCart
End Function
Function UpdateItem(ID,Num)
dim aryUpdateCart,i
aryUpdateCart = Session(&Cart&)
For i = LBound(aryUpdateCart) To UBound(aryUpdateCart)
If aryUpdateCart(i,0) = ID Then
aryUpdateCart(i,1) = Num
Session(&Cart&) = aryUpdateCart
End Function
Function AddItem(ID,Num)
Dim btnCartStatus,aryAddCart
btnCartStatus = CheckCart
If btnCartStatus = False Then
CreateCart
aryAddCart = Session(&Cart&)
aryAddCart (0,0) = ID
aryAddCart (0,1) = Num
Session (&Cart&) = aryAddCart
Exit Function
ElseIf btnCartStatus = True Then
If CheckItem(ID) = True Then
UpdateItem ID,Num
ElseIf CheckItem(ID) = False Then
aryAddCart = Session(&Cart&)
For i = LBound(aryAddCart) To UBound(aryAddCart)
If aryAddCart(i,0) = && Then
aryAddCart(i,0) = ID
aryAddCart(i,1) = Num
Session(&Cart&) = aryAddCart
Exit Function
End Function
&提示：您可以先修改部分代码再运行
UID23074在线时间 小时积分11629帖子离线17009 天注册时间
谁有好点的通用分页函数吗？贴一个吧，我这里的不够优化！
UID23092在线时间 小时积分21942帖子离线17009 天注册时间
&%
&&'这是我用ASP写的一个N进制转换的函数，不过还有局限性，感兴趣的可以测试一下，有问题请告诉我
&&'【题目】任意进制间的互化。
&&'& && &&&把n进制的Ｍ转化成k进制表示
&&'& && &&&如m=ff n=16 k=2
&&'& && &&&则有&&(ff)16=(
&&'【参考程序】
&&Function KTON(data,k,n)
& && &Dim a(100),strTemp,strData,i,j,strDec,strReturnn
& & & && &'N进制转成十进制
& & & && &strData = Trim(data)
& && &For i=1 TO Len(strData)
& & & && && & strTemp = Mid(strData,Len(strData)-i+1,1)
& && && & If (strTemp&=&9&) And (strTemp&=&0&) Then
& & & && && && &&&a(i)=Asc(strTemp)-48
& && && & End If
& & & & & & & && &If (Ucase(strTemp)&=&F&) And (Ucase(strTemp)&=&A&) Then
& & & & & & & && && & a(i) = Asc(Ucase(strTemp))-55
& && && & End If
& && && & strDec = strDec + a(i) * k^(i-1)
& && &Next
& && &'NTOD = s
& & & && &'十进制转成Ｎ进制
& && &If n = 10 Then
& & & && && & KTON = strDec
& & & & & & & && &Exit Function
& & & && &End If
& & & && &i = 0
& & & && &Do
& & & && && & i = i + 1
& & & & & & & && &a(i) = strDec Mod n
& & & & & & & && &strDec = strDec \ n
& && &Loop While(strDec&&0)
& & & && &For j=i To 1 step -1
& & & && && & If a(j)&9 Then
& & & & & & & & & & & && &strReturn = strReturn & Chr(a(j)+55)
& & & && && & Else
& & & & & & & && && & strReturn = strReturn & a(j)
& & & & & & & && &End If
& & & && &Next
& & & && &Erase a
& & & && &KTON = strReturn
&&End Function
&&'调用示例
&&'参数1：&abf&是需要转换的字符串
&&'参数2：16是指需要转换字符串原来的进制
&&'参数3：8是指将要转换成进制
&&Response.Write (KTON(&abf&,16,8))
%&
复制代码
UID54845在线时间 小时积分6863帖子离线17009 天注册时间
研究一下动网里面的一些函数倒也很好。 ：）
UID41719在线时间 小时积分11880帖子离线17009 天注册时间
顶，太好了。我就是需要调用函数连接库
UID23092在线时间 小时积分21942帖子离线17009 天注册时间
一. 程序思路
　　所有的程序，主要实现两个功能，一、发送邮件；二、上传附件。使用无组件上传程序来上传附件到服务器，在发送完后，将删除服务器上的邮件。实现这两个功能，需要一个数据库来存放邮件内容及附件信息（文件名）。邮件的发送有两种情况：一是，无附件的邮件；二是，有附件的邮件。
　　１.发送无附件的邮件。用户根据实际情况来填写收信人、发信人、抄送、密送、SMTP服务器地址、邮件主题、邮件内容等信息，这些信息中，收信人、发信人、邮件主题、邮件内容是必须填写的，否则将收不到邮件。如果ＳＭＴＰ服务器支持ＳＭＴＰ验证，那么你就把你在该邮局的用户名和密码填上。如，你填的发信人地址是，因为１６３的ＳＭＴＰ服务，支持ＳＭＴＰ验证，所以你就要需要你在１６３的用户名xxxx，密码****，这样才能顺利发送邮件；如，你发信人地址是，因为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,'',cjj','','','','','测试','测试邮件件发送程序','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
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
Set objConn = Nothing
Session(&Attachment_ID&) = &&
Session.Abandon
= Trim(Request.Form(&subject&))
sUsername = Trim(Request.Form(&username&))
sPassword = TriM(Request.Form(&password&))
= Trim(Request.Form(&body&))
= Trim(Request.Form(&from&))
sFromName = Trim(Request.Form(&fromname&))
= Trim(Request.Form(&to&))
= Trim(Request.Form(&BCC&))
= 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&&)
Response.Write(sReturn)
Response.End
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)
= objRS(&From&)
= objRS(&Fromname&)
= objRS(&subject&)
= objRS(&body&)
= objRS(&to&)
= objRS(&filenames&)
= objRS(&bcc&)
= objRS(&cc&)
= objRS(&server&)
= objRS(&username&)
= 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
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&&)
Response.Write(sReturn)
'删除服务器上的附件
sAttachmentPath = Server.Mappath(&AttachmentFiles\&)
If Instr(sAddFile,&,&) && 0 Then
aryTemp = Split(sAddFile,&,&)
For i = LBound(aryTemp) To UBound(aryTemp)
Call DelFiles(sAttachmentPath & &\& & aryTemp(i))
If Trim(sAddFile) && && Then
Call DelFiles(sAttachmentPath & &\& & sAddFile)
Response.End
ElseIf sAction = &附件& Then
= Trim(Request.Form(&smtpserver&))
bSMTPCheck= Trim(Request.Form(&smtpcheck&))
If (bSMTPCheck = &True&) or (bSMTPCheck=True) Then
bSMTPCheck = True
bSMTPCheck = False
= Trim(Request.Form(&subject&))
sUsername = Trim(Request.Form(&username&))
sPassword = TriM(Request.Form(&password&))
= Trim(Request.Form(&body&))
= Trim(Request.Form(&from&))
sFromName = Trim(Request.Form(&fromname&))
= Trim(Request.Form(&to&))
= Trim(Request.Form(&BCC&))
= 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
strSQL = &SELECT * FROM [attachment]&
objRS.Open strSQL,objConn,1,2
objRS.Addnew
objRS(&SmtpCheck&) = bSMTPCheck
objRS(&username&)
= sUsername
objRS(&password&)
= sPassword
objRS(&Server&)
objRS(&Subject&)
= sSubject
objRS(&body&)
objRS(&from&)
objRS(&fromname&)
= sFromname
objRS(&bcc&)
objRS(&cc&)
objRS(&to&)
objRS.Update
Session(&Attachment_ID&) = objRS(&id&)
objRS.Close
Set objRS = Nothing
objConn.Close
Set objConn = Nothing
Response.Redirect &upload.asp&
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
= objRS(&server&)
bSMTPCheck = objRS(&SMTPCheck&)
= objRS(&Subject&)
= objRS(&body&)
= objRS(&from&)
= objRS(&fromname&)
= objRS(&to&)
= objRS(&bcc&)
= objRS(&cc&)
= objRS(&username&)
= objRS(&password&)
= objRS(&filenames&)
objConn.Close
Set objConn = Nothing
&title&发送&/title&
&meta http-equiv=&Content-Type& content=&text/ charset=gb2312&&
function scheck() {
if (form1.smtpcheck.checked)
form1.smtpcheck.value=true
form1.smtpcheck.value=
&body bgcolor=&#FFFFFF& text=&#000000&&
&form name=&form1& method=&post& action=&mail.asp&&
&p&邮件服务器
&input type=&text& name=&smtpserver& value=&&%=sServer%&&&
&input type=&text& name=&mailobject&&
&p&ＳＭＴＰ验证：
&%If bSMTPCheck Then%&
&input type=&checkbox& name=&smtpcheck& value=&true& onclick=&scheck();& checked&
&input type=&checkbox& name=&smtpcheck& value=&false& onclick=&scheck();&&
&%End If%&
&p&用户名：
&input type=&text& name=&username& value=&&%=sUsername%&&&
&p&密　码：
&input type=&text& name=&password& value=&&%=sPassword%&&&
&p&收信人地址
&input type=&text& name=&to& value=&&%=sTo%&&&
&p&发信人地址
&input type=&text& name=&from& value=&&%=sFrom%&&&
&p&发信人姓名
&input type=&text& name=&fromname& value=&&%=sFromName%&&&
&input type=&text& name=&cc& value=&&%=sCC%&&&
&input type=&text& name=&bcc& value=&&%=sBCC%&&&
&input type=&text& name=&subject& value=&&%=sSubject%&&&
&p&附　件：
&input type=&text& name=&addfile& value=&&%=sAddFile%&&&
&textarea name=&body& rows=&20& cols=&100&&&%=sBody%&
&/textarea&
&input type=&submit& name=&action& value=&发送&&
&input type=&submit& name=&action& value=&附件&&
&%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
Private Const SWEmail_JMail
Private Const SWEmail_ASPEMail
Private Const SWEmail_ASPMail
Private Const SWEmail_EasyWebmail = 4
Private Const SWEmail_CMailServer = 5
Private Const SWEmail_CDO
'本类支持的组件数,由于数组的下标是从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
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 = &&
'设置默认组件字符串
'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)
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)
If sReturn = False Then
Response.Write(&
&td&Failed&/td&& & vbcrlf)
Response.Write(&
&td&& & sReturn & &&/td&& & vbcrlf)
Response.Write(&
&/tr&& & vbcrlf)
Response.Write(&&/table&& & vbcrlf)
'自动检测服务器支持的组件并设置，如果成功返回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
Set objTest = Nothing
End Function
Function MailErr()
MailErr = SWEmail_strError
End Function
'邮件等级设置
Sub Speed(str)
'0:最慢,1:默认,2,最快
If Trim(str) = && Then
str = CInt(str)
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
SWEmail_intSpeed = 3
Case SWEmail_JMail
If str = 0 Then
SWEmail_intSpeed = 5
ElseIf str = 1 Then
SWEmail_intSpeed = 3
ElseIf str = 2 Then
SWEmail_intSpeed = 1
SWEmail_intSpeed = 3
Case SWEmail_CDO
SWEmail_intSpeed = str
End Select
'是否发送HTML邮件
Sub IsHTML(bln)
SWEmail_blnIsHTML = bln
'SMTP服务器地址
Sub Server(str)
SWEmail_strSMTPServer = str
Function Send(from,fromname,go,subject,body)
Dim sReturn
'发信人的Email地址
SWEmail_strFrom
'发信人的名字
SWEmail_strFromName = fromname
'收信人Email地址
SWEmail_strTo = go
SWEmail_strSubject = subject
SWEmail_strBody = body
sReturn = Execute()
If sReturn = True Then
Send = True
Send = sReturn
End Function
Sub BCC(str)
SWEmail_strBCC = str
Sub CC(str)
SWEmail_strCC = str
Sub AddFile(str)
SWEmail_strFiles = str
'SMTP验证,只有JMail组件可用
Sub SMTPCheck(username,password)
SWEmail_strUsername = username
SWEmail_strPassword = password
'设置邮件组件对象
Sub SetObject(str)
For i = 0 To SWEmail_intMailObjects
If SWEmail_aryMailObject(i,0) = str Then
SWEmail_strMailObject = str
SWEmail_intMailType = SWEmail_aryMailObject(i,1)
'发送邮件主体
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
'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
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
objMail.Body = SWEmail_strBody
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)
objMail.AddAttachment (SWEmail_strAttachmentPath & &\& & SWEmail_strFiles)
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)
objMail.AddAttachment (SWEmail_strAttachmentPath & &\& & SWEmail_strFiles)
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)
objMail.AddAttachment (SWEmail_strAttachmentPath & &\& & SWEmail_strFiles)
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
objMail.BodyText = MailBody
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)
objMail.AddAttachment (SWEmail_strAttachmentPath & &\& & SWEmail_strFiles)
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
objMail.EM_Text = SWEmail_strBody
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
objMail.AddAttFileString = SWEmail_strAttachmentPath & &\& & SWEmail_strFiles
If objMail.Send() = FALSE Then
SWEmail_strError= &有错误发生&
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
Case SWEmail_CDO
'微软自带发信主体
objMail.Subject = SWEmail_strSubject
objMail.From = SWEmail_strFrom
objMail.To = SWEmail_strTo
If SWEmail_blnIsHTML Then
objMail.BodyFormat = 0
objMail.BodyFormat = 1
'支持纯文本
'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,strFileName)
objMail.AttachFile (SWEmail_strAttachmentPath & &\& & SWEmail_strFiles,SWEmail_strFiles)
objMail.Send
End Select
If Err.Number && 0 Then
If Trim(err.Description) && && Then Execute = Err.Description & &&br&&
Execute = True
Set objMail = Nothing
End Function
Sub Close()
SWEmail_strMailObject = &&
SWEmail_intMailType = &&
strMailName = &&
SWEmail_strFiles = &&
SWEmail_intSpeed = &&
Erase SWEmail_aryMailObject
&提示：您可以先修改部分代码再运行
upload.asp的源码：
If Trim(Request.ServerVariables(&HTTP_REFERER&))=&& Then
'Response.Write(Request.ServerVariables(&HTTP_REFERER&))
'Response.End
Response.Redirect &mail.asp&
Response.End
&!--#include file=&inc_set.asp&--&
&title&文件上传&/title&
&meta http-equiv=&Content-Type& content=&text/ charset=gb2312&&
&style type=&text/css&&
height: 16 width: 30 border-color: black black #000000; border-top-width: 0 border-right-width: 0 border-bottom-width: 1 border-left-width: 0 font-size: 9 background-color: &%=clrGeneralTR%&; color: #0000FF}
.tx1 { height: 20 width: 30 font-size: 9 border: 1 border-color: black black #000000; color: #0000FF}
&body topmargin=&0&&
&table border=&1&&
& &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 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.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://--&
&li& 需要上传的个数
&input type=&text& name=&upcount& class=&tx& value=&2&&
&input type=&button& name=&Button& class=&button& onclick=&setid();& value=&设置&&
&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&&
&tr align=&center& valign=&middle& bgcolor=&&%=clrTitleTR%&&&
&td height=&28& bgcolor=&&%=clrTitleTR%&&&&/td&
&input type=&submit& name=&action& value=&上传& class=&button&&
&script language=&javascript&&
file://--&
&提示：您可以先修改部分代码再运行
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
strNewname = strNewname & &,& & sNewname
strNewname = objUpload.FormName(&filename1&)
'清空文本内容
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
strInfo = strInfo &
objUpload.ErrorInfo
strInfo = strInfo & objUpload.ErrorInfo
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。
需要转换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)))
strTemp = strTemp & Chr(AscB(MidB(str, i, 1)))
strTemp = Replace(Replace(Trim(strTemp),&'&,&''&),VBCRLF,&&)
BinToStr=strTemp
End Function
'*****************************************
将String转成Binary。
需要转换的String。
转换后的二进制字符串。
'*****************************************
Private Function StrToBin(str)
Dim i, binTemp
For i = 1 To Len(str)
binTemp = binTemp & ChrB(Asc(Mid(str,I,1)))
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
'-----------------------------7da
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
strFileName = sFileName
'文件开始位置
intFileStart = iInfoEnd
intFileSize = iFormStart -iInfoEnd
'binFileContent = MidB(formdata,intFileStart,intFileSize)
'添加文件,以文件名为关键字
If Not objFiles.Exists(sFileName) Then
objFiles.Add sFileName,intFileStart & &,& & intFileSize
strErrorInfo = strErrorInfo & &&br&文件 &b&& & sFileName & &&/b& 已经存在！&
'统计文件个数
intFileCount = intFileCount + 1
'如果是表单项目
iValEnd = iFormStart-iInfoEnd-3
If iValEnd& 0 Then
sFormValue = MidB(formdata,iValStart,iValEnd)
sFormValue = &&
binTxtData = binTxtData & sFormname & StrToBin(&:&) & sFormValue & StrToBin(&&&&)
iFormStart=iFormStart + iStart + 1
formdata=&&
'*****************************************
限制文件上传的类型,只能许sAllow格式的文件
strLimit，允许上传的文件格式，多种格式用|分开
允许上传的文件格式（多种格式用|分开）
'*****************************************
Sub AllowFiles(sAllow)
strAllowed = sAllow
'*****************************************
检查文件后缀是否为被允许的文件格式
如果是允许的文件格式返回True,否则返回False
'*****************************************
Function IsAllowed(filename)
Dim intStart
IsAllowed = False
If strAllowed = && Then
IsAllowed = True
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 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
strErrorInfo = strErrorInfo & &&br&文件 &font color=&&#ff00000&&&& & sFileName & &&/font& 为不被允许上传的文件，请检查文件后缀&br&&
SaveFile = False
'Exit Function
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
strErrorInfo = strErrorInfo & &&br&文件 &Font Color=&&#FF0000&&&& & sFileName & &&/font& 为不被允许上传的文件，请检查文件后缀！&
SaveFile = False
'Exit Function
objSaveFile.Close
Set objSaveFile = Nothing
objData.Close
Set objData = Nothing
Set objFiles = Nothing
'If err.Number && 0 Then SaveFile = False
End Function
'*****************************************
获取表单项的值
为要寻找的字段变量
为已从图象中分离出来的的所有文本
表单项的值
'*****************************************
Function FindInput(fName,txtdata)
Dim intStartPos,intEndPos,intNameLen,intValEnd,i,bReturn
intStartPos = 1
intNameLen = LenB(StrToBin(&name=&&& & fName & &:&))
intStartPos = InstrB(intStartPos,txtdata,fName,1) + intNameLen
If intStartPos & intNameLen Then
intEndPos = InstrB(intStartPos-3,txtdata,StrToBin(&&&&))
bReturn = bReturn & MidB(txtdata,intStartPos,intEndPos-intStartPos)
intValEnd = intEndPos
'表单中可能有多个同名变量(用在有主表与明细表中的数据更新中）
intStartPos = Instr(intValEnd,txtdata,fName) + intNameLen
If intStartPos & intNameLen Then
intValEnd = Instr(intStartPos,txtdata,&&&&)
bReturn = bReturn & &,& & Mid(intStartPos,txtdata,intEndPos-intStartPos)
Loop While (intStartPos & intNameLen)
FindInput = bReturn
End Function
'*****************************************
检测文件是否存在
filename：
文件存在返回False,文件不存在返回True
'*****************************************
Function FileExist(filename)
Dim objFSO,objFile
Dim sPath,sError
FileExist = False
If Trim(filename) = && Then
strErrorInfo = strErrorInfo
& &&Br&文件名不能为空！&
Exit Function
Set objFSO = Server.CreateObject(&Scripting.FileSystemObject&)
If Instr(filename,&,&)&0 Then
'Response.Write(&&br&@& & filename & &@&br&&)
aryFileName = Split(filename,&,&)
For i = LBound(aryFileName) To UBound(aryFileName)
'Response.Write(&&br&file:& & strFilePath &&#& &
aryFileName(i) & &&br&&)
sPath = Server.Mappath(strFilePath & aryFileName(i))
If objFSO.FileExists(sPath) Then
sError = sError & &&br&文件 & & aryFileName(i) & & 已经存在！&
sPath = Server.Mappath(strFilePath & filename)
If objFSO.FileExists(sPath) Then
sError = sError & &&br&文件 & & filename & & 已经存在!&
Set objFSO = Nothing
If Trim(sError) && && Then
strErrorInfo = strErrorInfo & sError
FileExist = True
End Function
'*****************************************
获取表单项的值
为要寻找的字段变量
转成普通字符串后的表单项的值
'*****************************************
Function FormName(aName)
Dim binFormName,binTest
'binTxtData已经分离出来的文件数据
binFormName = FindInput(aName,binTxtData)
FormName = BinToStr(binFormName)
End Function
'*****************************************
设置文件存放路径
文件存放相对路径
将输入的str赋给Class级变量FilePath,记录文件相对路径
'*****************************************
Sub SetPath(str)
strFilePath = str & &\&
'*****************************************
获取文件存放相对路径
返回文件存放相对路径
'*****************************************
Function GetPath()
GetPath = strFilePath
End Function
'*****************************************
获取错误信息
返回错误信息
'*****************************************
Function ErrorInfo()
ErrorInfo = strErrorInfo
End Function
'*****************************************
获取文件名或文件名列表
文件名或文件名列表
'*****************************************
Function FileName()
FileName = strFileName
End Function
&提示：您可以先修改部分代码再运行
inc_set.asp的源码：
&%
& &Private Const HTMLTitle = &WEB内容管理系统&
& &'ＴＯＰ。ｈｔｍ中行的颜色
& &Private Const ClrTopTR = &#D1A798&
& &'表格的颜色
& &Private Const clrLeftTD = &#B57560&
& &Private Const clrRightTD = &#A6624A&
& &Private Const clrTitleTR = &#C18B79&
& &Private Const clrGeneralTR = &#CEA293&
& &Private Const clrBottmTR = &#C18B79&
%&
复制代码
四、商业应用中的问题
　　优点：1.支持多种发送邮件组件；
　　　　　　2.支持发送多附件。
　　缺点：1.对附件大小没有限制；
　　　　　　2.如果附件已经存在于服务器上，无法再上传；
　　　　　　3.对填写的表单信息是否为空，没进行判断;
五、注意事项
　　本程序主要目的是学习，不适合用于商业，因为在使用中还有问题存在，当然你可以对其进行完善再应用到商业上。大家，在使用过程中，如发现问题，可以到论坛问/bbs，也可以发email给我(也是我的ＭＳＮ地址)。最后，感谢各位兄弟帮忙测试。Ｊmail部分代码已测试通过，用ＣＤＯ发附件，及其它发信组件还没有测试，由于条件有限，只能到此为止了。
　　还有一点，在存入程序文件的目录下，需要建一文件夹attachmentfiles（用于存放附件），此文件夹是必须的。
/tech/program/.asp
UID74285在线时间 小时积分289帖子离线17009 天注册时间
中级会员, 积分 289, 距离下一级还需 211 积分
感谢~~~很有用啊~~
UID73157在线时间 小时积分61帖子离线17009 天注册时间
初级会员, 积分 61, 距离下一级还需 139 积分
有没有求字符打打度的函数，谢谢帮忙
UID48315在线时间 小时积分297帖子离线17009 天注册时间
中级会员, 积分 297, 距离下一级还需 203 积分
分页的那个类中在init()里面少了一句
SW_objRS.pagesize = SW_intPageSize
UID23092在线时间 小时积分21942帖子离线17009 天注册时间
本来还想把MD5及其它的一些HASH算法整合进来，后来想想觉得没啥用，就不干了
[VBS]描述SHA算法（SHA-1\SHA-256）：
&%Option Explicit
'Homepage :
'一些常见Hash算法的类，sha-1、sha-256等
Class HashEncode
Private m_lOnBits(30),m_l2Power(30)
Private K(80)
BITS_TO_A_BYTE,BYTES_TO_A_WORD,BITS_TO_A_WORD
'#######################HASH算法通用函数开始#################
Private Function SHL(lValue, iBits)
If iBits = 0 Then
SHL = lValue
Exit Function
ElseIf iBits = 31 Then
If lValue And 1 Then
Exit Function
ElseIf iBits & 0 Or iBits & 31 Then
Err.Raise 6
If (lValue And m_l2Power(31 - iBits)) Then
SHL = ((lValue And m_lOnBits(31 - (iBits + 1))) * m_l2Power(iBits)) Or &H
SHL = ((lValue And m_lOnBits(31 - iBits)) * m_l2Power(iBits))
End Function
Private Function SHR(lValue, iBits)
If iBits = 0 Then
SHR = lValue
Exit Function
ElseIf iBits = 31 Then
If lValue And &H Then
Exit Function
ElseIf iBits & 0 Or iBits & 31 Then
Err.Raise 6
SHR = (lValue And &H7FFFFFFE) \ m_l2Power(iBits)
If (lValue And &H) Then
SHR = (SHR Or (&H \ m_l2Power(iBits - 1)))
End Function
Private Function AddUnsigned(lX, lY)
Dim lResult
lX8 = lX And &H
lY8 = lY And &H
lX4 = lX And &H
lY4 = lY And &H
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
lResult = lResult Xor &H Xor lX8 Xor lY8
lResult = lResult Xor lX8 Xor lY8
AddUnsigned = lResult
End Function
'将字符串转成32位字数组(将字符串转成 双字 数组)
Private Function ConvertToWordArray(sMsg)
Dim lMsgLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448
lMsgLength = Len(sMsg)
lNumberOfWords = (((lMsgLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount &= lMsgLength
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
lByte = AscB(Mid(sMsg, lByteCount + 1, 1))
lWordArray(lWordCount) = lWordArray(lWordCount) Or SHL(lByte, lBytePosition)
lByteCount = lByteCount + 1
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or SHL(&H80, lBytePosition)
lWordArray(lNumberOfWords - 1) = SHL(lMsgLength, 3)
lWordArray(lNumberOfWords - 2) = SHR(lMsgLength, 29)
ConvertToWordArray = lWordArray
End Function
'########################HASH算法通用函数结束################
'********************SHA算法专用函数开始*********************
Private Function ROTR(x, n)
ROTR = (SHR(x, (n And m_lOnBits(4))) Or SHL(x, (32 - (n And m_lOnBits(4)))))
End Function
Private Function ROTL(x, n)
ROTL = (SHL(x, (n And m_lOnBits(4))) Or SHR(x, (32 - (n And m_lOnBits(4)))))
End Function
Private Function Sigma0(x)
Sigma0 = (ROTR(x, 2) Xor ROTR(x, 13) Xor ROTR(x, 22))
End Function
Private Function Sigma1(x)
Sigma1 = (ROTR(x, 6) Xor ROTR(x, 11) Xor ROTR(x, 25))
End Function
Private Function Gamma0(x)
Gamma0 = (ROTR(x, 7) Xor ROTR(x, 18) Xor SHR(x, CInt(3 And m_lOnBits(4))))
End Function
Private Function Gamma1(x)
Gamma1 = (ROTR(x, 17) Xor ROTR(x, 19) Xor SHR(x, CInt(10 And m_lOnBits(4))))
End Function
Private Function Ch(x, y, z)
Ch = ((x And y) Xor ((Not x) And z))
End Function
Private Function Maj(x, y, z)
Maj = ((x And y) Xor (x And z) Xor (y And z))
End Function
Private Function Parity(x,y,z)
Parity = x XOR y XOR z
End Function
Private Function F1(x,y,z,t)
Select Case Int(t / 20)
F1 = CH(x,y,z)
F1 = Parity(x,y,z)
F1 = Maj(x,y,z)
F1 = Parity(x,y,z)
End Select
End Function
Private Sub HashInit(a_Type)
Select Case LCase(Trim(a_Type))
Case &sha1&
For i = 0 To 79
Select Case Int(i/20)
K(i) = &H5a827999
K(i) = &H6ed9eba1
K(i) = &H8f1bbcdc
K(i) = &Hca62c1d6
End Select
Case &sha256&
K(0) = &H428A2F98
K(2) = &HB5C0FBCF
K(3) = &HE9B5DBA5
K(4) = &H3956C25B
K(5) = &H59F111F1
K(6) = &H923F82A4
K(7) = &HAB1C5ED5
K(8) = &HD807AA98
K(9) = &H12835B01
K(10) = &H243185BE
K(11) = &H550C7DC3
K(12) = &H72BE5D74
K(13) = &H80DEB1FE
K(14) = &H9BDC06A7
K(15) = &HC19BF174
K(16) = &HE49B69C1
K(17) = &HEFBE4786
K(18) = &HFC19DC6
K(19) = &H240CA1CC
K(20) = &H2DE92C6F
K(21) = &H4A7484AA
K(22) = &H5CB0A9DC
K(23) = &H76F988DA
K(24) = &H983E5152
K(25) = &HA831C66D
K(26) = &HB00327C8
K(27) = &HBF597FC7
K(28) = &HC6E00BF3
K(29) = &HD5A79147
K(30) = &H6CA6351
K(31) = &H
K(32) = &H27B70A85
K(33) = &H2E1B2138
K(34) = &H4D2C6DFC
K(35) = &H53380D13
K(36) = &H650A7354
K(37) = &H766A0ABB
K(38) = &H81C2C92E
K(39) = &H92722C85
K(40) = &HA2BFE8A1
K(41) = &HA81A664B
K(42) = &HC24B8B70
K(43) = &HC76C51A3
K(44) = &HD192E819
K(45) = &HD6990624
K(46) = &HF40E3585
K(47) = &H106AA070
K(48) = &H19A4C116
K(49) = &H1E376C08
K(50) = &H2748774C
K(51) = &H34B0BCB5
K(52) = &H391C0CB3
K(53) = &H4ED8AA4A
K(54) = &H5B9CCA4F
K(55) = &H682E6FF3
K(56) = &H748F82EE
K(57) = &H78A5636F
K(58) = &H84C87814
K(59) = &H8CC70208
K(60) = &H90BEFFFA
K(61) = &HA4506CEB
K(62) = &HBEF9A3F7
K(63) = &HC67178F2
End Select
'********************SHA算法专用函数结束*********************
Public Function Execute(a_Type,a_Msg)
Dim HASH(7),W(80)
Dim a,b,c,d,e,f,g,h,str,sReturn
Dim T,T1,T2
M = ConvertToWordArray(a_msg)
Call HashInit(a_Type)
Select Case LCase(Trim(a_type))
Case &sha1&
'初始化常量
HASH(0) = &H
HASH(1) = &HEFCDAB89
HASH(2) = &H98BADCFE
HASH(3) = &H
HASH(4) = &HC3D2E1F0
For i = 0 To UBound(M) Step 16
a = HASH(0)
b = HASH(1)
c = HASH(2)
d = HASH(3)
e = HASH(4)
For j = 0 To 79
If j & 16 Then
W(j) = M(j + i)
W(j) = ROTL(W(j-3) XOR W(j-8) XOR W(j-14) XOR W(j-16),1)
T =AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(ROTL(a,5),F1(b,c,d,j)),e),K(j)),W(j))
c = ROTL(b,30)
HASH(0) = AddUnsigned(a, HASH(0))
HASH(1) = AddUnsigned(b, HASH(1))
HASH(2) = AddUnsigned(c, HASH(2))
HASH(3) = AddUnsigned(d, HASH(3))
HASH(4) = AddUnsigned(e, HASH(4))
sReturn = LCase(Right(&& & Hex(HASH(0)), 8) & Right(&& & Hex(HASH(1)), 8) & Right(&& & Hex(HASH(2)), 8) & Right(&& & Hex(HASH(3)), 8) & Right(&& & Hex(HASH(4)), 8))
Case &sha256&
'初始化常量
HASH(0) = &H6A09E667
HASH(1) = &HBB67AE85
HASH(2) = &H3C6EF372
HASH(3) = &HA54FF53A
HASH(4) = &H510E527F
HASH(5) = &H9B05688C
HASH(6) = &H1F83D9AB
HASH(7) = &H5BE0CD19
For i = 0 To UBound(M) Step 16 'For i = 1 To N
'Initialize the eight working variables
a = HASH(0)
b = HASH(1)
c = HASH(2)
d = HASH(3)
e = HASH(4)
f = HASH(5)
g = HASH(6)
h = HASH(7)
For j = 0 To 63
'Prepare the message schedule W(t)
If j & 16 Then
W(j) = M(j + i)
W(j) = AddUnsigned(AddUnsigned(AddUnsigned(Gamma1(W(j - 2)), W(j - 7)), Gamma0(W(j - 15))), W(j - 16))
'For t = 0
T1 = AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(h, Sigma1(e)), Ch(e, f, g)), K(j)), W(j))
T2 = AddUnsigned(Sigma0(a), Maj(a, b, c))
e = AddUnsigned(d, T1)
a = AddUnsigned(T1, T2)
HASH(0) = AddUnsigned(a, HASH(0))
HASH(1) = AddUnsigned(b, HASH(1))
HASH(2) = AddUnsigned(c, HASH(2))
HASH(3) = AddUnsigned(d, HASH(3))
HASH(4) = AddUnsigned(e, HASH(4))
HASH(5) = AddUnsigned(f, HASH(5))
HASH(6) = AddUnsigned(g, HASH(6))
HASH(7) = AddUnsigned(h, HASH(7))
sReturn = LCase(Right(&& & Hex(HASH(0)), 8) & Right(&& & Hex(HASH(1)), 8) & Right(&& & Hex(HASH(2)), 8) & Right(&& & Hex(HASH(3)), 8) & Right(&& & Hex(HASH(4)), 8) & Right(&& & Hex(HASH(5)), 8) & Right(&& & Hex(HASH(6)), 8) & Right(&& & Hex(HASH(7)), 8))
End Select
Execute = sReturn
End Function
'*****************************************
'*****************************************
Private Sub Class_Initialize()
BITS_TO_A_BYTE = 8
BYTES_TO_A_WORD = 4
BITS_TO_A_WORD = 32
For i = 0 To 30
m_lOnBits(i) = CLng(2^j-1)
m_l2Power(i) = CLng(2^i)
'调用Class
Dim sMsg,sResult
Set oHash = New HashEncode
sMsg = &abc&
sResult = oHash.Execute(&sha1&,sMsg)
sResult = oHash.Execute(&sha256&,&abc&)
&提示：您可以先修改部分代码再运行
Powered by